-- | Computing fingerprints of values serializable with GHC's \"Binary\" module.
module GHC.Iface.Recomp.Binary
  ( -- * Computing fingerprints
    fingerprintBinMem
  , computeFingerprint
  , putNameLiterally
  ) where

import GHC.Prelude

import GHC.Utils.Fingerprint
import GHC.Utils.Binary
import GHC.Types.Name
import GHC.Utils.Panic.Plain
import GHC.Iface.Type (putIfaceType)

fingerprintBinMem :: WriteBinHandle -> IO Fingerprint
fingerprintBinMem :: WriteBinHandle -> IO Fingerprint
fingerprintBinMem WriteBinHandle
bh = WriteBinHandle -> (ByteString -> IO Fingerprint) -> IO Fingerprint
forall a. WriteBinHandle -> (ByteString -> IO a) -> IO a
withBinBuffer WriteBinHandle
bh ByteString -> IO Fingerprint
forall {m :: * -> *}. Monad m => ByteString -> m Fingerprint
f
  where
    f :: ByteString -> m Fingerprint
f ByteString
bs =
        -- we need to take care that we force the result here
        -- lest a reference to the ByteString may leak out of
        -- withBinBuffer.
        let fp :: Fingerprint
fp = ByteString -> Fingerprint
fingerprintByteString ByteString
bs
        in Fingerprint
fp Fingerprint -> m Fingerprint -> m Fingerprint
forall a b. a -> b -> b
`seq` Fingerprint -> m Fingerprint
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Fingerprint
fp

computeFingerprint :: (Binary a)
                   => (WriteBinHandle -> Name -> IO ())
                   -> a
                   -> IO Fingerprint
computeFingerprint :: forall a.
Binary a =>
(WriteBinHandle -> Name -> IO ()) -> a -> IO Fingerprint
computeFingerprint WriteBinHandle -> Name -> IO ()
put_nonbinding_name a
a = do
    bh <- (WriteBinHandle -> WriteBinHandle)
-> IO WriteBinHandle -> IO WriteBinHandle
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap WriteBinHandle -> WriteBinHandle
set_user_data (IO WriteBinHandle -> IO WriteBinHandle)
-> IO WriteBinHandle -> IO WriteBinHandle
forall a b. (a -> b) -> a -> b
$ Int -> IO WriteBinHandle
openBinMem (Int
3Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
1024) -- just less than a block
    put_ bh a
    fingerprintBinMem bh
  where
    set_user_data :: WriteBinHandle -> WriteBinHandle
set_user_data WriteBinHandle
bh = WriteBinHandle -> WriterUserData -> WriteBinHandle
setWriterUserData WriteBinHandle
bh (WriterUserData -> WriteBinHandle)
-> WriterUserData -> WriteBinHandle
forall a b. (a -> b) -> a -> b
$ [SomeBinaryWriter] -> WriterUserData
mkWriterUserData
      [ BinaryWriter IfaceType -> SomeBinaryWriter
forall a. Typeable a => BinaryWriter a -> SomeBinaryWriter
mkSomeBinaryWriter (BinaryWriter IfaceType -> SomeBinaryWriter)
-> BinaryWriter IfaceType -> SomeBinaryWriter
forall a b. (a -> b) -> a -> b
$ (WriteBinHandle -> IfaceType -> IO ()) -> BinaryWriter IfaceType
forall s. (WriteBinHandle -> s -> IO ()) -> BinaryWriter s
mkWriter WriteBinHandle -> IfaceType -> IO ()
putIfaceType
      , BinaryWriter Name -> SomeBinaryWriter
forall a. Typeable a => BinaryWriter a -> SomeBinaryWriter
mkSomeBinaryWriter (BinaryWriter Name -> SomeBinaryWriter)
-> BinaryWriter Name -> SomeBinaryWriter
forall a b. (a -> b) -> a -> b
$ (WriteBinHandle -> Name -> IO ()) -> BinaryWriter Name
forall s. (WriteBinHandle -> s -> IO ()) -> BinaryWriter s
mkWriter WriteBinHandle -> Name -> IO ()
put_nonbinding_name
      , BinaryWriter BindingName -> SomeBinaryWriter
forall a. Typeable a => BinaryWriter a -> SomeBinaryWriter
mkSomeBinaryWriter (BinaryWriter BindingName -> SomeBinaryWriter)
-> BinaryWriter BindingName -> SomeBinaryWriter
forall a b. (a -> b) -> a -> b
$ BinaryWriter Name -> BinaryWriter BindingName
simpleBindingNameWriter (BinaryWriter Name -> BinaryWriter BindingName)
-> BinaryWriter Name -> BinaryWriter BindingName
forall a b. (a -> b) -> a -> b
$ (WriteBinHandle -> Name -> IO ()) -> BinaryWriter Name
forall s. (WriteBinHandle -> s -> IO ()) -> BinaryWriter s
mkWriter WriteBinHandle -> Name -> IO ()
putNameLiterally
      , BinaryWriter FastString -> SomeBinaryWriter
forall a. Typeable a => BinaryWriter a -> SomeBinaryWriter
mkSomeBinaryWriter (BinaryWriter FastString -> SomeBinaryWriter)
-> BinaryWriter FastString -> SomeBinaryWriter
forall a b. (a -> b) -> a -> b
$ (WriteBinHandle -> FastString -> IO ()) -> BinaryWriter FastString
forall s. (WriteBinHandle -> s -> IO ()) -> BinaryWriter s
mkWriter WriteBinHandle -> FastString -> IO ()
putFS
      ]

-- | Used when we want to fingerprint a structure without depending on the
-- fingerprints of external Names that it refers to.
putNameLiterally :: WriteBinHandle -> Name -> IO ()
putNameLiterally :: WriteBinHandle -> Name -> IO ()
putNameLiterally WriteBinHandle
bh Name
name = Bool -> IO () -> IO ()
forall a. HasCallStack => Bool -> a -> a
assert (Name -> Bool
isExternalName Name
name) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    WriteBinHandle -> Module -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh (Module -> IO ()) -> Module -> IO ()
forall a b. (a -> b) -> a -> b
$! HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
name
    WriteBinHandle -> OccName -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh (OccName -> IO ()) -> OccName -> IO ()
forall a b. (a -> b) -> a -> b
$! Name -> OccName
nameOccName Name
name