{-# LANGUAGE CPP               #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE Trustworthy       #-}

-- ----------------------------------------------------------------------------
--
--  (c) The University of Glasgow 2006
--
-- Fingerprints for recompilation checking and ABI versioning, and
-- implementing fast comparison of Typeable.
--
-- ----------------------------------------------------------------------------

module GHC.Internal.Fingerprint (
        Fingerprint(..), fingerprint0,
        fingerprintData,
        fingerprintString,
        fingerprintFingerprints,
        fingerprintBufferedStream
   ) where

import GHC.Internal.Err (undefined)
import GHC.Internal.IO
import GHC.Internal.Base (String, ord, when, ($))
import GHC.Internal.Bits
import GHC.Internal.Num
import GHC.Internal.Data.Maybe
import GHC.Internal.List
import GHC.Internal.Real
import GHC.Internal.Types (Int)
import GHC.Internal.Word
import GHC.Internal.Ptr
import GHC.Internal.Foreign.C.Types
import GHC.Internal.Foreign.Marshal.Alloc
import GHC.Internal.Foreign.Marshal.Array
import GHC.Internal.Foreign.Storable

import GHC.Internal.Fingerprint.Type

-- for SIZEOF_STRUCT_MD5CONTEXT:
#include "HsBaseConfig.h"

-- XXX instance Storable Fingerprint
-- defined in GHC.Internal.Foreign.Storable to avoid orphan instance

fingerprint0 :: Fingerprint
fingerprint0 :: Fingerprint
fingerprint0 = Word64 -> Word64 -> Fingerprint
Fingerprint Word64
0 Word64
0

fingerprintFingerprints :: [Fingerprint] -> Fingerprint
fingerprintFingerprints :: [Fingerprint] -> Fingerprint
fingerprintFingerprints [Fingerprint]
fs = IO Fingerprint -> Fingerprint
forall a. IO a -> a
unsafeDupablePerformIO (IO Fingerprint -> Fingerprint) -> IO Fingerprint -> Fingerprint
forall a b. (a -> b) -> a -> b
$
  [Fingerprint]
-> (Int -> Ptr Fingerprint -> IO Fingerprint) -> IO Fingerprint
forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen [Fingerprint]
fs ((Int -> Ptr Fingerprint -> IO Fingerprint) -> IO Fingerprint)
-> (Int -> Ptr Fingerprint -> IO Fingerprint) -> IO Fingerprint
forall a b. (a -> b) -> a -> b
$ \Int
len Ptr Fingerprint
p ->
    Ptr Word8 -> Int -> IO Fingerprint
fingerprintData (Ptr Fingerprint -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr Fingerprint
p) (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
* Fingerprint -> Int
forall a. Storable a => a -> Int
sizeOf (Fingerprint
forall a. HasCallStack => a
undefined :: Fingerprint))

fingerprintData :: Ptr Word8 -> Int -> IO Fingerprint
fingerprintData :: Ptr Word8 -> Int -> IO Fingerprint
fingerprintData Ptr Word8
buf Int
len =
  Int -> (Ptr MD5Context -> IO Fingerprint) -> IO Fingerprint
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes SIZEOF_STRUCT_MD5CONTEXT $ \pctxt -> do
    c_MD5Init pctxt
    c_MD5Update pctxt buf (fromIntegral len)
    allocaBytes 16 $ \pdigest -> do
      c_MD5Final pdigest pctxt
      peek (castPtr pdigest :: Ptr Fingerprint)

fingerprintString :: String -> Fingerprint
fingerprintString :: String -> Fingerprint
fingerprintString String
str = IO Fingerprint -> Fingerprint
forall a. IO a -> a
unsafeDupablePerformIO (IO Fingerprint -> Fingerprint) -> IO Fingerprint -> Fingerprint
forall a b. (a -> b) -> a -> b
$
  [Word8] -> (Int -> Ptr Word8 -> IO Fingerprint) -> IO Fingerprint
forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen [Word8]
word8s ((Int -> Ptr Word8 -> IO Fingerprint) -> IO Fingerprint)
-> (Int -> Ptr Word8 -> IO Fingerprint) -> IO Fingerprint
forall a b. (a -> b) -> a -> b
$ \Int
len Ptr Word8
p ->
     Ptr Word8 -> Int -> IO Fingerprint
fingerprintData Ptr Word8
p Int
len
    where word8s :: [Word8]
word8s = (Char -> [Word8]) -> String -> [Word8]
forall a b. (a -> [b]) -> [a] -> [b]
concatMap Char -> [Word8]
forall {a}. Num a => Char -> [a]
f String
str
          f :: Char -> [a]
f Char
c = let w32 :: Word32
                    w32 :: Word32
w32 = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c)
                in [Word32 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
w32 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
24),
                    Word32 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
w32 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
16),
                    Word32 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
w32 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
8),
                    Word32 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w32]

-- | Reads data in chunks and computes its hash.
-- This function runs in constant memory.
fingerprintBufferedStream :: (Ptr Word8 -> Int -> IO (Maybe Int))
                          -> IO Fingerprint
fingerprintBufferedStream :: (Ptr Word8 -> Int -> IO (Maybe Int)) -> IO Fingerprint
fingerprintBufferedStream Ptr Word8 -> Int -> IO (Maybe Int)
readChunk =
  Int -> (Ptr MD5Context -> IO Fingerprint) -> IO Fingerprint
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes SIZEOF_STRUCT_MD5CONTEXT $ \pctxt -> do
    c_MD5Init pctxt
    allocaBytes _BUFSIZE $ \arrPtr ->
      let loop = do
            maybeRemainderSize <- readChunk arrPtr _BUFSIZE
            c_MD5Update pctxt
                        arrPtr
                        (fromIntegral (fromMaybe _BUFSIZE maybeRemainderSize))
            when (isNothing maybeRemainderSize) loop
      in loop
    allocaBytes 16 $ \pdigest -> do
      c_MD5Final pdigest pctxt
      peek (castPtr pdigest :: Ptr Fingerprint)
  where
    _BUFSIZE :: Int
_BUFSIZE = Int
4096

data MD5Context

foreign import ccall unsafe "__hsbase_MD5Init"
   c_MD5Init   :: Ptr MD5Context -> IO ()
foreign import ccall unsafe "__hsbase_MD5Update"
   c_MD5Update :: Ptr MD5Context -> Ptr Word8 -> CInt -> IO ()
foreign import ccall unsafe "__hsbase_MD5Final"
   c_MD5Final  :: Ptr Word8 -> Ptr MD5Context -> IO ()