{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ExistentialQuantification #-}
module Util.BinaryUtils(
mapWrite,
mapRead,
mapWriteIO,
mapReadIO,
ArgMonad,
mkArgMonad,
toArgMonad,
runArgMonad,
writeBinaryToArgMonad,
readBinaryToArgMonad,
WrappedBinary(..),
hWriteWrappedBinary,
WrapBinary(..),
) where
import System.IO(Handle)
import Control.Applicative
import Control.Monad.Fail
import Control.Monad.Trans
import Util.Binary
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)
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)
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
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)
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)
data WrappedBinary =
forall v . HasBinary v IO => WrappedBinary v
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
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"