module Text.Chatty.Channel.Printer (
ChannelPrinter (..),
ArchiverT (..),
IntArchiverT,
BoolArchiverT,
HandleArchiverT,
runArchiverT,
FilterT (..),
IntFilterT,
BoolFilterT,
HandleFilterT
) where
import Control.Arrow
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Text.Chatty.Printer
import System.IO
class (MonadPrinter m,Eq c) => ChannelPrinter c m where
cbracket :: c -> m a -> m a
cbracket c m = cstart c >> m >>= \a -> cfin c >> return a
cstart :: c -> m ()
cfin :: c -> m ()
cprint :: c -> String -> m ()
cprint c s = cbracket c $ mprint s
cthis :: m c
newtype ArchiverT c m a = Archiver { runArchiverT' :: ([(c,[String])],[c]) -> m (a,([(c,[String])],[c])) }
instance Monad m => Monad (ArchiverT c m) where
return a = Archiver $ \s -> return (a,s)
(Archiver r) >>= f = Archiver $ \s -> do (a,s') <- r s; runArchiverT' (f a) s'
instance MonadTrans (ArchiverT c) where
lift m = Archiver $ \s -> do a <- m; return (a,s)
instance MonadIO m => MonadIO (ArchiverT c m) where
liftIO = lift . liftIO
instance Monad m => Functor (ArchiverT c m) where
fmap f a = liftM f a
withAssoc :: Eq b => b -> a -> (a -> a) -> [(b,a)] -> [(b,a)]
withAssoc k n f [] = [(k,f n)]
withAssoc k n f ((p,a):ps)
| p == k = (p,f a) : ps
| otherwise = (p,a) : withAssoc k n f ps
instance (Eq c,Monad m) => MonadPrinter (ArchiverT c m) where
mprint s = Archiver $ \(r,c:cx) -> return ((),(withAssoc c [] (s:) r,c:cx))
instance (Eq c,Monad m) => ChannelPrinter c (ArchiverT c m) where
cbracket c m = Archiver $ \(r,c1) -> do
(a,(r',_)) <- runArchiverT' m (r,c:c1)
return (a,(r',c1))
cstart c = Archiver $ \(r,c1) -> return ((),(r,c:c1))
cfin _ = Archiver $ \(r,_:cx) -> return ((),(r,cx))
cprint c s = Archiver $ \(r,c1) -> return ((),(withAssoc c [] (s:) r,c1))
cthis = Archiver $ \(r,c) -> return (head c,(r,c))
runArchiverT :: (Eq c,Monad m) => c -> ArchiverT c m a -> m (a,[(c,Replayable)])
runArchiverT c = liftM (second $ map (second Replayable) . fst) . flip runArchiverT' ([],[c])
type IntArchiverT = ArchiverT Int
type BoolArchiverT = ArchiverT Bool
type HandleArchiverT = ArchiverT Handle
newtype FilterT c m a = Filter { runFilterT :: (c,[c]) -> m (a,[c]) }
instance Monad m => Monad (FilterT c m) where
return a = Filter $ \(c,s) -> return (a,s)
(Filter g) >>= f = Filter $ \(c,s) -> do (a,s') <- g (c,s); runFilterT (f a) (c,s')
instance MonadTrans (FilterT c) where
lift m = Filter $ \(c,s) -> do a <- m; return (a,s)
instance MonadIO m => MonadIO (FilterT c m) where
liftIO = lift . liftIO
instance Monad m => Functor (FilterT c m) where
fmap f a = liftM f a
instance (Eq c,MonadPrinter m) => MonadPrinter (FilterT c m) where
mprint str = Filter $ \(c,c1:cx) -> if c == c1 then mprint str >> return ((),c1:cx) else return ((),c1:cx)
instance (Eq c,MonadPrinter m) => ChannelPrinter c (FilterT c m) where
cbracket c m = Filter $ \(cf,cx) -> do
(a,_) <- runFilterT m (cf,c:cx)
return (a,cx)
cstart c = Filter $ \(cf,cx) -> return ((),c:cx)
cfin _ = Filter $ \(cf,_:cx) -> return ((),cx)
cprint c s = Filter $ \(cf,cx) -> if c == cf then mprint s >> return ((),cx) else return ((),cx)
cthis = Filter $ \(cf,cx) -> return (head cx,cx)
type IntFilterT = FilterT Int
type BoolFilterT = FilterT Bool
type HandleFilterT = FilterT Handle