{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiWayIf #-}

{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
-- We always optimise this, otherwise performance of a non-optimised
-- compiler is severely affected

--
-- (c) The University of Glasgow 2002-2006
--
-- Binary I/O library, with special tweaks for GHC
--
-- Based on the nhc98 Binary library, which is copyright
-- (c) Malcolm Wallace and Colin Runciman, University of York, 1998.
-- Under the terms of the license for that software, we must tell you
-- where you can obtain the original version of the Binary library, namely
--     http://www.cs.york.ac.uk/fp/nhc98/

module Binary
  ( {-type-}  Bin,
    {-class-} Binary(..),
    {-type-}  BinHandle,
    SymbolTable, Dictionary,

   openBinMem,
--   closeBin,

   seekBin,
   seekBy,
   tellBin,
   castBin,
   isEOFBin,
   withBinBuffer,

   writeBinMem,
   readBinMem,

   putAt, getAt,

   -- * For writing instances
   putByte,
   getByte,

   -- * Lazy Binary I/O
   lazyGet,
   lazyPut,

   -- * User data
   UserData(..), getUserData, setUserData,
   newReadState, newWriteState,
   putDictionary, getDictionary, putFS,
  ) where

#include "HsVersions.h"

-- The *host* architecture version:
#include "MachDeps.h"

import GhcPrelude

import {-# SOURCE #-} Name (Name)
import FastString
import PlainPanic
import UniqFM
import FastMutInt
import Fingerprint
import BasicTypes
import SrcLoc

import Foreign
import Data.Array
import Data.ByteString (ByteString)
import qualified Data.ByteString.Internal as BS
import qualified Data.ByteString.Unsafe   as BS
import Data.IORef
import Data.Char                ( ord, chr )
import Data.Time
import Type.Reflection
import Type.Reflection.Unsafe
import Data.Kind (Type)
import GHC.Exts (TYPE, RuntimeRep(..), VecCount(..), VecElem(..))
import Control.Monad            ( when )
import System.IO as IO
import System.IO.Unsafe         ( unsafeInterleaveIO )
import System.IO.Error          ( mkIOError, eofErrorType )
import GHC.Real                 ( Ratio(..) )
import GHC.Serialized

type BinArray = ForeignPtr Word8

---------------------------------------------------------------
-- BinHandle
---------------------------------------------------------------

data BinHandle
  = BinMem {                     -- binary data stored in an unboxed array
     BinHandle -> UserData
bh_usr :: UserData,         -- sigh, need parameterized modules :-)
     BinHandle -> FastMutInt
_off_r :: !FastMutInt,      -- the current offset
     BinHandle -> FastMutInt
_sz_r  :: !FastMutInt,      -- size of the array (cached)
     BinHandle -> IORef BinArray
_arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1))
    }
        -- XXX: should really store a "high water mark" for dumping out
        -- the binary data to a file.

getUserData :: BinHandle -> UserData
getUserData :: BinHandle -> UserData
getUserData bh :: BinHandle
bh = BinHandle -> UserData
bh_usr BinHandle
bh

setUserData :: BinHandle -> UserData -> BinHandle
setUserData :: BinHandle -> UserData -> BinHandle
setUserData bh :: BinHandle
bh us :: UserData
us = BinHandle
bh { bh_usr :: UserData
bh_usr = UserData
us }

-- | Get access to the underlying buffer.
--
-- It is quite important that no references to the 'ByteString' leak out of the
-- continuation lest terrible things happen.
withBinBuffer :: BinHandle -> (ByteString -> IO a) -> IO a
withBinBuffer :: BinHandle -> (ByteString -> IO a) -> IO a
withBinBuffer (BinMem _ ix_r :: FastMutInt
ix_r _ arr_r :: IORef BinArray
arr_r) action :: ByteString -> IO a
action = do
  BinArray
arr <- IORef BinArray -> IO BinArray
forall a. IORef a -> IO a
readIORef IORef BinArray
arr_r
  Int
ix <- FastMutInt -> IO Int
readFastMutInt FastMutInt
ix_r
  BinArray -> (Ptr Word8 -> IO a) -> IO a
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr BinArray
arr ((Ptr Word8 -> IO a) -> IO a) -> (Ptr Word8 -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \ptr :: Ptr Word8
ptr ->
    CStringLen -> IO ByteString
BS.unsafePackCStringLen (Ptr Word8 -> Ptr CChar
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
ptr, Int
ix) IO ByteString -> (ByteString -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> IO a
action


---------------------------------------------------------------
-- Bin
---------------------------------------------------------------

newtype Bin a = BinPtr Int
  deriving (Bin a -> Bin a -> Bool
(Bin a -> Bin a -> Bool) -> (Bin a -> Bin a -> Bool) -> Eq (Bin a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (a :: k). Bin a -> Bin a -> Bool
/= :: Bin a -> Bin a -> Bool
$c/= :: forall k (a :: k). Bin a -> Bin a -> Bool
== :: Bin a -> Bin a -> Bool
$c== :: forall k (a :: k). Bin a -> Bin a -> Bool
Eq, Eq (Bin a)
Eq (Bin a) =>
(Bin a -> Bin a -> Ordering)
-> (Bin a -> Bin a -> Bool)
-> (Bin a -> Bin a -> Bool)
-> (Bin a -> Bin a -> Bool)
-> (Bin a -> Bin a -> Bool)
-> (Bin a -> Bin a -> Bin a)
-> (Bin a -> Bin a -> Bin a)
-> Ord (Bin a)
Bin a -> Bin a -> Bool
Bin a -> Bin a -> Ordering
Bin a -> Bin a -> Bin a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall k (a :: k). Eq (Bin a)
forall k (a :: k). Bin a -> Bin a -> Bool
forall k (a :: k). Bin a -> Bin a -> Ordering
forall k (a :: k). Bin a -> Bin a -> Bin a
min :: Bin a -> Bin a -> Bin a
$cmin :: forall k (a :: k). Bin a -> Bin a -> Bin a
max :: Bin a -> Bin a -> Bin a
$cmax :: forall k (a :: k). Bin a -> Bin a -> Bin a
>= :: Bin a -> Bin a -> Bool
$c>= :: forall k (a :: k). Bin a -> Bin a -> Bool
> :: Bin a -> Bin a -> Bool
$c> :: forall k (a :: k). Bin a -> Bin a -> Bool
<= :: Bin a -> Bin a -> Bool
$c<= :: forall k (a :: k). Bin a -> Bin a -> Bool
< :: Bin a -> Bin a -> Bool
$c< :: forall k (a :: k). Bin a -> Bin a -> Bool
compare :: Bin a -> Bin a -> Ordering
$ccompare :: forall k (a :: k). Bin a -> Bin a -> Ordering
$cp1Ord :: forall k (a :: k). Eq (Bin a)
Ord, Int -> Bin a -> ShowS
[Bin a] -> ShowS
Bin a -> String
(Int -> Bin a -> ShowS)
-> (Bin a -> String) -> ([Bin a] -> ShowS) -> Show (Bin a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (a :: k). Int -> Bin a -> ShowS
forall k (a :: k). [Bin a] -> ShowS
forall k (a :: k). Bin a -> String
showList :: [Bin a] -> ShowS
$cshowList :: forall k (a :: k). [Bin a] -> ShowS
show :: Bin a -> String
$cshow :: forall k (a :: k). Bin a -> String
showsPrec :: Int -> Bin a -> ShowS
$cshowsPrec :: forall k (a :: k). Int -> Bin a -> ShowS
Show, Bin a
Bin a -> Bin a -> Bounded (Bin a)
forall a. a -> a -> Bounded a
forall k (a :: k). Bin a
maxBound :: Bin a
$cmaxBound :: forall k (a :: k). Bin a
minBound :: Bin a
$cminBound :: forall k (a :: k). Bin a
Bounded)

castBin :: Bin a -> Bin b
castBin :: Bin a -> Bin b
castBin (BinPtr i :: Int
i) = Int -> Bin b
forall k (a :: k). Int -> Bin a
BinPtr Int
i

---------------------------------------------------------------
-- class Binary
---------------------------------------------------------------

class Binary a where
    put_   :: BinHandle -> a -> IO ()
    put    :: BinHandle -> a -> IO (Bin a)
    get    :: BinHandle -> IO a

    -- define one of put_, put.  Use of put_ is recommended because it
    -- is more likely that tail-calls can kick in, and we rarely need the
    -- position return value.
    put_ bh :: BinHandle
bh a :: a
a = do Bin a
_ <- BinHandle -> a -> IO (Bin a)
forall a. Binary a => BinHandle -> a -> IO (Bin a)
put BinHandle
bh a
a; () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    put bh :: BinHandle
bh a :: a
a  = do Bin a
p <- BinHandle -> IO (Bin a)
forall k (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh; BinHandle -> a -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh a
a; Bin a -> IO (Bin a)
forall (m :: * -> *) a. Monad m => a -> m a
return Bin a
p

putAt  :: Binary a => BinHandle -> Bin a -> a -> IO ()
putAt :: BinHandle -> Bin a -> a -> IO ()
putAt bh :: BinHandle
bh p :: Bin a
p x :: a
x = do BinHandle -> Bin a -> IO ()
forall k (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin a
p; BinHandle -> a -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh a
x; () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

getAt  :: Binary a => BinHandle -> Bin a -> IO a
getAt :: BinHandle -> Bin a -> IO a
getAt bh :: BinHandle
bh p :: Bin a
p = do BinHandle -> Bin a -> IO ()
forall k (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin a
p; BinHandle -> IO a
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh

openBinMem :: Int -> IO BinHandle
openBinMem :: Int -> IO BinHandle
openBinMem size :: Int
size
 | Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0 = String -> IO BinHandle
forall a. HasCallStack => String -> a
error "Data.Binary.openBinMem: size must be >= 0"
 | Bool
otherwise = do
   BinArray
arr <- Int -> IO BinArray
forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
size
   IORef BinArray
arr_r <- BinArray -> IO (IORef BinArray)
forall a. a -> IO (IORef a)
newIORef BinArray
arr
   FastMutInt
ix_r <- IO FastMutInt
newFastMutInt
   FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
ix_r 0
   FastMutInt
sz_r <- IO FastMutInt
newFastMutInt
   FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
sz_r Int
size
   BinHandle -> IO BinHandle
forall (m :: * -> *) a. Monad m => a -> m a
return (UserData -> FastMutInt -> FastMutInt -> IORef BinArray -> BinHandle
BinMem UserData
forall a. a
noUserData FastMutInt
ix_r FastMutInt
sz_r IORef BinArray
arr_r)

tellBin :: BinHandle -> IO (Bin a)
tellBin :: BinHandle -> IO (Bin a)
tellBin (BinMem _ r :: FastMutInt
r _ _) = do Int
ix <- FastMutInt -> IO Int
readFastMutInt FastMutInt
r; Bin a -> IO (Bin a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Bin a
forall k (a :: k). Int -> Bin a
BinPtr Int
ix)

seekBin :: BinHandle -> Bin a -> IO ()
seekBin :: BinHandle -> Bin a -> IO ()
seekBin h :: BinHandle
h@(BinMem _ ix_r :: FastMutInt
ix_r sz_r :: FastMutInt
sz_r _) (BinPtr p :: Int
p) = do
  Int
sz <- FastMutInt -> IO Int
readFastMutInt FastMutInt
sz_r
  if (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
sz)
        then do BinHandle -> Int -> IO ()
expandBin BinHandle
h Int
p; FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
ix_r Int
p
        else FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
ix_r Int
p

seekBy :: BinHandle -> Int -> IO ()
seekBy :: BinHandle -> Int -> IO ()
seekBy h :: BinHandle
h@(BinMem _ ix_r :: FastMutInt
ix_r sz_r :: FastMutInt
sz_r _) off :: Int
off = do
  Int
sz <- FastMutInt -> IO Int
readFastMutInt FastMutInt
sz_r
  Int
ix <- FastMutInt -> IO Int
readFastMutInt FastMutInt
ix_r
  let ix' :: Int
ix' = Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
off
  if (Int
ix' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
sz)
        then do BinHandle -> Int -> IO ()
expandBin BinHandle
h Int
ix'; FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
ix_r Int
ix'
        else FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
ix_r Int
ix'

isEOFBin :: BinHandle -> IO Bool
isEOFBin :: BinHandle -> IO Bool
isEOFBin (BinMem _ ix_r :: FastMutInt
ix_r sz_r :: FastMutInt
sz_r _) = do
  Int
ix <- FastMutInt -> IO Int
readFastMutInt FastMutInt
ix_r
  Int
sz <- FastMutInt -> IO Int
readFastMutInt FastMutInt
sz_r
  Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
ix Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
sz)

writeBinMem :: BinHandle -> FilePath -> IO ()
writeBinMem :: BinHandle -> String -> IO ()
writeBinMem (BinMem _ ix_r :: FastMutInt
ix_r _ arr_r :: IORef BinArray
arr_r) fn :: String
fn = do
  Handle
h <- String -> IOMode -> IO Handle
openBinaryFile String
fn IOMode
WriteMode
  BinArray
arr <- IORef BinArray -> IO BinArray
forall a. IORef a -> IO a
readIORef IORef BinArray
arr_r
  Int
ix  <- FastMutInt -> IO Int
readFastMutInt FastMutInt
ix_r
  BinArray -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr BinArray
arr ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \p :: Ptr Word8
p -> Handle -> Ptr Word8 -> Int -> IO ()
forall a. Handle -> Ptr a -> Int -> IO ()
hPutBuf Handle
h Ptr Word8
p Int
ix
  Handle -> IO ()
hClose Handle
h

readBinMem :: FilePath -> IO BinHandle
-- Return a BinHandle with a totally undefined State
readBinMem :: String -> IO BinHandle
readBinMem filename :: String
filename = do
  Handle
h <- String -> IOMode -> IO Handle
openBinaryFile String
filename IOMode
ReadMode
  Integer
filesize' <- Handle -> IO Integer
hFileSize Handle
h
  let filesize :: Int
filesize = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
filesize'
  BinArray
arr <- Int -> IO BinArray
forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
filesize
  Int
count <- BinArray -> (Ptr Word8 -> IO Int) -> IO Int
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr BinArray
arr ((Ptr Word8 -> IO Int) -> IO Int)
-> (Ptr Word8 -> IO Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ \p :: Ptr Word8
p -> Handle -> Ptr Word8 -> Int -> IO Int
forall a. Handle -> Ptr a -> Int -> IO Int
hGetBuf Handle
h Ptr Word8
p Int
filesize
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
count Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
filesize) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
       String -> IO ()
forall a. HasCallStack => String -> a
error ("Binary.readBinMem: only read " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
count String -> ShowS
forall a. [a] -> [a] -> [a]
++ " bytes")
  Handle -> IO ()
hClose Handle
h
  IORef BinArray
arr_r <- BinArray -> IO (IORef BinArray)
forall a. a -> IO (IORef a)
newIORef BinArray
arr
  FastMutInt
ix_r <- IO FastMutInt
newFastMutInt
  FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
ix_r 0
  FastMutInt
sz_r <- IO FastMutInt
newFastMutInt
  FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
sz_r Int
filesize
  BinHandle -> IO BinHandle
forall (m :: * -> *) a. Monad m => a -> m a
return (UserData -> FastMutInt -> FastMutInt -> IORef BinArray -> BinHandle
BinMem UserData
forall a. a
noUserData FastMutInt
ix_r FastMutInt
sz_r IORef BinArray
arr_r)

-- expand the size of the array to include a specified offset
expandBin :: BinHandle -> Int -> IO ()
expandBin :: BinHandle -> Int -> IO ()
expandBin (BinMem _ _ sz_r :: FastMutInt
sz_r arr_r :: IORef BinArray
arr_r) off :: Int
off = do
   Int
sz <- FastMutInt -> IO Int
readFastMutInt FastMutInt
sz_r
   let sz' :: Int
sz' = [Int] -> Int
forall a. [a] -> a
head ((Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
off) ((Int -> Int) -> Int -> [Int]
forall a. (a -> a) -> a -> [a]
iterate (Int -> Int -> Int
forall a. Num a => a -> a -> a
* 2) Int
sz))
   BinArray
arr <- IORef BinArray -> IO BinArray
forall a. IORef a -> IO a
readIORef IORef BinArray
arr_r
   BinArray
arr' <- Int -> IO BinArray
forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
sz'
   BinArray -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr BinArray
arr ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \old :: Ptr Word8
old ->
     BinArray -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr BinArray
arr' ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \new :: Ptr Word8
new ->
       Ptr Word8 -> Ptr Word8 -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes Ptr Word8
new Ptr Word8
old Int
sz
   FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
sz_r Int
sz'
   IORef BinArray -> BinArray -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef BinArray
arr_r BinArray
arr'

-- -----------------------------------------------------------------------------
-- Low-level reading/writing of bytes

putPrim :: BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()
putPrim :: BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()
putPrim h :: BinHandle
h@(BinMem _ ix_r :: FastMutInt
ix_r sz_r :: FastMutInt
sz_r arr_r :: IORef BinArray
arr_r) size :: Int
size f :: Ptr Word8 -> IO ()
f = do
  Int
ix <- FastMutInt -> IO Int
readFastMutInt FastMutInt
ix_r
  Int
sz <- FastMutInt -> IO Int
readFastMutInt FastMutInt
sz_r
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
sz) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    BinHandle -> Int -> IO ()
expandBin BinHandle
h (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size)
  BinArray
arr <- IORef BinArray -> IO BinArray
forall a. IORef a -> IO a
readIORef IORef BinArray
arr_r
  BinArray -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr BinArray
arr ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \op :: Ptr Word8
op -> Ptr Word8 -> IO ()
f (Ptr Word8
op Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
ix)
  FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
ix_r (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size)

getPrim :: BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a
getPrim :: BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a
getPrim (BinMem _ ix_r :: FastMutInt
ix_r sz_r :: FastMutInt
sz_r arr_r :: IORef BinArray
arr_r) size :: Int
size f :: Ptr Word8 -> IO a
f = do
  Int
ix <- FastMutInt -> IO Int
readFastMutInt FastMutInt
ix_r
  Int
sz <- FastMutInt -> IO Int
readFastMutInt FastMutInt
sz_r
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
sz) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      IOError -> IO ()
forall a. IOError -> IO a
ioError (IOErrorType -> String -> Maybe Handle -> Maybe String -> IOError
mkIOError IOErrorType
eofErrorType "Data.Binary.getPrim" Maybe Handle
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing)
  BinArray
arr <- IORef BinArray -> IO BinArray
forall a. IORef a -> IO a
readIORef IORef BinArray
arr_r
  a
w <- BinArray -> (Ptr Word8 -> IO a) -> IO a
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr BinArray
arr ((Ptr Word8 -> IO a) -> IO a) -> (Ptr Word8 -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \op :: Ptr Word8
op -> Ptr Word8 -> IO a
f (Ptr Word8
op Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
ix)
  FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
ix_r (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size)
  a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
w

putWord8 :: BinHandle -> Word8 -> IO ()
putWord8 :: BinHandle -> Word8 -> IO ()
putWord8 h :: BinHandle
h w :: Word8
w = BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()
putPrim BinHandle
h 1 (\op :: Ptr Word8
op -> Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word8
op Word8
w)

getWord8 :: BinHandle -> IO Word8
getWord8 :: BinHandle -> IO Word8
getWord8 h :: BinHandle
h = BinHandle -> Int -> (Ptr Word8 -> IO Word8) -> IO Word8
forall a. BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a
getPrim BinHandle
h 1 Ptr Word8 -> IO Word8
forall a. Storable a => Ptr a -> IO a
peek

putWord16 :: BinHandle -> Word16 -> IO ()
putWord16 :: BinHandle -> Word16 -> IO ()
putWord16 h :: BinHandle
h w :: Word16
w = BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()
putPrim BinHandle
h 2 (\op :: Ptr Word8
op -> do
  Ptr Word8 -> Int -> Word8 -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
op 0 (Word16 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
w Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
`shiftR` 8))
  Ptr Word8 -> Int -> Word8 -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
op 1 (Word16 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
w Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. 0xFF))
  )

getWord16 :: BinHandle -> IO Word16
getWord16 :: BinHandle -> IO Word16
getWord16 h :: BinHandle
h = BinHandle -> Int -> (Ptr Word8 -> IO Word16) -> IO Word16
forall a. BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a
getPrim BinHandle
h 2 (\op :: Ptr Word8
op -> do
  Word16
w0 <- Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word16) -> IO Word8 -> IO Word16
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Word8 -> Int -> IO Word8
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word8
op 0
  Word16
w1 <- Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word16) -> IO Word8 -> IO Word16
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Word8 -> Int -> IO Word8
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word8
op 1
  Word16 -> IO Word16
forall (m :: * -> *) a. Monad m => a -> m a
return (Word16 -> IO Word16) -> Word16 -> IO Word16
forall a b. (a -> b) -> a -> b
$! Word16
w0 Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
`shiftL` 8 Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|. Word16
w1
  )

putWord32 :: BinHandle -> Word32 -> IO ()
putWord32 :: BinHandle -> Word32 -> IO ()
putWord32 h :: BinHandle
h w :: Word32
w = BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()
putPrim BinHandle
h 4 (\op :: Ptr Word8
op -> do
  Ptr Word8 -> Int -> Word8 -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
op 0 (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` 24))
  Ptr Word8 -> Int -> Word8 -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
op 1 (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` 16) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. 0xFF))
  Ptr Word8 -> Int -> Word8 -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
op 2 (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` 8) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. 0xFF))
  Ptr Word8 -> Int -> Word8 -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
op 3 (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
w Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. 0xFF))
  )

getWord32 :: BinHandle -> IO Word32
getWord32 :: BinHandle -> IO Word32
getWord32 h :: BinHandle
h = BinHandle -> Int -> (Ptr Word8 -> IO Word32) -> IO Word32
forall a. BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a
getPrim BinHandle
h 4 (\op :: Ptr Word8
op -> do
  Word32
w0 <- Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word32) -> IO Word8 -> IO Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Word8 -> Int -> IO Word8
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word8
op 0
  Word32
w1 <- Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word32) -> IO Word8 -> IO Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Word8 -> Int -> IO Word8
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word8
op 1
  Word32
w2 <- Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word32) -> IO Word8 -> IO Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Word8 -> Int -> IO Word8
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word8
op 2
  Word32
w3 <- Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word32) -> IO Word8 -> IO Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Word8 -> Int -> IO Word8
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word8
op 3

  Word32 -> IO Word32
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32 -> IO Word32) -> Word32 -> IO Word32
forall a b. (a -> b) -> a -> b
$! (Word32
w0 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` 24) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|.
            (Word32
w1 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` 16) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|.
            (Word32
w2 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` 8)  Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|.
            Word32
w3
  )

putWord64 :: BinHandle -> Word64 -> IO ()
putWord64 :: BinHandle -> Word64 -> IO ()
putWord64 h :: BinHandle
h w :: Word64
w = BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()
putPrim BinHandle
h 8 (\op :: Ptr Word8
op -> do
  Ptr Word8 -> Int -> Word8 -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
op 0 (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
w Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` 56))
  Ptr Word8 -> Int -> Word8 -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
op 1 (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word64
w Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` 48) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. 0xFF))
  Ptr Word8 -> Int -> Word8 -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
op 2 (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word64
w Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` 40) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. 0xFF))
  Ptr Word8 -> Int -> Word8 -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
op 3 (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word64
w Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` 32) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. 0xFF))
  Ptr Word8 -> Int -> Word8 -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
op 4 (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word64
w Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` 24) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. 0xFF))
  Ptr Word8 -> Int -> Word8 -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
op 5 (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word64
w Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` 16) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. 0xFF))
  Ptr Word8 -> Int -> Word8 -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
op 6 (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word64
w Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` 8) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. 0xFF))
  Ptr Word8 -> Int -> Word8 -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
op 7 (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
w Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. 0xFF))
  )

getWord64 :: BinHandle -> IO Word64
getWord64 :: BinHandle -> IO Word64
getWord64 h :: BinHandle
h = BinHandle -> Int -> (Ptr Word8 -> IO Word64) -> IO Word64
forall a. BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a
getPrim BinHandle
h 8 (\op :: Ptr Word8
op -> do
  Word64
w0 <- Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word64) -> IO Word8 -> IO Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Word8 -> Int -> IO Word8
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word8
op 0
  Word64
w1 <- Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word64) -> IO Word8 -> IO Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Word8 -> Int -> IO Word8
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word8
op 1
  Word64
w2 <- Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word64) -> IO Word8 -> IO Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Word8 -> Int -> IO Word8
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word8
op 2
  Word64
w3 <- Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word64) -> IO Word8 -> IO Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Word8 -> Int -> IO Word8
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word8
op 3
  Word64
w4 <- Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word64) -> IO Word8 -> IO Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Word8 -> Int -> IO Word8
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word8
op 4
  Word64
w5 <- Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word64) -> IO Word8 -> IO Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Word8 -> Int -> IO Word8
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word8
op 5
  Word64
w6 <- Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word64) -> IO Word8 -> IO Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Word8 -> Int -> IO Word8
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word8
op 6
  Word64
w7 <- Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word64) -> IO Word8 -> IO Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Word8 -> Int -> IO Word8
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word8
op 7

  Word64 -> IO Word64
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64 -> IO Word64) -> Word64 -> IO Word64
forall a b. (a -> b) -> a -> b
$! (Word64
w0 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` 56) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|.
            (Word64
w1 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` 48) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|.
            (Word64
w2 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` 40) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|.
            (Word64
w3 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` 32) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|.
            (Word64
w4 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` 24) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|.
            (Word64
w5 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` 16) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|.
            (Word64
w6 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` 8)  Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|.
            Word64
w7
  )

putByte :: BinHandle -> Word8 -> IO ()
putByte :: BinHandle -> Word8 -> IO ()
putByte bh :: BinHandle
bh w :: Word8
w = BinHandle -> Word8 -> IO ()
putWord8 BinHandle
bh Word8
w

getByte :: BinHandle -> IO Word8
getByte :: BinHandle -> IO Word8
getByte h :: BinHandle
h = BinHandle -> IO Word8
getWord8 BinHandle
h

-- -----------------------------------------------------------------------------
-- Primitive Word writes

instance Binary Word8 where
  put_ :: BinHandle -> Word8 -> IO ()
put_ = BinHandle -> Word8 -> IO ()
putWord8
  get :: BinHandle -> IO Word8
get  = BinHandle -> IO Word8
getWord8

instance Binary Word16 where
  put_ :: BinHandle -> Word16 -> IO ()
put_ h :: BinHandle
h w :: Word16
w = BinHandle -> Word16 -> IO ()
putWord16 BinHandle
h Word16
w
  get :: BinHandle -> IO Word16
get h :: BinHandle
h = BinHandle -> IO Word16
getWord16 BinHandle
h

instance Binary Word32 where
  put_ :: BinHandle -> Word32 -> IO ()
put_ h :: BinHandle
h w :: Word32
w = BinHandle -> Word32 -> IO ()
putWord32 BinHandle
h Word32
w
  get :: BinHandle -> IO Word32
get h :: BinHandle
h = BinHandle -> IO Word32
getWord32 BinHandle
h

instance Binary Word64 where
  put_ :: BinHandle -> Word64 -> IO ()
put_ h :: BinHandle
h w :: Word64
w = BinHandle -> Word64 -> IO ()
putWord64 BinHandle
h Word64
w
  get :: BinHandle -> IO Word64
get h :: BinHandle
h = BinHandle -> IO Word64
getWord64 BinHandle
h

-- -----------------------------------------------------------------------------
-- Primitive Int writes

instance Binary Int8 where
  put_ :: BinHandle -> Int8 -> IO ()
put_ h :: BinHandle
h w :: Int8
w = BinHandle -> Word8 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
h (Int8 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int8
w :: Word8)
  get :: BinHandle -> IO Int8
get h :: BinHandle
h    = do Word8
w <- BinHandle -> IO Word8
forall a. Binary a => BinHandle -> IO a
get BinHandle
h; Int8 -> IO Int8
forall (m :: * -> *) a. Monad m => a -> m a
return (Int8 -> IO Int8) -> Int8 -> IO Int8
forall a b. (a -> b) -> a -> b
$! (Word8 -> Int8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
w::Word8))

instance Binary Int16 where
  put_ :: BinHandle -> Int16 -> IO ()
put_ h :: BinHandle
h w :: Int16
w = BinHandle -> Word16 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
h (Int16 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
w :: Word16)
  get :: BinHandle -> IO Int16
get h :: BinHandle
h    = do Word16
w <- BinHandle -> IO Word16
forall a. Binary a => BinHandle -> IO a
get BinHandle
h; Int16 -> IO Int16
forall (m :: * -> *) a. Monad m => a -> m a
return (Int16 -> IO Int16) -> Int16 -> IO Int16
forall a b. (a -> b) -> a -> b
$! (Word16 -> Int16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
w::Word16))

instance Binary Int32 where
  put_ :: BinHandle -> Int32 -> IO ()
put_ h :: BinHandle
h w :: Int32
w = BinHandle -> Word32 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
h (Int32 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
w :: Word32)
  get :: BinHandle -> IO Int32
get h :: BinHandle
h    = do Word32
w <- BinHandle -> IO Word32
forall a. Binary a => BinHandle -> IO a
get BinHandle
h; Int32 -> IO Int32
forall (m :: * -> *) a. Monad m => a -> m a
return (Int32 -> IO Int32) -> Int32 -> IO Int32
forall a b. (a -> b) -> a -> b
$! (Word32 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
w::Word32))

instance Binary Int64 where
  put_ :: BinHandle -> Int64 -> IO ()
put_ h :: BinHandle
h w :: Int64
w = BinHandle -> Word64 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
h (Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
w :: Word64)
  get :: BinHandle -> IO Int64
get h :: BinHandle
h    = do Word64
w <- BinHandle -> IO Word64
forall a. Binary a => BinHandle -> IO a
get BinHandle
h; Int64 -> IO Int64
forall (m :: * -> *) a. Monad m => a -> m a
return (Int64 -> IO Int64) -> Int64 -> IO Int64
forall a b. (a -> b) -> a -> b
$! (Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
w::Word64))

-- -----------------------------------------------------------------------------
-- Instances for standard types

instance Binary () where
    put_ :: BinHandle -> () -> IO ()
put_ _ () = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    get :: BinHandle -> IO ()
get  _    = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

instance Binary Bool where
    put_ :: BinHandle -> Bool -> IO ()
put_ bh :: BinHandle
bh b :: Bool
b = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Bool -> Int
forall a. Enum a => a -> Int
fromEnum Bool
b))
    get :: BinHandle -> IO Bool
get  bh :: BinHandle
bh   = do Word8
x <- BinHandle -> IO Word8
getWord8 BinHandle
bh; Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$! (Int -> Bool
forall a. Enum a => Int -> a
toEnum (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x))

instance Binary Char where
    put_ :: BinHandle -> Char -> IO ()
put_  bh :: BinHandle
bh c :: Char
c = BinHandle -> Word32 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c) :: Word32)
    get :: BinHandle -> IO Char
get  bh :: BinHandle
bh   = do Word32
x <- BinHandle -> IO Word32
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh; Char -> IO Char
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> IO Char) -> Char -> IO Char
forall a b. (a -> b) -> a -> b
$! (Int -> Char
chr (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
x :: Word32)))

instance Binary Int where
    put_ :: BinHandle -> Int -> IO ()
put_ bh :: BinHandle
bh i :: Int
i = BinHandle -> Int64 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i :: Int64)
    get :: BinHandle -> IO Int
get  bh :: BinHandle
bh = do
        Int64
x <- BinHandle -> IO Int64
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$! (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64
x :: Int64))

instance Binary a => Binary [a] where
    put_ :: BinHandle -> [a] -> IO ()
put_ bh :: BinHandle
bh l :: [a]
l = do
        let len :: Int
len = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
l
        if (Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0xff)
          then BinHandle -> Word8 -> IO ()
putByte BinHandle
bh (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len :: Word8)
          else do BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 0xff; BinHandle -> Word32 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len :: Word32)
        (a -> IO ()) -> [a] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (BinHandle -> a -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh) [a]
l
    get :: BinHandle -> IO [a]
get bh :: BinHandle
bh = do
        Word8
b <- BinHandle -> IO Word8
getByte BinHandle
bh
        Word32
len <- if Word8
b Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 0xff
                  then BinHandle -> IO Word32
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                  else Word32 -> IO Word32
forall (m :: * -> *) a. Monad m => a -> m a
return (Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b :: Word32)
        let loop :: Word32 -> IO [a]
loop 0 = [a] -> IO [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
            loop n :: Word32
n = do a
a <- BinHandle -> IO a
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh; [a]
as <- Word32 -> IO [a]
loop (Word32
nWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
-1); [a] -> IO [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
as)
        Word32 -> IO [a]
loop Word32
len

instance (Ix a, Binary a, Binary b) => Binary (Array a b) where
    put_ :: BinHandle -> Array a b -> IO ()
put_ bh :: BinHandle
bh arr :: Array a b
arr = do
        BinHandle -> (a, a) -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh ((a, a) -> IO ()) -> (a, a) -> IO ()
forall a b. (a -> b) -> a -> b
$ Array a b -> (a, a)
forall i e. Array i e -> (i, i)
bounds Array a b
arr
        BinHandle -> [b] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh ([b] -> IO ()) -> [b] -> IO ()
forall a b. (a -> b) -> a -> b
$ Array a b -> [b]
forall i e. Array i e -> [e]
elems Array a b
arr
    get :: BinHandle -> IO (Array a b)
get bh :: BinHandle
bh = do
        (a, a)
bounds <- BinHandle -> IO (a, a)
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        [b]
xs <- BinHandle -> IO [b]
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        Array a b -> IO (Array a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Array a b -> IO (Array a b)) -> Array a b -> IO (Array a b)
forall a b. (a -> b) -> a -> b
$ (a, a) -> [b] -> Array a b
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (a, a)
bounds [b]
xs

instance (Binary a, Binary b) => Binary (a,b) where
    put_ :: BinHandle -> (a, b) -> IO ()
put_ bh :: BinHandle
bh (a :: a
a,b :: b
b) = do BinHandle -> a -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh a
a; BinHandle -> b -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh b
b
    get :: BinHandle -> IO (a, b)
get bh :: BinHandle
bh        = do a
a <- BinHandle -> IO a
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                       b
b <- BinHandle -> IO b
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                       (a, b) -> IO (a, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,b
b)

instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
    put_ :: BinHandle -> (a, b, c) -> IO ()
put_ bh :: BinHandle
bh (a :: a
a,b :: b
b,c :: c
c) = do BinHandle -> a -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh a
a; BinHandle -> b -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh b
b; BinHandle -> c -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh c
c
    get :: BinHandle -> IO (a, b, c)
get bh :: BinHandle
bh          = do a
a <- BinHandle -> IO a
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                         b
b <- BinHandle -> IO b
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                         c
c <- BinHandle -> IO c
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                         (a, b, c) -> IO (a, b, c)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,b
b,c
c)

instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
    put_ :: BinHandle -> (a, b, c, d) -> IO ()
put_ bh :: BinHandle
bh (a :: a
a,b :: b
b,c :: c
c,d :: d
d) = do BinHandle -> a -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh a
a; BinHandle -> b -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh b
b; BinHandle -> c -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh c
c; BinHandle -> d -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh d
d
    get :: BinHandle -> IO (a, b, c, d)
get bh :: BinHandle
bh            = do a
a <- BinHandle -> IO a
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                           b
b <- BinHandle -> IO b
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                           c
c <- BinHandle -> IO c
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                           d
d <- BinHandle -> IO d
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                           (a, b, c, d) -> IO (a, b, c, d)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,b
b,c
c,d
d)

instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d, e) where
    put_ :: BinHandle -> (a, b, c, d, e) -> IO ()
put_ bh :: BinHandle
bh (a :: a
a,b :: b
b,c :: c
c,d :: d
d, e :: e
e) = do BinHandle -> a -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh a
a; BinHandle -> b -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh b
b; BinHandle -> c -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh c
c; BinHandle -> d -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh d
d; BinHandle -> e -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh e
e;
    get :: BinHandle -> IO (a, b, c, d, e)
get bh :: BinHandle
bh               = do a
a <- BinHandle -> IO a
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                              b
b <- BinHandle -> IO b
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                              c
c <- BinHandle -> IO c
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                              d
d <- BinHandle -> IO d
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                              e
e <- BinHandle -> IO e
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                              (a, b, c, d, e) -> IO (a, b, c, d, e)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,b
b,c
c,d
d,e
e)

instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) => Binary (a,b,c,d, e, f) where
    put_ :: BinHandle -> (a, b, c, d, e, f) -> IO ()
put_ bh :: BinHandle
bh (a :: a
a,b :: b
b,c :: c
c,d :: d
d, e :: e
e, f :: f
f) = do BinHandle -> a -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh a
a; BinHandle -> b -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh b
b; BinHandle -> c -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh c
c; BinHandle -> d -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh d
d; BinHandle -> e -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh e
e; BinHandle -> f -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh f
f;
    get :: BinHandle -> IO (a, b, c, d, e, f)
get bh :: BinHandle
bh                  = do a
a <- BinHandle -> IO a
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                                 b
b <- BinHandle -> IO b
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                                 c
c <- BinHandle -> IO c
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                                 d
d <- BinHandle -> IO d
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                                 e
e <- BinHandle -> IO e
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                                 f
f <- BinHandle -> IO f
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                                 (a, b, c, d, e, f) -> IO (a, b, c, d, e, f)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,b
b,c
c,d
d,e
e,f
f)

instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g) => Binary (a,b,c,d,e,f,g) where
    put_ :: BinHandle -> (a, b, c, d, e, f, g) -> IO ()
put_ bh :: BinHandle
bh (a :: a
a,b :: b
b,c :: c
c,d :: d
d,e :: e
e,f :: f
f,g :: g
g) = do BinHandle -> a -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh a
a; BinHandle -> b -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh b
b; BinHandle -> c -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh c
c; BinHandle -> d -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh d
d; BinHandle -> e -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh e
e; BinHandle -> f -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh f
f; BinHandle -> g -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh g
g
    get :: BinHandle -> IO (a, b, c, d, e, f, g)
get bh :: BinHandle
bh                  = do a
a <- BinHandle -> IO a
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                                 b
b <- BinHandle -> IO b
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                                 c
c <- BinHandle -> IO c
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                                 d
d <- BinHandle -> IO d
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                                 e
e <- BinHandle -> IO e
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                                 f
f <- BinHandle -> IO f
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                                 g
g <- BinHandle -> IO g
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                                 (a, b, c, d, e, f, g) -> IO (a, b, c, d, e, f, g)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,b
b,c
c,d
d,e
e,f
f,g
g)

instance Binary a => Binary (Maybe a) where
    put_ :: BinHandle -> Maybe a -> IO ()
put_ bh :: BinHandle
bh Nothing  = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 0
    put_ bh :: BinHandle
bh (Just a :: a
a) = do BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 1; BinHandle -> a -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh a
a
    get :: BinHandle -> IO (Maybe a)
get bh :: BinHandle
bh           = do Word8
h <- BinHandle -> IO Word8
getWord8 BinHandle
bh
                          case Word8
h of
                            0 -> Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
                            _ -> do a
x <- BinHandle -> IO a
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh; Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
x)

instance (Binary a, Binary b) => Binary (Either a b) where
    put_ :: BinHandle -> Either a b -> IO ()
put_ bh :: BinHandle
bh (Left  a :: a
a) = do BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 0; BinHandle -> a -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh a
a
    put_ bh :: BinHandle
bh (Right b :: b
b) = do BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 1; BinHandle -> b -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh b
b
    get :: BinHandle -> IO (Either a b)
get bh :: BinHandle
bh            = do Word8
h <- BinHandle -> IO Word8
getWord8 BinHandle
bh
                           case Word8
h of
                             0 -> do a
a <- BinHandle -> IO a
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh ; Either a b -> IO (Either a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either a b
forall a b. a -> Either a b
Left a
a)
                             _ -> do b
b <- BinHandle -> IO b
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh ; Either a b -> IO (Either a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> Either a b
forall a b. b -> Either a b
Right b
b)

instance Binary UTCTime where
    put_ :: BinHandle -> UTCTime -> IO ()
put_ bh :: BinHandle
bh u :: UTCTime
u = do BinHandle -> Day -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (UTCTime -> Day
utctDay UTCTime
u)
                   BinHandle -> DiffTime -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (UTCTime -> DiffTime
utctDayTime UTCTime
u)
    get :: BinHandle -> IO UTCTime
get bh :: BinHandle
bh = do Day
day <- BinHandle -> IO Day
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                DiffTime
dayTime <- BinHandle -> IO DiffTime
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                UTCTime -> IO UTCTime
forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime -> IO UTCTime) -> UTCTime -> IO UTCTime
forall a b. (a -> b) -> a -> b
$ UTCTime :: Day -> DiffTime -> UTCTime
UTCTime { utctDay :: Day
utctDay = Day
day, utctDayTime :: DiffTime
utctDayTime = DiffTime
dayTime }

instance Binary Day where
    put_ :: BinHandle -> Day -> IO ()
put_ bh :: BinHandle
bh d :: Day
d = BinHandle -> Integer -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Day -> Integer
toModifiedJulianDay Day
d)
    get :: BinHandle -> IO Day
get bh :: BinHandle
bh = do Integer
i <- BinHandle -> IO Integer
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                Day -> IO Day
forall (m :: * -> *) a. Monad m => a -> m a
return (Day -> IO Day) -> Day -> IO Day
forall a b. (a -> b) -> a -> b
$ ModifiedJulianDay :: Integer -> Day
ModifiedJulianDay { toModifiedJulianDay :: Integer
toModifiedJulianDay = Integer
i }

instance Binary DiffTime where
    put_ :: BinHandle -> DiffTime -> IO ()
put_ bh :: BinHandle
bh dt :: DiffTime
dt = BinHandle -> Rational -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (DiffTime -> Rational
forall a. Real a => a -> Rational
toRational DiffTime
dt)
    get :: BinHandle -> IO DiffTime
get bh :: BinHandle
bh = do Rational
r <- BinHandle -> IO Rational
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                DiffTime -> IO DiffTime
forall (m :: * -> *) a. Monad m => a -> m a
return (DiffTime -> IO DiffTime) -> DiffTime -> IO DiffTime
forall a b. (a -> b) -> a -> b
$ Rational -> DiffTime
forall a. Fractional a => Rational -> a
fromRational Rational
r

--to quote binary-0.3 on this code idea,
--
-- TODO  This instance is not architecture portable.  GMP stores numbers as
-- arrays of machine sized words, so the byte format is not portable across
-- architectures with different endianness and word size.
--
-- This makes it hard (impossible) to make an equivalent instance
-- with code that is compilable with non-GHC.  Do we need any instance
-- Binary Integer, and if so, does it have to be blazing fast?  Or can
-- we just change this instance to be portable like the rest of the
-- instances? (binary package has code to steal for that)
--
-- yes, we need Binary Integer and Binary Rational in basicTypes/Literal.hs

instance Binary Integer where
    put_ :: BinHandle -> Integer -> IO ()
put_ bh :: BinHandle
bh i :: Integer
i
      | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
lo32 Bool -> Bool -> Bool
&& Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
hi32 = do
          BinHandle -> Word8 -> IO ()
putWord8 BinHandle
bh 0
          BinHandle -> Int32 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Integer -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i :: Int32)
      | Bool
otherwise = do
          BinHandle -> Word8 -> IO ()
putWord8 BinHandle
bh 1
          BinHandle -> String -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Integer -> String
forall a. Show a => a -> String
show Integer
i)
      where
        lo32 :: Integer
lo32 = Int32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32
forall a. Bounded a => a
minBound :: Int32)
        hi32 :: Integer
hi32 = Int32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32
forall a. Bounded a => a
maxBound :: Int32)

    get :: BinHandle -> IO Integer
get bh :: BinHandle
bh = do
      Word8
int_kind <- BinHandle -> IO Word8
getWord8 BinHandle
bh
      case Word8
int_kind of
        0 -> Int32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Integer) -> IO Int32 -> IO Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (BinHandle -> IO Int32
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh :: IO Int32)
        _ -> do String
str <- BinHandle -> IO String
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                case ReadS Integer
forall a. Read a => ReadS a
reads String
str of
                  [(i :: Integer
i, "")] -> Integer -> IO Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
i
                  _ -> String -> IO Integer
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ("Binary integer: got " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
str)

    {-
    -- This code is currently commented out.
    -- See https://ghc.haskell.org/trac/ghc/ticket/3379#comment:10 for
    -- discussion.

    put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)
    put_ bh (J# s# a#) = do
        putByte bh 1
        put_ bh (I# s#)
        let sz# = sizeofByteArray# a#  -- in *bytes*
        put_ bh (I# sz#)  -- in *bytes*
        putByteArray bh a# sz#

    get bh = do
        b <- getByte bh
        case b of
          0 -> do (I# i#) <- get bh
                  return (S# i#)
          _ -> do (I# s#) <- get bh
                  sz <- get bh
                  (BA a#) <- getByteArray bh sz
                  return (J# s# a#)

putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()
putByteArray bh a s# = loop 0#
  where loop n#
           | n# ==# s# = return ()
           | otherwise = do
                putByte bh (indexByteArray a n#)
                loop (n# +# 1#)

getByteArray :: BinHandle -> Int -> IO ByteArray
getByteArray bh (I# sz) = do
  (MBA arr) <- newByteArray sz
  let loop n
           | n ==# sz = return ()
           | otherwise = do
                w <- getByte bh
                writeByteArray arr n w
                loop (n +# 1#)
  loop 0#
  freezeByteArray arr
    -}

{-
data ByteArray = BA ByteArray#
data MBA = MBA (MutableByteArray# RealWorld)

newByteArray :: Int# -> IO MBA
newByteArray sz = IO $ \s ->
  case newByteArray# sz s of { (# s, arr #) ->
  (# s, MBA arr #) }

freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
freezeByteArray arr = IO $ \s ->
  case unsafeFreezeByteArray# arr s of { (# s, arr #) ->
  (# s, BA arr #) }

writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()
writeByteArray arr i (W8# w) = IO $ \s ->
  case writeWord8Array# arr i w s of { s ->
  (# s, () #) }

indexByteArray :: ByteArray# -> Int# -> Word8
indexByteArray a# n# = W8# (indexWord8Array# a# n#)

-}
instance (Binary a) => Binary (Ratio a) where
    put_ :: BinHandle -> Ratio a -> IO ()
put_ bh :: BinHandle
bh (a :: a
a :% b :: a
b) = do BinHandle -> a -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh a
a; BinHandle -> a -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh a
b
    get :: BinHandle -> IO (Ratio a)
get bh :: BinHandle
bh = do a
a <- BinHandle -> IO a
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh; a
b <- BinHandle -> IO a
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh; Ratio a -> IO (Ratio a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a a -> a -> Ratio a
forall a. a -> a -> Ratio a
:% a
b)

instance Binary (Bin a) where
  put_ :: BinHandle -> Bin a -> IO ()
put_ bh :: BinHandle
bh (BinPtr i :: Int
i) = BinHandle -> Int32 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i :: Int32)
  get :: BinHandle -> IO (Bin a)
get bh :: BinHandle
bh = do Int32
i <- BinHandle -> IO Int32
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh; Bin a -> IO (Bin a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Bin a
forall k (a :: k). Int -> Bin a
BinPtr (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32
i :: Int32)))

-- -----------------------------------------------------------------------------
-- Instances for Data.Typeable stuff

instance Binary TyCon where
    put_ :: BinHandle -> TyCon -> IO ()
put_ bh :: BinHandle
bh tc :: TyCon
tc = do
        BinHandle -> String -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (TyCon -> String
tyConPackage TyCon
tc)
        BinHandle -> String -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (TyCon -> String
tyConModule TyCon
tc)
        BinHandle -> String -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (TyCon -> String
tyConName TyCon
tc)
        BinHandle -> Int -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (TyCon -> Int
tyConKindArgs TyCon
tc)
        BinHandle -> KindRep -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (TyCon -> KindRep
tyConKindRep TyCon
tc)
    get :: BinHandle -> IO TyCon
get bh :: BinHandle
bh =
        String -> String -> String -> Int -> KindRep -> TyCon
mkTyCon (String -> String -> String -> Int -> KindRep -> TyCon)
-> IO String -> IO (String -> String -> Int -> KindRep -> TyCon)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinHandle -> IO String
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh IO (String -> String -> Int -> KindRep -> TyCon)
-> IO String -> IO (String -> Int -> KindRep -> TyCon)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BinHandle -> IO String
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh IO (String -> Int -> KindRep -> TyCon)
-> IO String -> IO (Int -> KindRep -> TyCon)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BinHandle -> IO String
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh IO (Int -> KindRep -> TyCon) -> IO Int -> IO (KindRep -> TyCon)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BinHandle -> IO Int
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh IO (KindRep -> TyCon) -> IO KindRep -> IO TyCon
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BinHandle -> IO KindRep
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh

instance Binary VecCount where
    put_ :: BinHandle -> VecCount -> IO ()
put_ bh :: BinHandle
bh = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh (Word8 -> IO ()) -> (VecCount -> Word8) -> VecCount -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (VecCount -> Int) -> VecCount -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VecCount -> Int
forall a. Enum a => a -> Int
fromEnum
    get :: BinHandle -> IO VecCount
get bh :: BinHandle
bh = Int -> VecCount
forall a. Enum a => Int -> a
toEnum (Int -> VecCount) -> (Word8 -> Int) -> Word8 -> VecCount
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> VecCount) -> IO Word8 -> IO VecCount
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinHandle -> IO Word8
getByte BinHandle
bh

instance Binary VecElem where
    put_ :: BinHandle -> VecElem -> IO ()
put_ bh :: BinHandle
bh = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh (Word8 -> IO ()) -> (VecElem -> Word8) -> VecElem -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (VecElem -> Int) -> VecElem -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VecElem -> Int
forall a. Enum a => a -> Int
fromEnum
    get :: BinHandle -> IO VecElem
get bh :: BinHandle
bh = Int -> VecElem
forall a. Enum a => Int -> a
toEnum (Int -> VecElem) -> (Word8 -> Int) -> Word8 -> VecElem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> VecElem) -> IO Word8 -> IO VecElem
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinHandle -> IO Word8
getByte BinHandle
bh

instance Binary RuntimeRep where
    put_ :: BinHandle -> RuntimeRep -> IO ()
put_ bh :: BinHandle
bh (VecRep a :: VecCount
a b :: VecElem
b)    = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 0 IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BinHandle -> VecCount -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh VecCount
a IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BinHandle -> VecElem -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh VecElem
b
    put_ bh :: BinHandle
bh (TupleRep reps :: [RuntimeRep]
reps) = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 1 IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BinHandle -> [RuntimeRep] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [RuntimeRep]
reps
    put_ bh :: BinHandle
bh (SumRep reps :: [RuntimeRep]
reps)   = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 2 IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BinHandle -> [RuntimeRep] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [RuntimeRep]
reps
    put_ bh :: BinHandle
bh LiftedRep       = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 3
    put_ bh :: BinHandle
bh UnliftedRep     = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 4
    put_ bh :: BinHandle
bh IntRep          = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 5
    put_ bh :: BinHandle
bh WordRep         = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 6
    put_ bh :: BinHandle
bh Int64Rep        = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 7
    put_ bh :: BinHandle
bh Word64Rep       = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 8
    put_ bh :: BinHandle
bh AddrRep         = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 9
    put_ bh :: BinHandle
bh FloatRep        = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 10
    put_ bh :: BinHandle
bh DoubleRep       = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 11
#if __GLASGOW_HASKELL__ >= 807
    put_ bh :: BinHandle
bh Int8Rep         = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 12
    put_ bh :: BinHandle
bh Word8Rep        = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 13
    put_ bh :: BinHandle
bh Int16Rep        = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 14
    put_ bh :: BinHandle
bh Word16Rep       = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 15
#endif

    get :: BinHandle -> IO RuntimeRep
get bh :: BinHandle
bh = do
        Word8
tag <- BinHandle -> IO Word8
getByte BinHandle
bh
        case Word8
tag of
          0  -> VecCount -> VecElem -> RuntimeRep
VecRep (VecCount -> VecElem -> RuntimeRep)
-> IO VecCount -> IO (VecElem -> RuntimeRep)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinHandle -> IO VecCount
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh IO (VecElem -> RuntimeRep) -> IO VecElem -> IO RuntimeRep
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BinHandle -> IO VecElem
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
          1  -> [RuntimeRep] -> RuntimeRep
TupleRep ([RuntimeRep] -> RuntimeRep) -> IO [RuntimeRep] -> IO RuntimeRep
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinHandle -> IO [RuntimeRep]
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
          2  -> [RuntimeRep] -> RuntimeRep
SumRep ([RuntimeRep] -> RuntimeRep) -> IO [RuntimeRep] -> IO RuntimeRep
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinHandle -> IO [RuntimeRep]
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
          3  -> RuntimeRep -> IO RuntimeRep
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
LiftedRep
          4  -> RuntimeRep -> IO RuntimeRep
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
UnliftedRep
          5  -> RuntimeRep -> IO RuntimeRep
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
IntRep
          6  -> RuntimeRep -> IO RuntimeRep
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
WordRep
          7  -> RuntimeRep -> IO RuntimeRep
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
Int64Rep
          8  -> RuntimeRep -> IO RuntimeRep
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
Word64Rep
          9  -> RuntimeRep -> IO RuntimeRep
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
AddrRep
          10 -> RuntimeRep -> IO RuntimeRep
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
FloatRep
          11 -> RuntimeRep -> IO RuntimeRep
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
DoubleRep
#if __GLASGOW_HASKELL__ >= 807
          12 -> RuntimeRep -> IO RuntimeRep
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
Int8Rep
          13 -> RuntimeRep -> IO RuntimeRep
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
Word8Rep
          14 -> RuntimeRep -> IO RuntimeRep
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
Int16Rep
          15 -> RuntimeRep -> IO RuntimeRep
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
Word16Rep
#endif
          _  -> String -> IO RuntimeRep
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Binary.putRuntimeRep: invalid tag"

instance Binary KindRep where
    put_ :: BinHandle -> KindRep -> IO ()
put_ bh :: BinHandle
bh (KindRepTyConApp tc :: TyCon
tc k :: [KindRep]
k) = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 0 IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BinHandle -> TyCon -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh TyCon
tc IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BinHandle -> [KindRep] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [KindRep]
k
    put_ bh :: BinHandle
bh (KindRepVar bndr :: Int
bndr) = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 1 IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BinHandle -> Int -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Int
bndr
    put_ bh :: BinHandle
bh (KindRepApp a :: KindRep
a b :: KindRep
b) = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 2 IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BinHandle -> KindRep -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh KindRep
a IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BinHandle -> KindRep -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh KindRep
b
    put_ bh :: BinHandle
bh (KindRepFun a :: KindRep
a b :: KindRep
b) = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 3 IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BinHandle -> KindRep -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh KindRep
a IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BinHandle -> KindRep -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh KindRep
b
    put_ bh :: BinHandle
bh (KindRepTYPE r :: RuntimeRep
r) = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 4 IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BinHandle -> RuntimeRep -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh RuntimeRep
r
    put_ bh :: BinHandle
bh (KindRepTypeLit sort :: TypeLitSort
sort r :: String
r) = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 5 IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BinHandle -> TypeLitSort -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh TypeLitSort
sort IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BinHandle -> String -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh String
r

    get :: BinHandle -> IO KindRep
get bh :: BinHandle
bh = do
        Word8
tag <- BinHandle -> IO Word8
getByte BinHandle
bh
        case Word8
tag of
          0 -> TyCon -> [KindRep] -> KindRep
KindRepTyConApp (TyCon -> [KindRep] -> KindRep)
-> IO TyCon -> IO ([KindRep] -> KindRep)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinHandle -> IO TyCon
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh IO ([KindRep] -> KindRep) -> IO [KindRep] -> IO KindRep
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BinHandle -> IO [KindRep]
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
          1 -> Int -> KindRep
KindRepVar (Int -> KindRep) -> IO Int -> IO KindRep
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinHandle -> IO Int
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
          2 -> KindRep -> KindRep -> KindRep
KindRepApp (KindRep -> KindRep -> KindRep)
-> IO KindRep -> IO (KindRep -> KindRep)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinHandle -> IO KindRep
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh IO (KindRep -> KindRep) -> IO KindRep -> IO KindRep
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BinHandle -> IO KindRep
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
          3 -> KindRep -> KindRep -> KindRep
KindRepFun (KindRep -> KindRep -> KindRep)
-> IO KindRep -> IO (KindRep -> KindRep)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinHandle -> IO KindRep
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh IO (KindRep -> KindRep) -> IO KindRep -> IO KindRep
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BinHandle -> IO KindRep
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
          4 -> RuntimeRep -> KindRep
KindRepTYPE (RuntimeRep -> KindRep) -> IO RuntimeRep -> IO KindRep
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinHandle -> IO RuntimeRep
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
          5 -> TypeLitSort -> String -> KindRep
KindRepTypeLit (TypeLitSort -> String -> KindRep)
-> IO TypeLitSort -> IO (String -> KindRep)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinHandle -> IO TypeLitSort
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh IO (String -> KindRep) -> IO String -> IO KindRep
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BinHandle -> IO String
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
          _ -> String -> IO KindRep
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Binary.putKindRep: invalid tag"

instance Binary TypeLitSort where
    put_ :: BinHandle -> TypeLitSort -> IO ()
put_ bh :: BinHandle
bh TypeLitSymbol = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 0
    put_ bh :: BinHandle
bh TypeLitNat = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 1
    get :: BinHandle -> IO TypeLitSort
get bh :: BinHandle
bh = do
        Word8
tag <- BinHandle -> IO Word8
getByte BinHandle
bh
        case Word8
tag of
          0 -> TypeLitSort -> IO TypeLitSort
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeLitSort
TypeLitSymbol
          1 -> TypeLitSort -> IO TypeLitSort
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeLitSort
TypeLitNat
          _ -> String -> IO TypeLitSort
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Binary.putTypeLitSort: invalid tag"

putTypeRep :: BinHandle -> TypeRep a -> IO ()
-- Special handling for TYPE, (->), and RuntimeRep due to recursive kind
-- relations.
-- See Note [Mutually recursive representations of primitive types]
putTypeRep :: BinHandle -> TypeRep a -> IO ()
putTypeRep bh :: BinHandle
bh rep :: TypeRep a
rep
  | Just HRefl <- TypeRep a
rep TypeRep a -> TypeRep * -> Maybe (a :~~: *)
forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
`eqTypeRep` (TypeRep *
forall k (a :: k). Typeable a => TypeRep a
typeRep :: TypeRep Type)
  = BinHandle -> Word8 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (0 :: Word8)
putTypeRep bh :: BinHandle
bh (Con' con :: TyCon
con ks :: [SomeTypeRep]
ks) = do
    BinHandle -> Word8 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (1 :: Word8)
    BinHandle -> TyCon -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh TyCon
con
    BinHandle -> [SomeTypeRep] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [SomeTypeRep]
ks
putTypeRep bh :: BinHandle
bh (App f :: TypeRep a
f x :: TypeRep b
x) = do
    BinHandle -> Word8 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (2 :: Word8)
    BinHandle -> TypeRep a -> IO ()
forall k (a :: k). BinHandle -> TypeRep a -> IO ()
putTypeRep BinHandle
bh TypeRep a
f
    BinHandle -> TypeRep b -> IO ()
forall k (a :: k). BinHandle -> TypeRep a -> IO ()
putTypeRep BinHandle
bh TypeRep b
x
putTypeRep bh :: BinHandle
bh (Fun arg :: TypeRep arg
arg res :: TypeRep res
res) = do
    BinHandle -> Word8 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (3 :: Word8)
    BinHandle -> TypeRep arg -> IO ()
forall k (a :: k). BinHandle -> TypeRep a -> IO ()
putTypeRep BinHandle
bh TypeRep arg
arg
    BinHandle -> TypeRep res -> IO ()
forall k (a :: k). BinHandle -> TypeRep a -> IO ()
putTypeRep BinHandle
bh TypeRep res
res
putTypeRep _ _ = String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Binary.putTypeRep: Impossible"

getSomeTypeRep :: BinHandle -> IO SomeTypeRep
getSomeTypeRep :: BinHandle -> IO SomeTypeRep
getSomeTypeRep bh :: BinHandle
bh = do
    Word8
tag <- BinHandle -> IO Word8
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh :: IO Word8
    case Word8
tag of
        0 -> SomeTypeRep -> IO SomeTypeRep
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeTypeRep -> IO SomeTypeRep) -> SomeTypeRep -> IO SomeTypeRep
forall a b. (a -> b) -> a -> b
$ TypeRep * -> SomeTypeRep
forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep (TypeRep *
forall k (a :: k). Typeable a => TypeRep a
typeRep :: TypeRep Type)
        1 -> do TyCon
con <- BinHandle -> IO TyCon
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh :: IO TyCon
                [SomeTypeRep]
ks <- BinHandle -> IO [SomeTypeRep]
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh :: IO [SomeTypeRep]
                SomeTypeRep -> IO SomeTypeRep
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeTypeRep -> IO SomeTypeRep) -> SomeTypeRep -> IO SomeTypeRep
forall a b. (a -> b) -> a -> b
$ TypeRep Any -> SomeTypeRep
forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep (TypeRep Any -> SomeTypeRep) -> TypeRep Any -> SomeTypeRep
forall a b. (a -> b) -> a -> b
$ TyCon -> [SomeTypeRep] -> TypeRep Any
forall k (a :: k). TyCon -> [SomeTypeRep] -> TypeRep a
mkTrCon TyCon
con [SomeTypeRep]
ks

        2 -> do SomeTypeRep f :: TypeRep a
f <- BinHandle -> IO SomeTypeRep
getSomeTypeRep BinHandle
bh
                SomeTypeRep x :: TypeRep a
x <- BinHandle -> IO SomeTypeRep
getSomeTypeRep BinHandle
bh
                case TypeRep a -> TypeRep k
forall k (a :: k). TypeRep a -> TypeRep k
typeRepKind TypeRep a
f of
                  Fun arg :: TypeRep arg
arg res :: TypeRep res
res ->
                      case TypeRep arg
arg TypeRep arg -> TypeRep k -> Maybe (arg :~~: k)
forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
`eqTypeRep` TypeRep a -> TypeRep k
forall k (a :: k). TypeRep a -> TypeRep k
typeRepKind TypeRep a
x of
                        Just HRefl ->
                            case TypeRep res -> TypeRep (TYPE r2)
forall k (a :: k). TypeRep a -> TypeRep k
typeRepKind TypeRep res
res TypeRep (TYPE r2) -> TypeRep * -> Maybe (TYPE r2 :~~: *)
forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
`eqTypeRep` (TypeRep *
forall k (a :: k). Typeable a => TypeRep a
typeRep :: TypeRep Type) of
                              Just HRefl -> SomeTypeRep -> IO SomeTypeRep
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeTypeRep -> IO SomeTypeRep) -> SomeTypeRep -> IO SomeTypeRep
forall a b. (a -> b) -> a -> b
$ TypeRep (a a) -> SomeTypeRep
forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep (TypeRep (a a) -> SomeTypeRep) -> TypeRep (a a) -> SomeTypeRep
forall a b. (a -> b) -> a -> b
$ TypeRep a -> TypeRep a -> TypeRep (a a)
forall k1 k2 (a :: k1 -> k2) (b :: k1).
TypeRep a -> TypeRep b -> TypeRep (a b)
mkTrApp TypeRep a
TypeRep a
f TypeRep a
x
                              _ -> String -> [String] -> IO SomeTypeRep
forall (m :: * -> *) a. MonadFail m => String -> [String] -> m a
failure "Kind mismatch in type application" []
                        _ -> String -> [String] -> IO SomeTypeRep
forall (m :: * -> *) a. MonadFail m => String -> [String] -> m a
failure "Kind mismatch in type application"
                             [ "    Found argument of kind: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRep k -> String
forall a. Show a => a -> String
show (TypeRep a -> TypeRep k
forall k (a :: k). TypeRep a -> TypeRep k
typeRepKind TypeRep a
x)
                             , "    Where the constructor:  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRep a -> String
forall a. Show a => a -> String
show TypeRep a
f
                             , "    Expects kind:           " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRep arg -> String
forall a. Show a => a -> String
show TypeRep arg
arg
                             ]
                  _ -> String -> [String] -> IO SomeTypeRep
forall (m :: * -> *) a. MonadFail m => String -> [String] -> m a
failure "Applied non-arrow"
                       [ "    Applied type: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRep a -> String
forall a. Show a => a -> String
show TypeRep a
f
                       , "    To argument:  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRep a -> String
forall a. Show a => a -> String
show TypeRep a
x
                       ]
        3 -> do SomeTypeRep arg :: TypeRep a
arg <- BinHandle -> IO SomeTypeRep
getSomeTypeRep BinHandle
bh
                SomeTypeRep res :: TypeRep a
res <- BinHandle -> IO SomeTypeRep
getSomeTypeRep BinHandle
bh
                if
                  | App argkcon :: TypeRep a
argkcon _ <- TypeRep a -> TypeRep k
forall k (a :: k). TypeRep a -> TypeRep k
typeRepKind TypeRep a
arg
                  , App reskcon :: TypeRep a
reskcon _ <- TypeRep a -> TypeRep k
forall k (a :: k). TypeRep a -> TypeRep k
typeRepKind TypeRep a
res
                  , Just HRefl <- TypeRep a
argkcon TypeRep a -> TypeRep TYPE -> Maybe (a :~~: TYPE)
forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
`eqTypeRep` TypeRep TYPE
tYPErep
                  , Just HRefl <- TypeRep a
reskcon TypeRep a -> TypeRep TYPE -> Maybe (a :~~: TYPE)
forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
`eqTypeRep` TypeRep TYPE
tYPErep
                  -> SomeTypeRep -> IO SomeTypeRep
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeTypeRep -> IO SomeTypeRep) -> SomeTypeRep -> IO SomeTypeRep
forall a b. (a -> b) -> a -> b
$ TypeRep (a -> a) -> SomeTypeRep
forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep (TypeRep (a -> a) -> SomeTypeRep)
-> TypeRep (a -> a) -> SomeTypeRep
forall a b. (a -> b) -> a -> b
$ TypeRep a -> TypeRep a -> TypeRep (a -> a)
forall k (fun :: k) arg res.
(k ~ *, fun ~~ (arg -> res)) =>
TypeRep arg -> TypeRep res -> TypeRep fun
Fun TypeRep a
TypeRep a
arg TypeRep a
TypeRep a
res
                  | Bool
otherwise -> String -> [String] -> IO SomeTypeRep
forall (m :: * -> *) a. MonadFail m => String -> [String] -> m a
failure "Kind mismatch" []
        _ -> String -> [String] -> IO SomeTypeRep
forall (m :: * -> *) a. MonadFail m => String -> [String] -> m a
failure "Invalid SomeTypeRep" []
  where
    tYPErep :: TypeRep TYPE
    tYPErep :: TypeRep TYPE
tYPErep = TypeRep TYPE
forall k (a :: k). Typeable a => TypeRep a
typeRep

    failure :: String -> [String] -> m a
failure description :: String
description info :: [String]
info =
        String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [ "Binary.getSomeTypeRep: "String -> ShowS
forall a. [a] -> [a] -> [a]
++String
description ]
                      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ("    "String -> ShowS
forall a. [a] -> [a] -> [a]
++) [String]
info

instance Typeable a => Binary (TypeRep (a :: k)) where
    put_ :: BinHandle -> TypeRep a -> IO ()
put_ = BinHandle -> TypeRep a -> IO ()
forall k (a :: k). BinHandle -> TypeRep a -> IO ()
putTypeRep
    get :: BinHandle -> IO (TypeRep a)
get bh :: BinHandle
bh = do
        SomeTypeRep rep :: TypeRep a
rep <- BinHandle -> IO SomeTypeRep
getSomeTypeRep BinHandle
bh
        case TypeRep a
rep TypeRep a -> TypeRep a -> Maybe (a :~~: a)
forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
`eqTypeRep` TypeRep a
expected of
            Just HRefl -> TypeRep a -> IO (TypeRep a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeRep a
rep
            Nothing    -> String -> IO (TypeRep a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (TypeRep a)) -> String -> IO (TypeRep a)
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
                               [ "Binary: Type mismatch"
                               , "    Deserialized type: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRep a -> String
forall a. Show a => a -> String
show TypeRep a
rep
                               , "    Expected type:     " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRep a -> String
forall a. Show a => a -> String
show TypeRep a
expected
                               ]
     where expected :: TypeRep a
expected = TypeRep a
forall k (a :: k). Typeable a => TypeRep a
typeRep :: TypeRep a

instance Binary SomeTypeRep where
    put_ :: BinHandle -> SomeTypeRep -> IO ()
put_ bh :: BinHandle
bh (SomeTypeRep rep :: TypeRep a
rep) = BinHandle -> TypeRep a -> IO ()
forall k (a :: k). BinHandle -> TypeRep a -> IO ()
putTypeRep BinHandle
bh TypeRep a
rep
    get :: BinHandle -> IO SomeTypeRep
get = BinHandle -> IO SomeTypeRep
getSomeTypeRep

-- -----------------------------------------------------------------------------
-- Lazy reading/writing

lazyPut :: Binary a => BinHandle -> a -> IO ()
lazyPut :: BinHandle -> a -> IO ()
lazyPut bh :: BinHandle
bh a :: a
a = do
    -- output the obj with a ptr to skip over it:
    Bin (Bin Any)
pre_a <- BinHandle -> IO (Bin (Bin Any))
forall k (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh
    BinHandle -> Bin (Bin Any) -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Bin (Bin Any)
pre_a       -- save a slot for the ptr
    BinHandle -> a -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh a
a           -- dump the object
    Bin Any
q <- BinHandle -> IO (Bin Any)
forall k (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh     -- q = ptr to after object
    BinHandle -> Bin (Bin Any) -> Bin Any -> IO ()
forall a. Binary a => BinHandle -> Bin a -> a -> IO ()
putAt BinHandle
bh Bin (Bin Any)
pre_a Bin Any
q    -- fill in slot before a with ptr to q
    BinHandle -> Bin Any -> IO ()
forall k (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin Any
q        -- finally carry on writing at q

lazyGet :: Binary a => BinHandle -> IO a
lazyGet :: BinHandle -> IO a
lazyGet bh :: BinHandle
bh = do
    Bin Any
p <- BinHandle -> IO (Bin Any)
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh -- a BinPtr
    Bin a
p_a <- BinHandle -> IO (Bin a)
forall k (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh
    a
a <- IO a -> IO a
forall a. IO a -> IO a
unsafeInterleaveIO (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
        -- NB: Use a fresh off_r variable in the child thread, for thread
        -- safety.
        FastMutInt
off_r <- IO FastMutInt
newFastMutInt
        BinHandle -> Bin a -> IO a
forall a. Binary a => BinHandle -> Bin a -> IO a
getAt BinHandle
bh { _off_r :: FastMutInt
_off_r = FastMutInt
off_r } Bin a
p_a
    BinHandle -> Bin Any -> IO ()
forall k (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin Any
p -- skip over the object for now
    a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- -----------------------------------------------------------------------------
-- UserData
-- -----------------------------------------------------------------------------

-- | Information we keep around during interface file
-- serialization/deserialization. Namely we keep the functions for serializing
-- and deserializing 'Name's and 'FastString's. We do this because we actually
-- use serialization in two distinct settings,
--
-- * When serializing interface files themselves
--
-- * When computing the fingerprint of an IfaceDecl (which we computing by
--   hashing its Binary serialization)
--
-- These two settings have different needs while serializing Names:
--
-- * Names in interface files are serialized via a symbol table (see Note
--   [Symbol table representation of names] in BinIface).
--
-- * During fingerprinting a binding Name is serialized as the OccName and a
--   non-binding Name is serialized as the fingerprint of the thing they
--   represent. See Note [Fingerprinting IfaceDecls] for further discussion.
--
data UserData =
   UserData {
        -- for *deserialising* only:
        UserData -> BinHandle -> IO Name
ud_get_name :: BinHandle -> IO Name,
        UserData -> BinHandle -> IO FastString
ud_get_fs   :: BinHandle -> IO FastString,

        -- for *serialising* only:
        UserData -> BinHandle -> Name -> IO ()
ud_put_nonbinding_name :: BinHandle -> Name -> IO (),
        -- ^ serialize a non-binding 'Name' (e.g. a reference to another
        -- binding).
        UserData -> BinHandle -> Name -> IO ()
ud_put_binding_name :: BinHandle -> Name -> IO (),
        -- ^ serialize a binding 'Name' (e.g. the name of an IfaceDecl)
        UserData -> BinHandle -> FastString -> IO ()
ud_put_fs   :: BinHandle -> FastString -> IO ()
   }

newReadState :: (BinHandle -> IO Name)   -- ^ how to deserialize 'Name's
             -> (BinHandle -> IO FastString)
             -> UserData
newReadState :: (BinHandle -> IO Name) -> (BinHandle -> IO FastString) -> UserData
newReadState get_name :: BinHandle -> IO Name
get_name get_fs :: BinHandle -> IO FastString
get_fs
  = UserData :: (BinHandle -> IO Name)
-> (BinHandle -> IO FastString)
-> (BinHandle -> Name -> IO ())
-> (BinHandle -> Name -> IO ())
-> (BinHandle -> FastString -> IO ())
-> UserData
UserData { ud_get_name :: BinHandle -> IO Name
ud_get_name = BinHandle -> IO Name
get_name,
               ud_get_fs :: BinHandle -> IO FastString
ud_get_fs   = BinHandle -> IO FastString
get_fs,
               ud_put_nonbinding_name :: BinHandle -> Name -> IO ()
ud_put_nonbinding_name = String -> BinHandle -> Name -> IO ()
forall a. String -> a
undef "put_nonbinding_name",
               ud_put_binding_name :: BinHandle -> Name -> IO ()
ud_put_binding_name    = String -> BinHandle -> Name -> IO ()
forall a. String -> a
undef "put_binding_name",
               ud_put_fs :: BinHandle -> FastString -> IO ()
ud_put_fs   = String -> BinHandle -> FastString -> IO ()
forall a. String -> a
undef "put_fs"
             }

newWriteState :: (BinHandle -> Name -> IO ())
                 -- ^ how to serialize non-binding 'Name's
              -> (BinHandle -> Name -> IO ())
                 -- ^ how to serialize binding 'Name's
              -> (BinHandle -> FastString -> IO ())
              -> UserData
newWriteState :: (BinHandle -> Name -> IO ())
-> (BinHandle -> Name -> IO ())
-> (BinHandle -> FastString -> IO ())
-> UserData
newWriteState put_nonbinding_name :: BinHandle -> Name -> IO ()
put_nonbinding_name put_binding_name :: BinHandle -> Name -> IO ()
put_binding_name put_fs :: BinHandle -> FastString -> IO ()
put_fs
  = UserData :: (BinHandle -> IO Name)
-> (BinHandle -> IO FastString)
-> (BinHandle -> Name -> IO ())
-> (BinHandle -> Name -> IO ())
-> (BinHandle -> FastString -> IO ())
-> UserData
UserData { ud_get_name :: BinHandle -> IO Name
ud_get_name = String -> BinHandle -> IO Name
forall a. String -> a
undef "get_name",
               ud_get_fs :: BinHandle -> IO FastString
ud_get_fs   = String -> BinHandle -> IO FastString
forall a. String -> a
undef "get_fs",
               ud_put_nonbinding_name :: BinHandle -> Name -> IO ()
ud_put_nonbinding_name = BinHandle -> Name -> IO ()
put_nonbinding_name,
               ud_put_binding_name :: BinHandle -> Name -> IO ()
ud_put_binding_name    = BinHandle -> Name -> IO ()
put_binding_name,
               ud_put_fs :: BinHandle -> FastString -> IO ()
ud_put_fs   = BinHandle -> FastString -> IO ()
put_fs
             }

noUserData :: a
noUserData :: a
noUserData = String -> a
forall a. String -> a
undef "UserData"

undef :: String -> a
undef :: String -> a
undef s :: String
s = String -> a
forall a. String -> a
panic ("Binary.UserData: no " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s)

---------------------------------------------------------
-- The Dictionary
---------------------------------------------------------

type Dictionary = Array Int FastString -- The dictionary
                                       -- Should be 0-indexed

putDictionary :: BinHandle -> Int -> UniqFM (Int,FastString) -> IO ()
putDictionary :: BinHandle -> Int -> UniqFM (Int, FastString) -> IO ()
putDictionary bh :: BinHandle
bh sz :: Int
sz dict :: UniqFM (Int, FastString)
dict = do
  BinHandle -> Int -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Int
sz
  (FastString -> IO ()) -> [FastString] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (BinHandle -> FastString -> IO ()
putFS BinHandle
bh) (Array Int FastString -> [FastString]
forall i e. Array i e -> [e]
elems ((Int, Int) -> [(Int, FastString)] -> Array Int FastString
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (0,Int
szInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) (UniqFM (Int, FastString) -> [(Int, FastString)]
forall elt. UniqFM elt -> [elt]
nonDetEltsUFM UniqFM (Int, FastString)
dict)))
    -- It's OK to use nonDetEltsUFM here because the elements have indices
    -- that array uses to create order

getDictionary :: BinHandle -> IO Dictionary
getDictionary :: BinHandle -> IO (Array Int FastString)
getDictionary bh :: BinHandle
bh = do
  Int
sz <- BinHandle -> IO Int
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
  [FastString]
elems <- [IO FastString] -> IO [FastString]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (Int -> [IO FastString] -> [IO FastString]
forall a. Int -> [a] -> [a]
take Int
sz (IO FastString -> [IO FastString]
forall a. a -> [a]
repeat (BinHandle -> IO FastString
getFS BinHandle
bh)))
  Array Int FastString -> IO (Array Int FastString)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int, Int) -> [FastString] -> Array Int FastString
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (0,Int
szInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) [FastString]
elems)

---------------------------------------------------------
-- The Symbol Table
---------------------------------------------------------

-- On disk, the symbol table is an array of IfExtName, when
-- reading it in we turn it into a SymbolTable.

type SymbolTable = Array Int Name

---------------------------------------------------------
-- Reading and writing FastStrings
---------------------------------------------------------

putFS :: BinHandle -> FastString -> IO ()
putFS :: BinHandle -> FastString -> IO ()
putFS bh :: BinHandle
bh fs :: FastString
fs = BinHandle -> ByteString -> IO ()
putBS BinHandle
bh (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ FastString -> ByteString
fastStringToByteString FastString
fs

getFS :: BinHandle -> IO FastString
getFS :: BinHandle -> IO FastString
getFS bh :: BinHandle
bh = do
  Int
l  <- BinHandle -> IO Int
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh :: IO Int
  BinHandle -> Int -> (Ptr Word8 -> IO FastString) -> IO FastString
forall a. BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a
getPrim BinHandle
bh Int
l (\src :: Ptr Word8
src -> FastString -> IO FastString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FastString -> IO FastString) -> FastString -> IO FastString
forall a b. (a -> b) -> a -> b
$! Ptr Word8 -> Int -> FastString
mkFastStringBytes Ptr Word8
src Int
l )

putBS :: BinHandle -> ByteString -> IO ()
putBS :: BinHandle -> ByteString -> IO ()
putBS bh :: BinHandle
bh bs :: ByteString
bs =
  ByteString -> (CStringLen -> IO ()) -> IO ()
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BS.unsafeUseAsCStringLen ByteString
bs ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(ptr :: Ptr CChar
ptr, l :: Int
l) -> do
    BinHandle -> Int -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Int
l
    BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()
putPrim BinHandle
bh Int
l (\op :: Ptr Word8
op -> Ptr Word8 -> Ptr Word8 -> Int -> IO ()
BS.memcpy Ptr Word8
op (Ptr CChar -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
ptr) Int
l)

getBS :: BinHandle -> IO ByteString
getBS :: BinHandle -> IO ByteString
getBS bh :: BinHandle
bh = do
  Int
l <- BinHandle -> IO Int
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh :: IO Int
  Int -> (Ptr Word8 -> IO ()) -> IO ByteString
BS.create Int
l ((Ptr Word8 -> IO ()) -> IO ByteString)
-> (Ptr Word8 -> IO ()) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \dest :: Ptr Word8
dest -> do
    BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()
forall a. BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a
getPrim BinHandle
bh Int
l (\src :: Ptr Word8
src -> Ptr Word8 -> Ptr Word8 -> Int -> IO ()
BS.memcpy Ptr Word8
dest Ptr Word8
src Int
l)

instance Binary ByteString where
  put_ :: BinHandle -> ByteString -> IO ()
put_ bh :: BinHandle
bh f :: ByteString
f = BinHandle -> ByteString -> IO ()
putBS BinHandle
bh ByteString
f
  get :: BinHandle -> IO ByteString
get bh :: BinHandle
bh = BinHandle -> IO ByteString
getBS BinHandle
bh

instance Binary FastString where
  put_ :: BinHandle -> FastString -> IO ()
put_ bh :: BinHandle
bh f :: FastString
f =
    case BinHandle -> UserData
getUserData BinHandle
bh of
        UserData { ud_put_fs :: UserData -> BinHandle -> FastString -> IO ()
ud_put_fs = BinHandle -> FastString -> IO ()
put_fs } -> BinHandle -> FastString -> IO ()
put_fs BinHandle
bh FastString
f

  get :: BinHandle -> IO FastString
get bh :: BinHandle
bh =
    case BinHandle -> UserData
getUserData BinHandle
bh of
        UserData { ud_get_fs :: UserData -> BinHandle -> IO FastString
ud_get_fs = BinHandle -> IO FastString
get_fs } -> BinHandle -> IO FastString
get_fs BinHandle
bh

-- Here to avoid loop
instance Binary LeftOrRight where
   put_ :: BinHandle -> LeftOrRight -> IO ()
put_ bh :: BinHandle
bh CLeft  = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 0
   put_ bh :: BinHandle
bh CRight = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 1

   get :: BinHandle -> IO LeftOrRight
get bh :: BinHandle
bh = do { Word8
h <- BinHandle -> IO Word8
getByte BinHandle
bh
               ; case Word8
h of
                   0 -> LeftOrRight -> IO LeftOrRight
forall (m :: * -> *) a. Monad m => a -> m a
return LeftOrRight
CLeft
                   _ -> LeftOrRight -> IO LeftOrRight
forall (m :: * -> *) a. Monad m => a -> m a
return LeftOrRight
CRight }

instance Binary PromotionFlag where
   put_ :: BinHandle -> PromotionFlag -> IO ()
put_ bh :: BinHandle
bh NotPromoted = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 0
   put_ bh :: BinHandle
bh IsPromoted  = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 1

   get :: BinHandle -> IO PromotionFlag
get bh :: BinHandle
bh = do
       Word8
n <- BinHandle -> IO Word8
getByte BinHandle
bh
       case Word8
n of
         0 -> PromotionFlag -> IO PromotionFlag
forall (m :: * -> *) a. Monad m => a -> m a
return PromotionFlag
NotPromoted
         1 -> PromotionFlag -> IO PromotionFlag
forall (m :: * -> *) a. Monad m => a -> m a
return PromotionFlag
IsPromoted
         _ -> String -> IO PromotionFlag
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Binary(IsPromoted): fail)"

instance Binary Fingerprint where
  put_ :: BinHandle -> Fingerprint -> IO ()
put_ h :: BinHandle
h (Fingerprint w1 :: Word64
w1 w2 :: Word64
w2) = do BinHandle -> Word64 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
h Word64
w1; BinHandle -> Word64 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
h Word64
w2
  get :: BinHandle -> IO Fingerprint
get  h :: BinHandle
h = do Word64
w1 <- BinHandle -> IO Word64
forall a. Binary a => BinHandle -> IO a
get BinHandle
h; Word64
w2 <- BinHandle -> IO Word64
forall a. Binary a => BinHandle -> IO a
get BinHandle
h; Fingerprint -> IO Fingerprint
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64 -> Word64 -> Fingerprint
Fingerprint Word64
w1 Word64
w2)

instance Binary FunctionOrData where
    put_ :: BinHandle -> FunctionOrData -> IO ()
put_ bh :: BinHandle
bh IsFunction = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 0
    put_ bh :: BinHandle
bh IsData     = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 1
    get :: BinHandle -> IO FunctionOrData
get bh :: BinHandle
bh = do
        Word8
h <- BinHandle -> IO Word8
getByte BinHandle
bh
        case Word8
h of
          0 -> FunctionOrData -> IO FunctionOrData
forall (m :: * -> *) a. Monad m => a -> m a
return FunctionOrData
IsFunction
          1 -> FunctionOrData -> IO FunctionOrData
forall (m :: * -> *) a. Monad m => a -> m a
return FunctionOrData
IsData
          _ -> String -> IO FunctionOrData
forall a. String -> a
panic "Binary FunctionOrData"

instance Binary TupleSort where
    put_ :: BinHandle -> TupleSort -> IO ()
put_ bh :: BinHandle
bh BoxedTuple      = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 0
    put_ bh :: BinHandle
bh UnboxedTuple    = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 1
    put_ bh :: BinHandle
bh ConstraintTuple = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 2
    get :: BinHandle -> IO TupleSort
get bh :: BinHandle
bh = do
      Word8
h <- BinHandle -> IO Word8
getByte BinHandle
bh
      case Word8
h of
        0 -> do TupleSort -> IO TupleSort
forall (m :: * -> *) a. Monad m => a -> m a
return TupleSort
BoxedTuple
        1 -> do TupleSort -> IO TupleSort
forall (m :: * -> *) a. Monad m => a -> m a
return TupleSort
UnboxedTuple
        _ -> do TupleSort -> IO TupleSort
forall (m :: * -> *) a. Monad m => a -> m a
return TupleSort
ConstraintTuple

instance Binary Activation where
    put_ :: BinHandle -> Activation -> IO ()
put_ bh :: BinHandle
bh NeverActive = do
            BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 0
    put_ bh :: BinHandle
bh AlwaysActive = do
            BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 1
    put_ bh :: BinHandle
bh (ActiveBefore src :: SourceText
src aa :: Int
aa) = do
            BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 2
            BinHandle -> SourceText -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh SourceText
src
            BinHandle -> Int -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Int
aa
    put_ bh :: BinHandle
bh (ActiveAfter src :: SourceText
src ab :: Int
ab) = do
            BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 3
            BinHandle -> SourceText -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh SourceText
src
            BinHandle -> Int -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Int
ab
    get :: BinHandle -> IO Activation
get bh :: BinHandle
bh = do
            Word8
h <- BinHandle -> IO Word8
getByte BinHandle
bh
            case Word8
h of
              0 -> do Activation -> IO Activation
forall (m :: * -> *) a. Monad m => a -> m a
return Activation
NeverActive
              1 -> do Activation -> IO Activation
forall (m :: * -> *) a. Monad m => a -> m a
return Activation
AlwaysActive
              2 -> do SourceText
src <- BinHandle -> IO SourceText
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                      Int
aa <- BinHandle -> IO Int
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                      Activation -> IO Activation
forall (m :: * -> *) a. Monad m => a -> m a
return (SourceText -> Int -> Activation
ActiveBefore SourceText
src Int
aa)
              _ -> do SourceText
src <- BinHandle -> IO SourceText
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                      Int
ab <- BinHandle -> IO Int
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                      Activation -> IO Activation
forall (m :: * -> *) a. Monad m => a -> m a
return (SourceText -> Int -> Activation
ActiveAfter SourceText
src Int
ab)

instance Binary InlinePragma where
    put_ :: BinHandle -> InlinePragma -> IO ()
put_ bh :: BinHandle
bh (InlinePragma s :: SourceText
s a :: InlineSpec
a b :: Maybe Int
b c :: Activation
c d :: RuleMatchInfo
d) = do
            BinHandle -> SourceText -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh SourceText
s
            BinHandle -> InlineSpec -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh InlineSpec
a
            BinHandle -> Maybe Int -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Maybe Int
b
            BinHandle -> Activation -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Activation
c
            BinHandle -> RuleMatchInfo -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh RuleMatchInfo
d

    get :: BinHandle -> IO InlinePragma
get bh :: BinHandle
bh = do
           SourceText
s <- BinHandle -> IO SourceText
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
           InlineSpec
a <- BinHandle -> IO InlineSpec
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
           Maybe Int
b <- BinHandle -> IO (Maybe Int)
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
           Activation
c <- BinHandle -> IO Activation
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
           RuleMatchInfo
d <- BinHandle -> IO RuleMatchInfo
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
           InlinePragma -> IO InlinePragma
forall (m :: * -> *) a. Monad m => a -> m a
return (SourceText
-> InlineSpec
-> Maybe Int
-> Activation
-> RuleMatchInfo
-> InlinePragma
InlinePragma SourceText
s InlineSpec
a Maybe Int
b Activation
c RuleMatchInfo
d)

instance Binary RuleMatchInfo where
    put_ :: BinHandle -> RuleMatchInfo -> IO ()
put_ bh :: BinHandle
bh FunLike = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 0
    put_ bh :: BinHandle
bh ConLike = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 1
    get :: BinHandle -> IO RuleMatchInfo
get bh :: BinHandle
bh = do
            Word8
h <- BinHandle -> IO Word8
getByte BinHandle
bh
            if Word8
h Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 1 then RuleMatchInfo -> IO RuleMatchInfo
forall (m :: * -> *) a. Monad m => a -> m a
return RuleMatchInfo
ConLike
                      else RuleMatchInfo -> IO RuleMatchInfo
forall (m :: * -> *) a. Monad m => a -> m a
return RuleMatchInfo
FunLike

instance Binary InlineSpec where
    put_ :: BinHandle -> InlineSpec -> IO ()
put_ bh :: BinHandle
bh NoUserInline    = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 0
    put_ bh :: BinHandle
bh Inline          = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 1
    put_ bh :: BinHandle
bh Inlinable       = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 2
    put_ bh :: BinHandle
bh NoInline        = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 3

    get :: BinHandle -> IO InlineSpec
get bh :: BinHandle
bh = do Word8
h <- BinHandle -> IO Word8
getByte BinHandle
bh
                case Word8
h of
                  0 -> InlineSpec -> IO InlineSpec
forall (m :: * -> *) a. Monad m => a -> m a
return InlineSpec
NoUserInline
                  1 -> InlineSpec -> IO InlineSpec
forall (m :: * -> *) a. Monad m => a -> m a
return InlineSpec
Inline
                  2 -> InlineSpec -> IO InlineSpec
forall (m :: * -> *) a. Monad m => a -> m a
return InlineSpec
Inlinable
                  _ -> InlineSpec -> IO InlineSpec
forall (m :: * -> *) a. Monad m => a -> m a
return InlineSpec
NoInline

instance Binary RecFlag where
    put_ :: BinHandle -> RecFlag -> IO ()
put_ bh :: BinHandle
bh Recursive = do
            BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 0
    put_ bh :: BinHandle
bh NonRecursive = do
            BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 1
    get :: BinHandle -> IO RecFlag
get bh :: BinHandle
bh = do
            Word8
h <- BinHandle -> IO Word8
getByte BinHandle
bh
            case Word8
h of
              0 -> do RecFlag -> IO RecFlag
forall (m :: * -> *) a. Monad m => a -> m a
return RecFlag
Recursive
              _ -> do RecFlag -> IO RecFlag
forall (m :: * -> *) a. Monad m => a -> m a
return RecFlag
NonRecursive

instance Binary OverlapMode where
    put_ :: BinHandle -> OverlapMode -> IO ()
put_ bh :: BinHandle
bh (NoOverlap    s :: SourceText
s) = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 0 IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BinHandle -> SourceText -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh SourceText
s
    put_ bh :: BinHandle
bh (Overlaps     s :: SourceText
s) = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 1 IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BinHandle -> SourceText -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh SourceText
s
    put_ bh :: BinHandle
bh (Incoherent   s :: SourceText
s) = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 2 IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BinHandle -> SourceText -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh SourceText
s
    put_ bh :: BinHandle
bh (Overlapping  s :: SourceText
s) = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 3 IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BinHandle -> SourceText -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh SourceText
s
    put_ bh :: BinHandle
bh (Overlappable s :: SourceText
s) = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 4 IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BinHandle -> SourceText -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh SourceText
s
    get :: BinHandle -> IO OverlapMode
get bh :: BinHandle
bh = do
        Word8
h <- BinHandle -> IO Word8
getByte BinHandle
bh
        case Word8
h of
            0 -> (BinHandle -> IO SourceText
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh) IO SourceText -> (SourceText -> IO OverlapMode) -> IO OverlapMode
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \s :: SourceText
s -> OverlapMode -> IO OverlapMode
forall (m :: * -> *) a. Monad m => a -> m a
return (OverlapMode -> IO OverlapMode) -> OverlapMode -> IO OverlapMode
forall a b. (a -> b) -> a -> b
$ SourceText -> OverlapMode
NoOverlap SourceText
s
            1 -> (BinHandle -> IO SourceText
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh) IO SourceText -> (SourceText -> IO OverlapMode) -> IO OverlapMode
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \s :: SourceText
s -> OverlapMode -> IO OverlapMode
forall (m :: * -> *) a. Monad m => a -> m a
return (OverlapMode -> IO OverlapMode) -> OverlapMode -> IO OverlapMode
forall a b. (a -> b) -> a -> b
$ SourceText -> OverlapMode
Overlaps SourceText
s
            2 -> (BinHandle -> IO SourceText
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh) IO SourceText -> (SourceText -> IO OverlapMode) -> IO OverlapMode
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \s :: SourceText
s -> OverlapMode -> IO OverlapMode
forall (m :: * -> *) a. Monad m => a -> m a
return (OverlapMode -> IO OverlapMode) -> OverlapMode -> IO OverlapMode
forall a b. (a -> b) -> a -> b
$ SourceText -> OverlapMode
Incoherent SourceText
s
            3 -> (BinHandle -> IO SourceText
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh) IO SourceText -> (SourceText -> IO OverlapMode) -> IO OverlapMode
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \s :: SourceText
s -> OverlapMode -> IO OverlapMode
forall (m :: * -> *) a. Monad m => a -> m a
return (OverlapMode -> IO OverlapMode) -> OverlapMode -> IO OverlapMode
forall a b. (a -> b) -> a -> b
$ SourceText -> OverlapMode
Overlapping SourceText
s
            4 -> (BinHandle -> IO SourceText
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh) IO SourceText -> (SourceText -> IO OverlapMode) -> IO OverlapMode
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \s :: SourceText
s -> OverlapMode -> IO OverlapMode
forall (m :: * -> *) a. Monad m => a -> m a
return (OverlapMode -> IO OverlapMode) -> OverlapMode -> IO OverlapMode
forall a b. (a -> b) -> a -> b
$ SourceText -> OverlapMode
Overlappable SourceText
s
            _ -> String -> IO OverlapMode
forall a. String -> a
panic ("get OverlapMode" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
h)


instance Binary OverlapFlag where
    put_ :: BinHandle -> OverlapFlag -> IO ()
put_ bh :: BinHandle
bh flag :: OverlapFlag
flag = do BinHandle -> OverlapMode -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (OverlapFlag -> OverlapMode
overlapMode OverlapFlag
flag)
                      BinHandle -> Bool -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (OverlapFlag -> Bool
isSafeOverlap OverlapFlag
flag)
    get :: BinHandle -> IO OverlapFlag
get bh :: BinHandle
bh = do
        OverlapMode
h <- BinHandle -> IO OverlapMode
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        Bool
b <- BinHandle -> IO Bool
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        OverlapFlag -> IO OverlapFlag
forall (m :: * -> *) a. Monad m => a -> m a
return OverlapFlag :: OverlapMode -> Bool -> OverlapFlag
OverlapFlag { overlapMode :: OverlapMode
overlapMode = OverlapMode
h, isSafeOverlap :: Bool
isSafeOverlap = Bool
b }

instance Binary FixityDirection where
    put_ :: BinHandle -> FixityDirection -> IO ()
put_ bh :: BinHandle
bh InfixL = do
            BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 0
    put_ bh :: BinHandle
bh InfixR = do
            BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 1
    put_ bh :: BinHandle
bh InfixN = do
            BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 2
    get :: BinHandle -> IO FixityDirection
get bh :: BinHandle
bh = do
            Word8
h <- BinHandle -> IO Word8
getByte BinHandle
bh
            case Word8
h of
              0 -> do FixityDirection -> IO FixityDirection
forall (m :: * -> *) a. Monad m => a -> m a
return FixityDirection
InfixL
              1 -> do FixityDirection -> IO FixityDirection
forall (m :: * -> *) a. Monad m => a -> m a
return FixityDirection
InfixR
              _ -> do FixityDirection -> IO FixityDirection
forall (m :: * -> *) a. Monad m => a -> m a
return FixityDirection
InfixN

instance Binary Fixity where
    put_ :: BinHandle -> Fixity -> IO ()
put_ bh :: BinHandle
bh (Fixity src :: SourceText
src aa :: Int
aa ab :: FixityDirection
ab) = do
            BinHandle -> SourceText -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh SourceText
src
            BinHandle -> Int -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Int
aa
            BinHandle -> FixityDirection -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh FixityDirection
ab
    get :: BinHandle -> IO Fixity
get bh :: BinHandle
bh = do
          SourceText
src <- BinHandle -> IO SourceText
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
          Int
aa <- BinHandle -> IO Int
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
          FixityDirection
ab <- BinHandle -> IO FixityDirection
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
          Fixity -> IO Fixity
forall (m :: * -> *) a. Monad m => a -> m a
return (SourceText -> Int -> FixityDirection -> Fixity
Fixity SourceText
src Int
aa FixityDirection
ab)

instance Binary WarningTxt where
    put_ :: BinHandle -> WarningTxt -> IO ()
put_ bh :: BinHandle
bh (WarningTxt s :: Located SourceText
s w :: [Located StringLiteral]
w) = do
            BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 0
            BinHandle -> Located SourceText -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Located SourceText
s
            BinHandle -> [Located StringLiteral] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [Located StringLiteral]
w
    put_ bh :: BinHandle
bh (DeprecatedTxt s :: Located SourceText
s d :: [Located StringLiteral]
d) = do
            BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 1
            BinHandle -> Located SourceText -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Located SourceText
s
            BinHandle -> [Located StringLiteral] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [Located StringLiteral]
d

    get :: BinHandle -> IO WarningTxt
get bh :: BinHandle
bh = do
            Word8
h <- BinHandle -> IO Word8
getByte BinHandle
bh
            case Word8
h of
              0 -> do Located SourceText
s <- BinHandle -> IO (Located SourceText)
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                      [Located StringLiteral]
w <- BinHandle -> IO [Located StringLiteral]
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                      WarningTxt -> IO WarningTxt
forall (m :: * -> *) a. Monad m => a -> m a
return (Located SourceText -> [Located StringLiteral] -> WarningTxt
WarningTxt Located SourceText
s [Located StringLiteral]
w)
              _ -> do Located SourceText
s <- BinHandle -> IO (Located SourceText)
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                      [Located StringLiteral]
d <- BinHandle -> IO [Located StringLiteral]
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                      WarningTxt -> IO WarningTxt
forall (m :: * -> *) a. Monad m => a -> m a
return (Located SourceText -> [Located StringLiteral] -> WarningTxt
DeprecatedTxt Located SourceText
s [Located StringLiteral]
d)

instance Binary StringLiteral where
  put_ :: BinHandle -> StringLiteral -> IO ()
put_ bh :: BinHandle
bh (StringLiteral st :: SourceText
st fs :: FastString
fs) = do
            BinHandle -> SourceText -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh SourceText
st
            BinHandle -> FastString -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh FastString
fs
  get :: BinHandle -> IO StringLiteral
get bh :: BinHandle
bh = do
            SourceText
st <- BinHandle -> IO SourceText
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
            FastString
fs <- BinHandle -> IO FastString
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
            StringLiteral -> IO StringLiteral
forall (m :: * -> *) a. Monad m => a -> m a
return (SourceText -> FastString -> StringLiteral
StringLiteral SourceText
st FastString
fs)

instance Binary a => Binary (Located a) where
    put_ :: BinHandle -> Located a -> IO ()
put_ bh :: BinHandle
bh (L l :: SrcSpan
l x :: a
x) = do
            BinHandle -> SrcSpan -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh SrcSpan
l
            BinHandle -> a -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh a
x

    get :: BinHandle -> IO (Located a)
get bh :: BinHandle
bh = do
            SrcSpan
l <- BinHandle -> IO SrcSpan
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
            a
x <- BinHandle -> IO a
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
            Located a -> IO (Located a)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> a -> Located a
forall l e. l -> e -> GenLocated l e
L SrcSpan
l a
x)

instance Binary RealSrcSpan where
  put_ :: BinHandle -> RealSrcSpan -> IO ()
put_ bh :: BinHandle
bh ss :: RealSrcSpan
ss = do
            BinHandle -> FastString -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
ss)
            BinHandle -> Int -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
ss)
            BinHandle -> Int -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
ss)
            BinHandle -> Int -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
ss)
            BinHandle -> Int -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (RealSrcSpan -> Int
srcSpanEndCol RealSrcSpan
ss)

  get :: BinHandle -> IO RealSrcSpan
get bh :: BinHandle
bh = do
            FastString
f <- BinHandle -> IO FastString
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
            Int
sl <- BinHandle -> IO Int
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
            Int
sc <- BinHandle -> IO Int
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
            Int
el <- BinHandle -> IO Int
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
            Int
ec <- BinHandle -> IO Int
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
            RealSrcSpan -> IO RealSrcSpan
forall (m :: * -> *) a. Monad m => a -> m a
return (RealSrcLoc -> RealSrcLoc -> RealSrcSpan
mkRealSrcSpan (FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc FastString
f Int
sl Int
sc)
                                  (FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc FastString
f Int
el Int
ec))

instance Binary SrcSpan where
  put_ :: BinHandle -> SrcSpan -> IO ()
put_ bh :: BinHandle
bh (RealSrcSpan ss :: RealSrcSpan
ss) = do
          BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 0
          BinHandle -> RealSrcSpan -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh RealSrcSpan
ss

  put_ bh :: BinHandle
bh (UnhelpfulSpan s :: FastString
s) = do
          BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 1
          BinHandle -> FastString -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh FastString
s

  get :: BinHandle -> IO SrcSpan
get bh :: BinHandle
bh = do
          Word8
h <- BinHandle -> IO Word8
getByte BinHandle
bh
          case Word8
h of
            0 -> do RealSrcSpan
ss <- BinHandle -> IO RealSrcSpan
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                    SrcSpan -> IO SrcSpan
forall (m :: * -> *) a. Monad m => a -> m a
return (RealSrcSpan -> SrcSpan
RealSrcSpan RealSrcSpan
ss)
            _ -> do FastString
s <- BinHandle -> IO FastString
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                    SrcSpan -> IO SrcSpan
forall (m :: * -> *) a. Monad m => a -> m a
return (FastString -> SrcSpan
UnhelpfulSpan FastString
s)

instance Binary Serialized where
    put_ :: BinHandle -> Serialized -> IO ()
put_ bh :: BinHandle
bh (Serialized the_type :: SomeTypeRep
the_type bytes :: [Word8]
bytes) = do
        BinHandle -> SomeTypeRep -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh SomeTypeRep
the_type
        BinHandle -> [Word8] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [Word8]
bytes
    get :: BinHandle -> IO Serialized
get bh :: BinHandle
bh = do
        SomeTypeRep
the_type <- BinHandle -> IO SomeTypeRep
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        [Word8]
bytes <- BinHandle -> IO [Word8]
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        Serialized -> IO Serialized
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeTypeRep -> [Word8] -> Serialized
Serialized SomeTypeRep
the_type [Word8]
bytes)

instance Binary SourceText where
  put_ :: BinHandle -> SourceText -> IO ()
put_ bh :: BinHandle
bh NoSourceText = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 0
  put_ bh :: BinHandle
bh (SourceText s :: String
s) = do
        BinHandle -> Word8 -> IO ()
putByte BinHandle
bh 1
        BinHandle -> String -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh String
s

  get :: BinHandle -> IO SourceText
get bh :: BinHandle
bh = do
    Word8
h <- BinHandle -> IO Word8
getByte BinHandle
bh
    case Word8
h of
      0 -> SourceText -> IO SourceText
forall (m :: * -> *) a. Monad m => a -> m a
return SourceText
NoSourceText
      1 -> do
        String
s <- BinHandle -> IO String
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        SourceText -> IO SourceText
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> SourceText
SourceText String
s)
      _ -> String -> IO SourceText
forall a. String -> a
panic (String -> IO SourceText) -> String -> IO SourceText
forall a b. (a -> b) -> a -> b
$ "Binary SourceText:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
h