{-# LANGUAGE CPP #-}

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

#include "HsVersions.h"

import GhcPrelude

import Fingerprint
import Binary
import Name
import PlainPanic
import Util

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
`seq` Fingerprint -> m Fingerprint
forall (m :: * -> *) a. Monad m => a -> m a
return Fingerprint
fp

computeFingerprint :: (Binary a)
                   => (BinHandle -> Name -> IO ())
                   -> a
                   -> IO Fingerprint
computeFingerprint :: (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 (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
    Fingerprint
fp <- BinHandle -> IO Fingerprint
fingerprintBinMem BinHandle
bh
    Fingerprint -> IO Fingerprint
forall (m :: * -> *) a. Monad m => a -> m a
return Fingerprint
fp
  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 = ASSERT( isExternalName name ) do
    put_ bh $! nameModule name
    put_ bh $! nameOccName name