{-# LANGUAGE CPP, MagicHash, BangPatterns, ScopedTypeVariables #-}

{-|

Module      : GHC.Packing.Type
Copyright   : (c) Jost Berthold, 2010-2015,
License     : BSD3
Maintainer  : Jost Berthold <jost.berthold@gmail.com>
Stability   : experimental
Portability : no (depends on GHC internals)

= Serialized type for the packman library, instances and helpers

The data type @'Serialized' a@ includes a phantom type @a@ to ensure
type safety within one and the same program run. Type @a@ can be
polymorphic (at compile time, that is) when @'Serialized' a@ is not used
apart from being argument to @'deserialize'@.

The @Show@, @Read@, and @Binary@ instances of @Serialized a@ require an
additional @Typeable@ context (which requires @a@ to be monomorphic)
in order to implement dynamic type checks when parsing and deserialising
data from external sources.

-}

module GHC.Packing.Type
--    ( Serialized(..)
-- TOOD assemble export list with structure and headings/text blocks
--    , ...    ) 
        where

import GHC.Prim -- ByteArray#
import GHC.Exts ( Int(..)) -- I#

-- Read and Show instances
import Text.Printf ( printf )
import Text.ParserCombinators.ReadP (sepBy1, many1, ReadP, munch,
    munch1, pfail, readP_to_S, satisfy, skipSpaces, string )
import Data.Char ( isDigit )

-- Binary instance
import Data.Binary ( Get, Binary(..), encode, decode, encodeFile, decodeFile )

-- we use UArrays of machine word size (TargetWord)
import Data.Word( Word, Word64, Word32 )
import Data.Array.Base ( UArray(..), elems, listArray )
import Foreign.Storable ( sizeOf )

-- for dynamic type checks when parsing
import Data.Typeable (Typeable(..), typeOf)
#if MIN_VERSION_base(4,8,0)
import Data.Typeable (typeRepFingerprint)
#else
import Data.Typeable.Internal (TypeRep(..))
#endif
import qualified GHC.Fingerprint

-- for a hash of the executable. Using GHC.Fingerprint.getFileHash
import GHC.Fingerprint(getFileHash)
import System.Environment
import System.IO.Unsafe

-- for control flow and exceptions
import Control.Monad(when)
import Control.Exception(throw)

import GHC.Packing.PackException

-- | The type of Serialized data. Phantom type 'a' ensures that we
-- unpack data as the expected type.
data Serialized a = Serialized { packetData :: ByteArray# }

{- $ShowReadBinary

The power of evaluation-orthogonal serialisation is that one can
/externalise/ partially evaluated data (containing thunks), for
instance write it to disk or send it over a network.
Therefore, the module defines a 'Binary' instance for 'Serialized a',
as well as instances for 'Read' and 'Show'@ which satisfy 

> read . show == id :: 'Serialized' a -> 'Serialized' a

The phantom type is enough to ensure type-correctness when serialised
data remain in one single program run. However, when data from
previous runs are read  from an external source, their type needs to
be checked at runtime. Type information must be stored together with
the (binary) serialisation data.

The serialised data contain pointers to static data in the generating
program (top-level functions and constants) and very likely to
additional library code. Therefore, the /exact same binary/ must be
used when reading in serialised data from an external source. A hash
of the executable is included in the representation to ensure this.

-}

-- | prints packet as Word array in 4 columns (/Word/ meaning the
-- machine word size), and additionally includes Fingerprint hash
-- values for executable binary and type.
instance Typeable a => Show (Serialized a) where
    show p = unlines [ "Serialization Packet, size " ++ show size,
                       ", program " ++ show prgHash,
                       ", type fingerprint" ++ show t,
                       showWArray (UArray 0 (size-1) size dat) ]
        where size = case sizeofByteArray# dat of
                          sz# -> (I# sz# ) `div` sizeOf(undefined::TargetWord)
              t    = typeFP ( undefined :: a )
              dat  = packetData p

-- | Helper to show a serialized structure as a packet (Word Array)
showWArray :: UArray Int TargetWord -> String
showWArray arr = unlines [ show i ++ ":" ++ unwords (map showH row)
                         | (i,row) <- zip  [0,4..] elRows ]
    where showH w = -- "\t0x" ++ showHex w " "
                    printf ('\t':hexWordFmt) w
          elRows = takeEach4 (elems arr)
          
          takeEach4 :: [a] -> [[a]]
          takeEach4 [] = []
          takeEach4 xs = first:takeEach4 rest
            where (first,rest) = splitAt 4 xs

-----------------------------------------------
-- | Reads the format generated by the 'Show' instance, checks
--   hash values for executable and type and parses exactly as much as
--   the included data size announces.
instance Typeable a => Read (Serialized a)
    -- using ReadP parser (base-4.x)
    where readsPrec _ input
           = case parseP input of
              []  -> throw P_ParseError -- no parse
              [((sz,tp,dat),r)]
                  -> let !(UArray _ _ _ arr# ) = listArray (0,sz-1) dat
                         t = typeFP (undefined::a)
                     in if t == tp
                              then [(Serialized arr# , r)]
                              else throw P_TypeMismatch
              other-> throw P_ParseError
                       -- ambiguous parse for packet

-- | Packet Parser, reads the format generated by the @Read@ instance.
-- Could also consume other formats of the array (not implemented).
-- Returns: (data size in words, type fingerprint, array values)
parseP :: ReadS (Int, FP, [TargetWord]) 
parseP = readP_to_S $
-- read header with size and type, then iterate over array values,
-- reading several hex words in one row, separated by
-- tab and space. Packet size needed to avoid returning a prefix.
         do string "Serialization Packet, size "
            sz_str <- munch1 isDigit
            let sz = read sz_str::Int
            string ", program "
            h  <- munch1 (not . (== '\n'))
            when (read h /= prgHash) (throw P_BinaryMismatch)
              -- executables do not match. No ambiguous parses here,
              -- so just throw; otherwise we would only pfail.
            newline
            string ", type "
            tp <- munch1 (not . (== '\n'))
            newline
            let startRow = do { many1 digit; colon; tabSpace }
                row = do { startRow; sepBy1 hexNum tabSpace }
            valss <- sepBy1 row newline
            skipSpaces -- eat remaining spaces
            let vals = concat valss
                l    = length vals
            -- filter out wrong lengths:
            if (sz /= length vals) then pfail
                                   else return (sz, read tp, vals)

digit = satisfy isDigit
colon = satisfy (==':')
tabSpace = munch1 ( \x -> x `elem` " \t" )
newline = munch1 (\x -> x `elem` " \n")

hexNum :: ReadP TargetWord
hexNum = do string "0x"
            ds <- munch hexDigit
            return (read ("0x" ++ ds))
  where hexDigit = (\x -> x `elem` "0123456789abcdefABCDEF")

------------------------------------------------------------------

-- | The binary format of @'Serialized' a@ data includes FingerPrint
--   hash values for type and executable binary, which are checked
--   when reading Serialized data back in using @get@.
instance Typeable a => Binary (Serialized a) where
    -- We make our life simple and construct/deconstruct Word
    -- (U)Arrays, quite as we did in the Show/Read instances.
    put (Serialized bArr#)
        = do put prgHash
             put (typeFP (undefined :: a))
             let arr    = UArray 0 (sz-1) sz bArr# :: UArray Int TargetWord
                 sz     = case sizeofByteArray# bArr# of
                            sz# -> (I# sz# ) `div` sizeOf(undefined::TargetWord)
             put arr
    get = do hash   <- get :: Get FP
             when (hash /= prgHash) 
               (throw P_BinaryMismatch) 
             -- executables do not match
             tp <- get :: Get FP
             when (tp /= typeFP (undefined :: a))
               (throw P_TypeMismatch)
                -- Type error during packet parse
             uarr   <- get :: Get (UArray Int TargetWord)
             let !(UArray _ _ sz bArr#) = uarr
             return ( Serialized bArr# )

------------------------------------------------------------------
-- $ComparingTypes
-----------------------------------------------
-- Helper functions to compare types at runtime:
--   We use type "fingerprints" defined in 'GHC.Fingerprint.Type'

-- This should ensure (as of GHC.7.8) that types with the same name
-- but different definition get different hashes.  (however, we also
-- require the executable to be exactly the same, so this is not
-- strictly necessary anyway).

-- Typeable context for dynamic type checks. 

-- | The module uses a custom GHC fingerprint type with its two Word64
--   fields, to be able to /read/ fingerprints
data FP = FP Word64 Word64 deriving (Read, Show, Eq)

-- | checks whether the type of the given expression matches the given Fingerprint
matches :: Typeable a => a -> FP -> Bool
matches x (FP c1 c2) = f1 == c1 && f2 == c2
  where  (GHC.Fingerprint.Fingerprint f1 f2) = typeRepFingerprint (typeOf x)

#if ! MIN_VERSION_base(4,8,0)
-- typeRepFingerprint is provided since base-4.8.0.0
typeRepFingerprint typeRep = ghcFP
    where TypeRep ghcFP _ _ = typeRep
#endif

-- | creates an 'FP' from a GHC 'Fingerprint'
toFP :: GHC.Fingerprint.Fingerprint -> FP
toFP (GHC.Fingerprint.Fingerprint f1 f2) = FP f1 f2

-- | returns the type fingerprint of an expression
typeFP :: Typeable a => a -> FP
typeFP = toFP . typeRepFingerprint . typeOf

-- | Binary instance for fingerprint data (encoding TypeRep and
--   executable in binary-encoded @Serialized a@)
instance Binary FP where
  put (FP f1 f2) = do put f1
                      put f2
  get            = do f1 <- get :: Get Word64
                      f2 <- get :: Get Word64
                      return (FP f1 f2)

-----------------------------------------------

-- | To check that the program (executable) is identical when packing
-- and unpacking, the fingerprint type from above is used (Read/Show
-- instances required). An 'FP' fingerprint of the executable is
-- computed once, by unsafePerformIO inside this CAF (safe to inline,
-- just inefficient).

{-# NOINLINE prgHash #-}
prgHash :: FP
prgHash = unsafePerformIO $ 
          getExecutablePath >>= getFileHash >>= return . toFP

-----------------------------------------------

-- | The target word size is the size of a machine word on the
-- platform we run on.
--
-- This type is only used in Binary, Read and Show instances, where
-- packets are stored as 'UArrays' of 'TargetWord'.
--
-- Actually, GHC uses machine word size (as Haskell 2010 spec. does
-- not fix it) so we could just use Word. See
-- <http://www.haskell.org/ghc/docs/7.8.3/html/users_guide/bugs-and-infelicities.html#haskell-98-2010-undefined>

-- We'd rather just import 'GHC.Constants.TargetWord' but it was
-- removed. This code here is a cheap and incomplete hack, as the
-- package would otherwise need a configure script.

#if x86_64_BUILD_ARCH
type TargetWord = Word64
hexWordFmt = "0x%016x"
#elif i386_BUILD_ARCH
type TargetWord = Word32
hexWordFmt = "0x%08x"
#elif powerpc_BUILD_ARCH
#error Don't know word size of your Power-PC model
#else
#warning Don't know the word size on your machine.
type TargetWord = Word
#endif