module Text.Chatty.Printer where
import Control.Applicative
import Control.Arrow
import Control.Monad
import Control.Monad.State
import Control.Monad.Identity
import Control.Monad.Writer
import System.IO
class Monad m => ChPrinter m where
mprint :: String -> m ()
mnoecho :: String -> m ()
mnoecho = mprint
mflush :: m ()
mflush = return ()
mnomask :: String -> m ()
mnomask = mprint
instance ChPrinter IO where
mprint = putStr
mnoecho _ = return ()
mflush = hFlush stdout
newtype DeafT m a = Deaf { runDeafT :: m a }
instance Monad m => Monad (DeafT m) where
return = Deaf . return
(Deaf d) >>= f = Deaf $ do d' <- d; runDeafT (f d')
instance MonadTrans DeafT where
lift = Deaf
instance (Functor m, Monad m) => Applicative (DeafT m) where
pure = return
(<*>) = ap
instance Functor m => Functor (DeafT m) where
fmap f (Deaf a) = Deaf $ fmap f a
instance MonadIO m => MonadIO (DeafT m) where
liftIO = lift . liftIO
instance Monad m => ChPrinter (DeafT m) where
mprint _ = return ()
newtype OutRedirT m a = OutRedir { runOutRedirT :: Handle -> m a }
type OutRedir = OutRedirT IO
instance Monad m => Monad (OutRedirT m) where
return a = OutRedir $ \h -> return a
(OutRedir r) >>= f = OutRedir $ \h -> do a <- r h; runOutRedirT (f a) h
instance MonadTrans OutRedirT where
lift m = OutRedir $ \h -> m
instance MonadIO m => MonadIO (OutRedirT m) where
liftIO = lift . liftIO
instance MonadIO m => ChPrinter (OutRedirT m) where
mprint s = OutRedir $ \h -> do liftIO $ hPutStr h s; return ()
mflush = OutRedir $ \h -> do liftIO $ hFlush h; return ()
instance Monad m => Functor (OutRedirT m) where
fmap f a = OutRedir $ \h -> do a' <- runOutRedirT a h; return (f a')
instance Monad m => Applicative (OutRedirT m) where
pure = return
(<*>) = ap
runOutRedir :: OutRedir a -> Handle -> IO a
runOutRedir = runOutRedirT
runOutRedirFT :: (Functor m,MonadIO m) => OutRedirT m a -> FilePath -> IOMode -> m a
runOutRedirFT m fp md
| md `elem` [AppendMode,WriteMode] = do
h <- liftIO $ openFile fp md
a <- runOutRedirT m h
liftIO $ hClose h
return a
| otherwise = error "runOutRedirFT does only accept AppendMode or WriteMode."
runOutRedirF :: OutRedir a -> FilePath -> IOMode -> IO a
runOutRedirF = runOutRedirFT
newtype RecorderT m a = Recorder { runRecorderT' :: m (a,[String]) }
type Recorder = RecorderT Identity
instance Monad m => Monad (RecorderT m) where
return a = Recorder $ return (a,[])
(Recorder r) >>= f = Recorder $ do
(a,s) <- r
(a',s') <- runRecorderT' (f a)
return (a', s'++s)
instance MonadTrans RecorderT where
lift m = Recorder $ do a <- m; return (a,[])
instance Monad m => ChPrinter (RecorderT m) where
mprint s = Recorder $ return ((),[s])
instance Monad m => Functor (RecorderT m) where
fmap = liftM
instance Monad m => Applicative (RecorderT m) where
(<*>) = ap
pure = return
instance MonadIO m => MonadIO (RecorderT m) where
liftIO = lift . liftIO
newtype Replayable = Replayable [String]
instance Show Replayable where
show r = show ((\(Replayable x) -> length x) r) ++ ":" ++ show (replay r)
replay :: Replayable -> String
replay (Replayable r) = concat $ reverse r
runRecorder :: Recorder a -> (a,Replayable)
runRecorder = second Replayable . runIdentity . runRecorderT'
runRecorderT :: (Functor m,Monad m) => RecorderT m a -> m (a,Replayable)
runRecorderT = fmap (second Replayable) . runRecorderT'
mprintLn :: ChPrinter m => String -> m ()
mprintLn = mprint . (++"\n")
mnomaskLn :: ChPrinter m => String -> m ()
mnomaskLn = mnomask . (++"\n")
data DiscardO = DiscardO
data RecordO = RecordO
class RedirectionTarget t mt a r | t -> mt, t a -> r where
(.>.) :: (Functor m,MonadIO m,ChPrinter (mt m)) => mt m a -> t -> m r
(.>>.) :: (Functor m,MonadIO m,ChPrinter (mt m)) => mt m a -> t -> m r
(.>>.) = (.>.)
instance RedirectionTarget DiscardO DeafT a a where
m .>. _ = runDeafT m
instance RedirectionTarget RecordO RecorderT a (a,Replayable) where
m .>. _ = runRecorderT m
instance RedirectionTarget FilePath OutRedirT a a where
m .>. fp = runOutRedirFT m fp WriteMode
m .>>. fp = runOutRedirFT m fp AppendMode
instance RedirectionTarget Handle OutRedirT a a where
m .>. fp = runOutRedirT m fp