{-# LANGUAGE CPP #-}

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

#include "HsVersions.h"

import GHC.Prelude

import GHC.Utils.Fingerprint
import GHC.Utils.Binary
import GHC.Types.Name
import GHC.Utils.Panic.Plain
import GHC.Utils.Misc

fingerprintBinMem :: BinHandle -> IO Fingerprint
fingerprintBinMem :: BinHandle -> IO Fingerprint
fingerprintBinMem BinHandle
bh = forall a. BinHandle -> (ByteString -> IO a) -> IO a
withBinBuffer BinHandle
bh 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 seq :: forall a b. a -> b -> b
`seq` 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 <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BinHandle -> BinHandle
set_user_data forall a b. (a -> b) -> a -> b
$ Int -> IO BinHandle
openBinMem (Int
3forall a. Num a => a -> a -> a
*Int
1024) -- just less than a block
    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 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 = ASSERT( isExternalName name ) do
    put_ bh $! nameModule name
    put_ bh $! nameOccName name