module Extra.TIO
( module Extra.CIO
, TIO
, runTIO
, tryTIO
) where
import Extra.CIO
import Prelude hiding (putStr, putChar, putStrLn)
import Control.Exception
import Control.Monad.RWS
import Control.Monad.Reader
import Control.Monad.Trans
import qualified System.IO as IO
data TState
= TState { cursor :: Position
} deriving Show
data Position
= BOL
| MOL
| EOL
deriving (Show, Eq)
type TIOT = RWST TStyle () TState
type TIO = TIOT IO
runTIO :: TStyle -> TIO a -> IO a
runTIO style action = (runRWST action) style initState >>= \ (a, _, _) -> return a
tryTIO :: TIO a -> TIO (Either Exception a)
tryTIO task =
do state <- get
liftTIO (try' state) task
where
try' state task =
do result <- try task
case result of
Left e -> return (Left e, state, ())
Right (a, s, _) -> return (Right a, s, ())
liftTIO :: (IO (a, TState, ()) -> IO (b, TState, ())) -> TIO a -> TIO b
liftTIO f = mapRWST f
initState :: TState
initState = TState {cursor = BOL}
instance CIO TIO where
hPutStr h s =
do style <- ask
state <- get
case (cursor state, break (== '\n') s) of
(_, ("", "")) -> return ()
(BOL, ("", (_ : b))) -> prefix style >> newline >> hPutStr h b
(MOL, ("", (_ : b))) -> newline >> put (state {cursor = BOL}) >> hPutStr h b
(EOL, ("", (_ : b))) -> newline >> put (state {cursor = BOL}) >> hPutStr h b
(BOL, (a, b)) -> prefix style >> write a >> put (state {cursor = MOL}) >> hPutStr h b
(MOL, (a, b)) -> write a >> hPutStr h b
(EOL, (a, b)) -> newline >> prefix style >> write a >> put (state {cursor = MOL}) >> hPutStr h b
where
prefix style = liftIO (IO.hPutStr IO.stderr (hGetPrefix h style))
newline = liftIO (IO.hPutStr IO.stderr "\n")
write s = liftIO (IO.hPutStr IO.stderr s)
hBOL h =
do state <- get
put (state {cursor = if cursor state == BOL then BOL else EOL})
ev v =
do style <- ask
return (verbosity style v)
setStyle styleFn = local styleFn
tryCIO = tryTIO
_test :: IO ()
_test =
runTIO (defStyle {prefix = "% "})
(putStr "hello\nworld\n" >>
bol >>
putStr "(some text)" >>
putStr "(some more on same line)" >>
bol >>
putStr "(newline)\n\n(after a blank line)" >>
bol)