-- | Computing fingerprints of values serializeable 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

fingerprintBinMem :: BinHandle -> IO Fingerprint
fingerprintBinMem :: BinHandle -> IO Fingerprint
fingerprintBinMem BinHandle
bh = BinHandle -> (ByteString -> IO Fingerprint) -> IO Fingerprint
forall a. BinHandle -> (ByteString -> IO a) -> IO a
withBinBuffer BinHandle
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)
                   => (BinHandle -> Name -> IO ())
                   -> a
                   -> IO Fingerprint
computeFingerprint :: forall a.
Binary a =>
(BinHandle -> Name -> IO ()) -> a -> IO Fingerprint
computeFingerprint BinHandle -> Name -> IO ()
put_nonbinding_name a
a = do
    BinHandle
bh <- (BinHandle -> BinHandle) -> IO BinHandle -> IO BinHandle
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BinHandle -> BinHandle
set_user_data (IO BinHandle -> IO BinHandle) -> IO BinHandle -> IO BinHandle
forall a b. (a -> b) -> a -> b
$ Int -> IO BinHandle
openBinMem (Int
3Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
1024) -- just less than a block
    BinHandle -> a -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh a
a
    BinHandle -> IO Fingerprint
fingerprintBinMem BinHandle
bh
  where
    set_user_data :: BinHandle -> BinHandle
set_user_data BinHandle
bh =
      BinHandle -> UserData -> BinHandle
setUserData BinHandle
bh (UserData -> BinHandle) -> UserData -> BinHandle
forall a b. (a -> b) -> a -> b
$ (BinHandle -> Name -> IO ())
-> (BinHandle -> Name -> IO ())
-> (BinHandle -> FastString -> IO ())
-> UserData
newWriteState BinHandle -> Name -> IO ()
put_nonbinding_name BinHandle -> Name -> IO ()
putNameLiterally BinHandle -> FastString -> IO ()
putFS

-- | Used when we want to fingerprint a structure without depending on the
-- fingerprints of external Names that it refers to.
putNameLiterally :: BinHandle -> Name -> IO ()
putNameLiterally :: BinHandle -> Name -> IO ()
putNameLiterally BinHandle
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
    BinHandle -> Module -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Module -> IO ()) -> Module -> IO ()
forall a b. (a -> b) -> a -> b
$! (() :: Constraint) => Name -> Module
Name -> Module
nameModule Name
name
    BinHandle -> OccName -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (OccName -> IO ()) -> OccName -> IO ()
forall a b. (a -> b) -> a -> b
$! Name -> OccName
nameOccName Name
name