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

-- | Various functions for declaring new instances of Binary for types.
module Util.BinaryUtils(
   mapWrite, -- :: HasBinary b m => (a -> b) -> (WriteBinary m -> a -> m ())
   mapRead, -- :: (Monad m,HasBinary b m) => (b -> a) -> (ReadBinary m -> m a)
   mapWriteIO,
      -- :: (HasBinary b m,MonadIO m)
      -- => (a -> IO b) -> (WriteBinary m -> a -> m ())
   mapReadIO,
      -- :: (HasBinary b m,MonadIO m)
      -- => (b -> IO a) -> (ReadBinary m -> m a)

   ArgMonad,
      -- A type for encoding a monadic action which requires an
      -- extra argument (of type "arg").
      --    ArgMonad arg m
      -- is an instance of Monad (and Functor), if m is.
      --
      -- ArgMonad is intended as a way of writing instances of Binary which
      -- require a bit of context.  Thus you would write something like
      --
      -- instance Monad m => HasBinary MyType1 (ArgMonad context m) where
      --    writeBinary wb (MyType1 v1 v2) = mkArgMonad
      --       (\ context ->
      --           do
      --              runArgMonad context (writeBinary rb v1)
      --                 -- this is something which is automatically
      --                 -- an instance of HasBinary for (ArgMonad context m)
      --                 -- like the standard types.
      --              runArgMonad context (writeBinary rb (f v2 context))
      --                 -- this is something which needs to be changed by
      --                 -- f, using context, to give a suitable instance.
      --           )
      --  (and likewise for readBinary).
      --
      --
      -- Then if you want to encode MyType2, containing MyType1, and providing
      -- this context, you could write
      --
      -- instance Monad m => HasBinary MyType2 m where
      --    writeBinary wb (MyType2 v3 v4) =
      --       do
      --          context <- ...
      --          writeBinary wb v3 -- encoding v3 doesn't need context
      --          runArgMonad context
      --             (writeBinary (writeBinaryToArgMonad wb) v4)
      --             -- encoding v4 does need context.
   mkArgMonad, -- :: (arg -> m a) -> ArgMonad arg m a
   toArgMonad, -- :: m a -> ArgMonad arg m a
   runArgMonad, -- :: arg -> ArgMonad arg m a -> m a

   writeBinaryToArgMonad, -- :: WriteBinary m -> WriteBinary (ArgMonad arg m)
   readBinaryToArgMonad, -- :: ReadBinary m -> ReadBinary (ArgMonad arg m)


   WrappedBinary(..),
      -- a wrapper for instances of HasBinary _ IO.
   hWriteWrappedBinary, -- :: Handle -> WrappedBinary -> IO ()

   WrapBinary(..),
      -- more general wrapped for any monad.
   ) where

import System.IO(Handle)

-- GHC imports
import Control.Applicative
import Control.Monad.Fail
import Control.Monad.Trans

-- our imports
import Util.Binary

-- ----------------------------------------------------------------------
-- Mapping HasBinary instances
-- ----------------------------------------------------------------------

-- | Given a function which converts an (a) to something we can already
-- convert to binary, return a 'writeBin' function to be used in
-- instances of 'HasBinary' (a).
mapWrite :: HasBinary b m => (a -> b) -> (WriteBinary m -> a -> m ())
mapWrite :: (a -> b) -> WriteBinary m -> a -> m ()
mapWrite  a -> b
fn WriteBinary m
wb a
a = WriteBinary m -> b -> m ()
forall a (m :: * -> *). HasBinary a m => WriteBinary m -> a -> m ()
writeBin WriteBinary m
wb (a -> b
fn a
a)

-- | Given a function which converts something we can already read from
-- binary to (a), return a 'readBin' function to be used in instances
-- of 'HasBinary' (a).
mapRead :: (Monad m,HasBinary b m) => (b -> a) -> (ReadBinary m -> m a)
mapRead :: (b -> a) -> ReadBinary m -> m a
mapRead b -> a
fn ReadBinary m
rb =
   do
      b
b <- ReadBinary m -> m b
forall a (m :: * -> *). HasBinary a m => ReadBinary m -> m a
readBin ReadBinary m
rb
      a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> a
fn b
b)

-- | Like 'mapWrite', but the conversion function is also allowed to use
-- 'IO'.
mapWriteIO :: (HasBinary b m,MonadIO m)
   => (a -> IO b) -> (WriteBinary m -> a -> m ())
mapWriteIO :: (a -> IO b) -> WriteBinary m -> a -> m ()
mapWriteIO a -> IO b
fn WriteBinary m
wb a
a =
   do
      b
b <- IO b -> m b
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (a -> IO b
fn a
a)
      WriteBinary m -> b -> m ()
forall a (m :: * -> *). HasBinary a m => WriteBinary m -> a -> m ()
writeBin WriteBinary m
wb b
b

-- | LIke 'mapRead', but the conversion function is also allowed to use
-- 'IO'.
mapReadIO :: (HasBinary b m,MonadIO m)
   => (b -> IO a) -> (ReadBinary m -> m a)
mapReadIO :: (b -> IO a) -> ReadBinary m -> m a
mapReadIO b -> IO a
fn ReadBinary m
rb =
   do
      b
b <- ReadBinary m -> m b
forall a (m :: * -> *). HasBinary a m => ReadBinary m -> m a
readBin ReadBinary m
rb
      IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (b -> IO a
fn b
b)


-- ----------------------------------------------------------------------
-- Creating HasBinary instances that need extra information about their
-- context
-- ----------------------------------------------------------------------

-- | A monad which hides an additional value which the 'HasBinary'
-- instances should be able to get at.  This is used, for example,
-- by "CodedValue", to make the 'View' available to instances.
newtype ArgMonad arg m a = ArgMonad (arg -> m a)

mkArgMonad :: (arg -> m a) -> ArgMonad arg m a
mkArgMonad :: (arg -> m a) -> ArgMonad arg m a
mkArgMonad = (arg -> m a) -> ArgMonad arg m a
forall arg (m :: * -> *) a. (arg -> m a) -> ArgMonad arg m a
ArgMonad

toArgMonad :: m a -> ArgMonad arg m a
toArgMonad :: m a -> ArgMonad arg m a
toArgMonad m a
act = (arg -> m a) -> ArgMonad arg m a
forall arg (m :: * -> *) a. (arg -> m a) -> ArgMonad arg m a
ArgMonad (m a -> arg -> m a
forall a b. a -> b -> a
const m a
act)

writeBinaryToArgMonad :: WriteBinary m -> WriteBinary (ArgMonad arg m)
writeBinaryToArgMonad :: WriteBinary m -> WriteBinary (ArgMonad arg m)
writeBinaryToArgMonad = (forall a. m a -> ArgMonad arg m a)
-> WriteBinary m -> WriteBinary (ArgMonad arg m)
forall (m :: * -> *) (n :: * -> *).
(forall a. m a -> n a) -> WriteBinary m -> WriteBinary n
liftWriteBinary forall a. m a -> ArgMonad arg m a
forall (m :: * -> *) a arg. m a -> ArgMonad arg m a
toArgMonad

readBinaryToArgMonad :: ReadBinary m -> ReadBinary (ArgMonad arg m)
readBinaryToArgMonad :: ReadBinary m -> ReadBinary (ArgMonad arg m)
readBinaryToArgMonad = (forall a. m a -> ArgMonad arg m a)
-> ReadBinary m -> ReadBinary (ArgMonad arg m)
forall (m :: * -> *) (n :: * -> *).
(forall a. m a -> n a) -> ReadBinary m -> ReadBinary n
liftReadBinary forall a. m a -> ArgMonad arg m a
forall (m :: * -> *) a arg. m a -> ArgMonad arg m a
toArgMonad

runArgMonad :: arg -> ArgMonad arg m a -> m a
runArgMonad :: arg -> ArgMonad arg m a -> m a
runArgMonad arg
arg (ArgMonad arg -> m a
fn) = arg -> m a
fn arg
arg

instance Functor m => Functor (ArgMonad arg m) where
   fmap :: (a -> b) -> ArgMonad arg m a -> ArgMonad arg m b
fmap a -> b
mapFn (ArgMonad arg -> m a
fn) =
      let
         fn2 :: arg -> m b
fn2 arg
arg = (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
mapFn (arg -> m a
fn arg
arg)
      in
         (arg -> m b) -> ArgMonad arg m b
forall arg (m :: * -> *) a. (arg -> m a) -> ArgMonad arg m a
ArgMonad arg -> m b
fn2

instance Applicative m => Applicative (ArgMonad arg m) where
   pure :: a -> ArgMonad arg m a
pure a
v = (arg -> m a) -> ArgMonad arg m a
forall arg (m :: * -> *) a. (arg -> m a) -> ArgMonad arg m a
ArgMonad (m a -> arg -> m a
forall a b. a -> b -> a
const (a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v))
   ArgMonad arg -> m (a -> b)
fn1 <*> :: ArgMonad arg m (a -> b) -> ArgMonad arg m a -> ArgMonad arg m b
<*> ArgMonad arg -> m a
fn2 =
      let
         fn :: arg -> m b
fn arg
arg = arg -> m (a -> b)
fn1 arg
arg m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> arg -> m a
fn2 arg
arg
      in
         (arg -> m b) -> ArgMonad arg m b
forall arg (m :: * -> *) a. (arg -> m a) -> ArgMonad arg m a
ArgMonad arg -> m b
fn

instance Monad m => Monad (ArgMonad arg m) where
   >>= :: ArgMonad arg m a -> (a -> ArgMonad arg m b) -> ArgMonad arg m b
(>>=) (ArgMonad arg -> m a
fn1) a -> ArgMonad arg m b
getArgMonad =
      let
         fn :: arg -> m b
fn arg
arg =
            do
               a
v1 <- arg -> m a
fn1 arg
arg
               let
                  (ArgMonad arg -> m b
fn2) = a -> ArgMonad arg m b
getArgMonad a
v1
               arg -> m b
fn2 arg
arg
      in
         (arg -> m b) -> ArgMonad arg m b
forall arg (m :: * -> *) a. (arg -> m a) -> ArgMonad arg m a
ArgMonad arg -> m b
fn

   return :: a -> ArgMonad arg m a
return a
v = (arg -> m a) -> ArgMonad arg m a
forall arg (m :: * -> *) a. (arg -> m a) -> ArgMonad arg m a
ArgMonad (m a -> arg -> m a
forall a b. a -> b -> a
const (a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v))

instance MonadFail m => MonadFail (ArgMonad arg m) where
   fail :: String -> ArgMonad arg m a
fail String
s = (arg -> m a) -> ArgMonad arg m a
forall arg (m :: * -> *) a. (arg -> m a) -> ArgMonad arg m a
ArgMonad (m a -> arg -> m a
forall a b. a -> b -> a
const (String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Control.Monad.Fail.fail String
s))

instance MonadIO m => MonadIO (ArgMonad arg m) where
   liftIO :: IO a -> ArgMonad arg m a
liftIO IO a
act = (arg -> m a) -> ArgMonad arg m a
forall arg (m :: * -> *) a. (arg -> m a) -> ArgMonad arg m a
ArgMonad (\ arg
arg -> IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
act)

-- ----------------------------------------------------------------------
-- A wrapper for instances of Binary.  This can be written, but not
-- read (since we wouldn't know what type to decode).
-- ----------------------------------------------------------------------

-- | A wrapper for instances of Binary.  This can be written, but not
-- read (since we wouldn't know what type to decode).
data WrappedBinary =
   forall v . HasBinary v IO => WrappedBinary v

-- | Write a 'WrappedBinary'
hWriteWrappedBinary :: Handle -> WrappedBinary -> IO ()
hWriteWrappedBinary :: Handle -> WrappedBinary -> IO ()
hWriteWrappedBinary Handle
handle (WrappedBinary v
v) = Handle -> v -> IO ()
forall a. HasBinary a IO => Handle -> a -> IO ()
hWrite Handle
handle v
v


-- ----------------------------------------------------------------------
-- More generally we provide a wrapped type for each monad, and a way
-- of writing it.  Of course we have to leave the method for reading it
-- undefined
-- ----------------------------------------------------------------------

data WrapBinary m = forall v . HasBinary v m => WrapBinary v

instance HasBinary (WrapBinary m) m where
   writeBin :: WriteBinary m -> WrapBinary m -> m ()
writeBin WriteBinary m
wb (WrapBinary v
v) = WriteBinary m -> v -> m ()
forall a (m :: * -> *). HasBinary a m => WriteBinary m -> a -> m ()
writeBin WriteBinary m
wb v
v

   readBin :: ReadBinary m -> m (WrapBinary m)
readBin = String -> ReadBinary m -> m (WrapBinary m)
forall a. HasCallStack => String -> a
error String
"BinaryUtils: can't read a general wrapped binary type"