-- -fno-cse is here because of anonymousNamedPrim - see the comments on that
{-# OPTIONS_GHC -fno-cse #-}
-- | Wrapper for prim patches to give them an identity derived from the identity
-- of the containined Named patch.
module Darcs.Patch.Prim.Named
    ( NamedPrim
    -- accessors
    , PrimPatchId
    , namedPrim
    , positivePrimPatchIds
    , anonymousNamedPrim
    -- for testing
    , unsafePrimPatchId
    , prop_primPatchIdNonZero
    ) where

import Control.Monad ( mzero )

import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy as BL

import qualified Data.Binary as Binary
import Crypto.Random ( getRandomBytes )
import System.IO.Unsafe ( unsafePerformIO )

import Darcs.Prelude hiding ( take )

import Darcs.Patch.Ident ( PatchId, SignedId(..), StorableId(..) )
import Darcs.Patch.Info ( PatchInfo, makePatchname )
import Darcs.Patch.Prim.WithName ( PrimWithName(..) )
import Darcs.Patch.Show ( ShowPatchFor(..) )

import Darcs.Test.TestOnly
import Darcs.Util.Hash ( SHA1, sha1Show, sha1Read )
import Darcs.Util.Parser
import Darcs.Util.Printer

-- TODO [V3INTEGRATION]:
-- Review whether we can use a PatchInfo directly here instead of a SHA1
-- Unless we can use observable sharing, this might be significantly
-- slower/less space efficient.
-- | Signed patch identity.
-- The 'SHA1' hash of the non-inverted meta data ('PatchInfo') plus an 'Int'
-- for the sequence number within the named patch, starting with 1. The 'Int'
-- gets inverted together with the patch and must never be 0 else we could not
-- distinguish between the patch and its inverse.
data PrimPatchId = PrimPatchId !Int !SHA1
  deriving (PrimPatchId -> PrimPatchId -> Bool
(PrimPatchId -> PrimPatchId -> Bool)
-> (PrimPatchId -> PrimPatchId -> Bool) -> Eq PrimPatchId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PrimPatchId -> PrimPatchId -> Bool
== :: PrimPatchId -> PrimPatchId -> Bool
$c/= :: PrimPatchId -> PrimPatchId -> Bool
/= :: PrimPatchId -> PrimPatchId -> Bool
Eq, Eq PrimPatchId
Eq PrimPatchId =>
(PrimPatchId -> PrimPatchId -> Ordering)
-> (PrimPatchId -> PrimPatchId -> Bool)
-> (PrimPatchId -> PrimPatchId -> Bool)
-> (PrimPatchId -> PrimPatchId -> Bool)
-> (PrimPatchId -> PrimPatchId -> Bool)
-> (PrimPatchId -> PrimPatchId -> PrimPatchId)
-> (PrimPatchId -> PrimPatchId -> PrimPatchId)
-> Ord PrimPatchId
PrimPatchId -> PrimPatchId -> Bool
PrimPatchId -> PrimPatchId -> Ordering
PrimPatchId -> PrimPatchId -> PrimPatchId
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: PrimPatchId -> PrimPatchId -> Ordering
compare :: PrimPatchId -> PrimPatchId -> Ordering
$c< :: PrimPatchId -> PrimPatchId -> Bool
< :: PrimPatchId -> PrimPatchId -> Bool
$c<= :: PrimPatchId -> PrimPatchId -> Bool
<= :: PrimPatchId -> PrimPatchId -> Bool
$c> :: PrimPatchId -> PrimPatchId -> Bool
> :: PrimPatchId -> PrimPatchId -> Bool
$c>= :: PrimPatchId -> PrimPatchId -> Bool
>= :: PrimPatchId -> PrimPatchId -> Bool
$cmax :: PrimPatchId -> PrimPatchId -> PrimPatchId
max :: PrimPatchId -> PrimPatchId -> PrimPatchId
$cmin :: PrimPatchId -> PrimPatchId -> PrimPatchId
min :: PrimPatchId -> PrimPatchId -> PrimPatchId
Ord, Int -> PrimPatchId -> ShowS
[PrimPatchId] -> ShowS
PrimPatchId -> String
(Int -> PrimPatchId -> ShowS)
-> (PrimPatchId -> String)
-> ([PrimPatchId] -> ShowS)
-> Show PrimPatchId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PrimPatchId -> ShowS
showsPrec :: Int -> PrimPatchId -> ShowS
$cshow :: PrimPatchId -> String
show :: PrimPatchId -> String
$cshowList :: [PrimPatchId] -> ShowS
showList :: [PrimPatchId] -> ShowS
Show)

-- | This should only be used for testing, as it exposes the internal structure
-- of a 'PrimPatchId'.
unsafePrimPatchId :: TestOnly => Int -> SHA1 -> PrimPatchId
unsafePrimPatchId :: TestOnly => Int -> SHA1 -> PrimPatchId
unsafePrimPatchId = Int -> SHA1 -> PrimPatchId
PrimPatchId

prop_primPatchIdNonZero :: PrimPatchId -> Bool
prop_primPatchIdNonZero :: PrimPatchId -> Bool
prop_primPatchIdNonZero (PrimPatchId Int
i SHA1
_) = Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0

instance SignedId PrimPatchId where
  positiveId :: PrimPatchId -> Bool
positiveId (PrimPatchId Int
i SHA1
_) = Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
  invertId :: PrimPatchId -> PrimPatchId
invertId (PrimPatchId Int
i SHA1
h) = Int -> SHA1 -> PrimPatchId
PrimPatchId (- Int
i) SHA1
h

-- | Create an infinite list of positive 'PrimPatchId's.
positivePrimPatchIds :: PatchInfo -> [PrimPatchId]
positivePrimPatchIds :: PatchInfo -> [PrimPatchId]
positivePrimPatchIds PatchInfo
info = (Int -> PrimPatchId) -> [Int] -> [PrimPatchId]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> SHA1 -> PrimPatchId) -> SHA1 -> Int -> PrimPatchId
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> SHA1 -> PrimPatchId
PrimPatchId (PatchInfo -> SHA1
makePatchname PatchInfo
info)) [Int
1..]

type NamedPrim = PrimWithName PrimPatchId

namedPrim :: PrimPatchId -> p wX wY -> NamedPrim p wX wY
namedPrim :: forall (p :: * -> * -> *) wX wY.
PrimPatchId -> p wX wY -> NamedPrim p wX wY
namedPrim = PrimPatchId -> p wX wY -> PrimWithName PrimPatchId p wX wY
forall name (p :: * -> * -> *) wX wY.
name -> p wX wY -> PrimWithName name p wX wY
PrimWithName

type instance PatchId (NamedPrim p) = PrimPatchId

-- TODO [V3INTEGRATION]:
-- It might be nice to elide the patch identifiers from the
-- on-disk format when they are the same as that of the containing patch
-- (which is the common case when there are no conflicts).
-- It's not that easy to implement as it requires refactoring to pass
-- the patch identifier downwards.
-- The sequence numbers could also be inferred from position.
instance StorableId PrimPatchId where
  readId :: Parser PrimPatchId
readId = do
    ByteString -> Parser ()
lexString (String -> ByteString
BC.pack String
"hash")
    Int
i <- Parser Int
int
    Parser ()
skipSpace
    ByteString
x <- Int -> Parser ByteString
take Int
40
    Maybe PrimPatchId -> Parser PrimPatchId
forall {a}. Maybe a -> Parser ByteString a
liftMaybe (Maybe PrimPatchId -> Parser PrimPatchId)
-> Maybe PrimPatchId -> Parser PrimPatchId
forall a b. (a -> b) -> a -> b
$ Int -> SHA1 -> PrimPatchId
PrimPatchId Int
i (SHA1 -> PrimPatchId) -> Maybe SHA1 -> Maybe PrimPatchId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Maybe SHA1
sha1Read ByteString
x
   where
     liftMaybe :: Maybe a -> Parser ByteString a
liftMaybe = Parser ByteString a
-> (a -> Parser ByteString a) -> Maybe a -> Parser ByteString a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Parser ByteString a
forall a. Parser ByteString a
forall (m :: * -> *) a. MonadPlus m => m a
mzero a -> Parser ByteString a
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return

  showId :: ShowPatchFor -> PrimPatchId -> Doc
showId ShowPatchFor
ForStorage (PrimPatchId Int
i SHA1
h) =
    String -> Doc
text String
"hash" Doc -> Doc -> Doc
<+> String -> Doc
text (Int -> String
forall a. Show a => a -> String
show Int
i) Doc -> Doc -> Doc
<+> ByteString -> Doc
packedString (SHA1 -> ByteString
sha1Show SHA1
h)
  showId ShowPatchFor
ForDisplay PrimPatchId
_ = Doc
forall a. Monoid a => a
mempty

-- Because we are using unsafePerformIO, we need -fno-cse for
-- this module. We don't need -fno-full-laziness because the
-- body of the unsafePerformIO mentions 'p' so can't float outside
-- the scope of 'p'.
-- http://hackage.haskell.org/package/base-4.12.0.0/docs/System-IO-Unsafe.html
{-# NOINLINE anonymousNamedPrim #-}
anonymousNamedPrim :: p wX wY -> NamedPrim p wX wY
anonymousNamedPrim :: forall (p :: * -> * -> *) wX wY. p wX wY -> NamedPrim p wX wY
anonymousNamedPrim p wX wY
p =
  IO (NamedPrim p wX wY) -> NamedPrim p wX wY
forall a. IO a -> a
unsafePerformIO (IO (NamedPrim p wX wY) -> NamedPrim p wX wY)
-> IO (NamedPrim p wX wY) -> NamedPrim p wX wY
forall a b. (a -> b) -> a -> b
$ do
    ByteString
b20 <- Int -> IO ByteString
forall byteArray. ByteArray byteArray => Int -> IO byteArray
forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
getRandomBytes Int
20
    ByteString
b8 <- Int -> IO ByteString
forall byteArray. ByteArray byteArray => Int -> IO byteArray
forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
getRandomBytes Int
8
    NamedPrim p wX wY -> IO (NamedPrim p wX wY)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (NamedPrim p wX wY -> IO (NamedPrim p wX wY))
-> NamedPrim p wX wY -> IO (NamedPrim p wX wY)
forall a b. (a -> b) -> a -> b
$
      PrimPatchId -> p wX wY -> NamedPrim p wX wY
forall name (p :: * -> * -> *) wX wY.
name -> p wX wY -> PrimWithName name p wX wY
PrimWithName
        (Int -> SHA1 -> PrimPatchId
PrimPatchId
           (Int -> Int
forall a. Num a => a -> a
abs (ByteString -> Int
forall a. Binary a => ByteString -> a
Binary.decode (ByteString -> Int) -> ByteString -> Int
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.fromStrict ByteString
b8))
           (ByteString -> SHA1
forall a. Binary a => ByteString -> a
Binary.decode (ByteString -> SHA1) -> ByteString -> SHA1
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.fromStrict ByteString
b20))
        p wX wY
p