module GHC.Iface.Recomp.Binary
(
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 =
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)
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
]
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