Omit Typeable from the "naturally coherent" list
[ghc.git] / libraries / base / GHC / Fingerprint.hs
1 {-# LANGUAGE Trustworthy #-}
2 {-# LANGUAGE CPP
3 , NoImplicitPrelude
4 , BangPatterns
5 #-}
6
7 -- ----------------------------------------------------------------------------
8 --
9 -- (c) The University of Glasgow 2006
10 --
11 -- Fingerprints for recompilation checking and ABI versioning, and
12 -- implementing fast comparison of Typeable.
13 --
14 -- ----------------------------------------------------------------------------
15
16 module GHC.Fingerprint (
17 Fingerprint(..), fingerprint0,
18 fingerprintData,
19 fingerprintString,
20 fingerprintFingerprints,
21 getFileHash
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 GHC.Show
30 import Foreign
31 import Foreign.C
32 import System.IO
33
34 import GHC.Fingerprint.Type
35
36 -- for SIZEOF_STRUCT_MD5CONTEXT:
37 #include "HsBaseConfig.h"
38
39 -- XXX instance Storable Fingerprint
40 -- defined in Foreign.Storable to avoid orphan instance
41
42 fingerprint0 :: Fingerprint
43 fingerprint0 = Fingerprint 0 0
44
45 fingerprintFingerprints :: [Fingerprint] -> Fingerprint
46 fingerprintFingerprints fs = unsafeDupablePerformIO $
47 withArrayLen fs $ \len p -> do
48 fingerprintData (castPtr p) (len * sizeOf (head fs))
49
50 fingerprintData :: Ptr Word8 -> Int -> IO Fingerprint
51 fingerprintData buf len = do
52 allocaBytes SIZEOF_STRUCT_MD5CONTEXT $ \pctxt -> do
53 c_MD5Init pctxt
54 c_MD5Update pctxt buf (fromIntegral len)
55 allocaBytes 16 $ \pdigest -> do
56 c_MD5Final pdigest pctxt
57 peek (castPtr pdigest :: Ptr Fingerprint)
58
59 fingerprintString :: String -> Fingerprint
60 fingerprintString str = unsafeDupablePerformIO $
61 withArrayLen word8s $ \len p ->
62 fingerprintData p len
63 where word8s = concatMap f str
64 f c = let w32 :: Word32
65 w32 = fromIntegral (ord c)
66 in [fromIntegral (w32 `shiftR` 24),
67 fromIntegral (w32 `shiftR` 16),
68 fromIntegral (w32 `shiftR` 8),
69 fromIntegral w32]
70
71 -- | Computes the hash of a given file.
72 -- This function loops over the handle, running in constant memory.
73 --
74 -- @since 4.7.0.0
75 getFileHash :: FilePath -> IO Fingerprint
76 getFileHash path = withBinaryFile path ReadMode $ \h -> do
77 allocaBytes SIZEOF_STRUCT_MD5CONTEXT $ \pctxt -> do
78 c_MD5Init pctxt
79
80 processChunks h (\buf size -> c_MD5Update pctxt buf (fromIntegral size))
81
82 allocaBytes 16 $ \pdigest -> do
83 c_MD5Final pdigest pctxt
84 peek (castPtr pdigest :: Ptr Fingerprint)
85
86 where
87 _BUFSIZE = 4096
88
89 -- | Loop over _BUFSIZE sized chunks read from the handle,
90 -- passing the callback a block of bytes and its size.
91 processChunks :: Handle -> (Ptr Word8 -> Int -> IO ()) -> IO ()
92 processChunks h f = allocaBytes _BUFSIZE $ \arrPtr ->
93
94 let loop = do
95 count <- hGetBuf h arrPtr _BUFSIZE
96 eof <- hIsEOF h
97 when (count /= _BUFSIZE && not eof) $ errorWithoutStackTrace $
98 "GHC.Fingerprint.getFileHash: only read " ++ show count ++ " bytes"
99
100 f arrPtr count
101
102 when (not eof) loop
103
104 in loop
105
106 data MD5Context
107
108 foreign import ccall unsafe "__hsbase_MD5Init"
109 c_MD5Init :: Ptr MD5Context -> IO ()
110 foreign import ccall unsafe "__hsbase_MD5Update"
111 c_MD5Update :: Ptr MD5Context -> Ptr Word8 -> CInt -> IO ()
112 foreign import ccall unsafe "__hsbase_MD5Final"
113 c_MD5Final :: Ptr Word8 -> Ptr MD5Context -> IO ()