Update base for latest Safe Haskell.
[packages/base.git] / GHC / Fingerprint.hs
1 {-# LANGUAGE Trustworthy #-}
2 {-# LANGUAGE NoImplicitPrelude
3 , BangPatterns
4 , ForeignFunctionInterface
5 , EmptyDataDecls
6 #-}
7
8 -- ----------------------------------------------------------------------------
9 --
10 -- (c) The University of Glasgow 2006
11 --
12 -- Fingerprints for recompilation checking and ABI versioning, and
13 -- implementing fast comparison of Typeable.
14 --
15 -- ----------------------------------------------------------------------------
16
17 module GHC.Fingerprint (
18 Fingerprint(..), fingerprint0,
19 fingerprintData,
20 fingerprintString,
21 fingerprintFingerprints
22 ) where
23
24 import GHC.IO
25 import GHC.Base
26 import GHC.Num
27 import GHC.List
28 import GHC.Real
29 import Foreign
30 import Foreign.C
31
32 import GHC.Fingerprint.Type
33
34 -- for SIZEOF_STRUCT_MD5CONTEXT:
35 #include "HsBaseConfig.h"
36
37 -- XXX instance Storable Fingerprint
38 -- defined in Foreign.Storable to avoid orphan instance
39
40 fingerprint0 :: Fingerprint
41 fingerprint0 = Fingerprint 0 0
42
43 fingerprintFingerprints :: [Fingerprint] -> Fingerprint
44 fingerprintFingerprints fs = unsafeDupablePerformIO $
45 withArrayLen fs $ \len p -> do
46 fingerprintData (castPtr p) (len * sizeOf (head fs))
47
48 fingerprintData :: Ptr Word8 -> Int -> IO Fingerprint
49 fingerprintData buf len = do
50 allocaBytes SIZEOF_STRUCT_MD5CONTEXT $ \pctxt -> do
51 c_MD5Init pctxt
52 c_MD5Update pctxt buf (fromIntegral len)
53 allocaBytes 16 $ \pdigest -> do
54 c_MD5Final pdigest pctxt
55 peek (castPtr pdigest :: Ptr Fingerprint)
56
57 -- This is duplicated in compiler/utils/Fingerprint.hsc
58 fingerprintString :: String -> Fingerprint
59 fingerprintString str = unsafeDupablePerformIO $
60 withArrayLen word8s $ \len p ->
61 fingerprintData p len
62 where word8s = concatMap f str
63 f c = let w32 :: Word32
64 w32 = fromIntegral (ord c)
65 in [fromIntegral (w32 `shiftR` 24),
66 fromIntegral (w32 `shiftR` 16),
67 fromIntegral (w32 `shiftR` 8),
68 fromIntegral w32]
69
70 data MD5Context
71
72 foreign import ccall unsafe "MD5Init"
73 c_MD5Init :: Ptr MD5Context -> IO ()
74 foreign import ccall unsafe "MD5Update"
75 c_MD5Update :: Ptr MD5Context -> Ptr Word8 -> CInt -> IO ()
76 foreign import ccall unsafe "MD5Final"
77 c_MD5Final :: Ptr Word8 -> Ptr MD5Context -> IO ()
78