module GHC.ByteCode.Recomp.Binary (
  -- * Fingerprinting ByteCode objects
  computeFingerprint,
) where

import GHC.Prelude

import GHC.ByteCode.Binary (addBinNameWriter)
import GHC.Iface.Binary
import GHC.Iface.Recomp.Binary (putNameLiterally, fingerprintBinMem)
import GHC.Types.Name
import GHC.Utils.Fingerprint
import GHC.Utils.Binary

import System.IO.Unsafe

-- | Create a 'Fingerprint' using the appropriate serializers
-- for 'ModuleByteCode'.
--
computeFingerprint :: (Binary a)
                   => (WriteBinHandle -> Name -> IO ())
                   -> a
                   -> Fingerprint
computeFingerprint :: forall a.
Binary a =>
(WriteBinHandle -> Name -> IO ()) -> a -> Fingerprint
computeFingerprint WriteBinHandle -> Name -> IO ()
put_nonbinding_name a
a = IO Fingerprint -> Fingerprint
forall a. IO a -> a
unsafePerformIO (IO Fingerprint -> Fingerprint) -> IO Fingerprint -> Fingerprint
forall a b. (a -> b) -> a -> b
$ 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
    bh' <- addBinNameWriter bh
    putWithUserData QuietBinIFace NormalCompression 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 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
      ]