{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}

-- | This module contains various extra Binary instances, for example ones
-- which are particular GHC or uni-specific.
module Util.BinaryExtras(
   hReadLtd, -- :: HasBinary a IO => Int -> Handle -> IO (WithError a)


   initialClockTime, -- :: ClockTime
      -- static clock time, used in other modules.
   ) where

import System.IO

import Data.IORef
import System.Time

import Util.Binary
import Util.BinaryUtils

import Util.Computation
import Util.ExtendedPrelude
import Util.IOExtras
import Util.BinaryInstances()

-- | Read something, but throw an exception if there is an attempt to
-- read too many characters.
hReadLtd :: HasBinary a IO =>
   Int -- ^ the maximum number of characters
   -> Handle -> IO (WithError a)
hReadLtd :: Int -> Handle -> IO (WithError a)
hReadLtd Int
limit Handle
handle =
   (BreakFn -> IO a) -> IO (WithError a)
forall a. (BreakFn -> IO a) -> IO (WithError a)
addFallOutWE (\ BreakFn
break ->
      do
         IORef Int
lenIORef <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0
         let
            ensure :: Int -> IO ()
            ensure :: Int -> IO ()
ensure Int
i =
               do
                  Int
len1 <- IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
simpleModifyIORef IORef Int
lenIORef
                     (\ Int
len0 ->
                        let
                           len1 :: Int
len1 = Int
len0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i
                        in
                           (Int
len1,Int
len1)
                        )
                  if Int
len1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
limit
                     then
                        String -> IO ()
BreakFn
break String
"BinaryExtras.hReadLtd: limit exceeded"
                     else
                        IO ()
forall (m :: * -> *). Monad m => m ()
done


            (ReadBinary {readByte :: forall (m :: * -> *). ReadBinary m -> m Byte
readByte = IO Byte
readByte1,readBytes :: forall (m :: * -> *). ReadBinary m -> Int -> m Bytes
readBytes = Int -> IO Bytes
readBytes1})
               = Handle -> ReadBinary IO
toReadBinaryHandle Handle
handle

            readByte2 :: IO Byte
readByte2 =
               do
                  Int -> IO ()
ensure Int
1
                  IO Byte
readByte1
            readBytes2 :: Int -> IO Bytes
readBytes2 Int
len =
               do
                  Int -> IO ()
ensure Int
len
                  Int -> IO Bytes
readBytes1 Int
len

            rb2 :: ReadBinary IO
rb2 = ReadBinary :: forall (m :: * -> *). m Byte -> (Int -> m Bytes) -> ReadBinary m
ReadBinary {readByte :: IO Byte
readByte = IO Byte
readByte2,readBytes :: Int -> IO Bytes
readBytes = Int -> IO Bytes
readBytes2}

         ReadBinary IO -> IO a
forall a (m :: * -> *). HasBinary a m => ReadBinary m -> m a
readBin ReadBinary IO
rb2
      )

-- ----------------------------------------------------------------------
-- Instance for ClockTime
-- ----------------------------------------------------------------------


instance Monad m => HasBinary ClockTime m where
   writeBin :: WriteBinary m -> ClockTime -> m ()
writeBin = (ClockTime -> (Integer, Integer))
-> WriteBinary m -> ClockTime -> m ()
forall b (m :: * -> *) a.
HasBinary b m =>
(a -> b) -> WriteBinary m -> a -> m ()
mapWrite (\ (TOD Integer
i Integer
j) -> (Integer
i,Integer
j))
   readBin :: ReadBinary m -> m ClockTime
readBin = ((Integer, Integer) -> ClockTime) -> ReadBinary m -> m ClockTime
forall (m :: * -> *) b a.
(Monad m, HasBinary b m) =>
(b -> a) -> ReadBinary m -> m a
mapRead (\ (Integer
i,Integer
j) -> Integer -> Integer -> ClockTime
TOD Integer
i Integer
j)

-- | Time this code was written.  We bung this definition in here
-- because this module needs GHC-specific access to ClockTime anyway.
initialClockTime :: ClockTime
initialClockTime :: ClockTime
initialClockTime = Integer -> Integer -> ClockTime
TOD Integer
1052391874 Integer
190946000000