hsenv-0.5: src/HsenvMonad.hs

{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables #-}
module HsenvMonad ( Hsenv
                  , runHsenv
                  , indentMessages
                  , debug
                  , info
                  , trace
                  , warning
                  , finally
                  , throwError
                  , catchError
                  , ask
                  , asks
                  , gets
                  , tell
                  , modify
                  , liftIO
                  ) where

import Types

import Control.Exception as Exception (IOException, catch)
import Control.Applicative
import Control.Monad.Trans (MonadIO, liftIO)
import Control.Monad.Reader (ReaderT, MonadReader, runReaderT, asks, ask)
import Control.Monad.Writer (WriterT, MonadWriter, runWriterT, tell)
import Control.Monad.State (StateT, MonadState, evalStateT, modify, gets)
import Control.Monad.Error (ErrorT, MonadError, runErrorT, throwError, catchError)
import Control.Monad (when)
import System.IO (stderr, hPutStrLn)

import Prelude hiding (log)

newtype Hsenv a = Hsenv (StateT HsenvState (ReaderT Options (ErrorT HsenvException (WriterT [String] IO))) a)
    deriving (Functor, Applicative, Monad, MonadReader Options, MonadState HsenvState, MonadError HsenvException, MonadWriter [String])

instance MonadIO Hsenv where
    liftIO m = Hsenv $ do
                 x <- liftIO $ (Right `fmap` m) `Exception.catch` \(e :: IOException) -> return $ Left e
                 case x of
                   Left e  -> throwError $ HsenvException $ "IO error: " ++ show e
                   Right y -> return y

runHsenv :: Hsenv a -> Options -> IO (Either HsenvException a, [String])
runHsenv (Hsenv m) = runWriterT . runErrorT . runReaderT (evalStateT m (HsenvState 0))

finally :: Hsenv a -> Hsenv b -> Hsenv a
finally m sequel = do
  result <- (Right `fmap` m) `catchError` (return . Left)
  _ <- sequel
  case result of
    Left e  -> throwError e
    Right x -> return x

indentMessages :: Hsenv a -> Hsenv a
indentMessages m = do
  modify (\s -> s{logDepth = logDepth s + 2})
  result <- m
  modify (\s -> s{logDepth = logDepth s - 2})
  return result

-- add message to private log and return adjusted message (with log depth)
-- that can be printed somewhere else
privateLog :: String -> Hsenv String
privateLog str = do
  depth <- gets logDepth
  let text = replicate (fromInteger depth) ' ' ++ str
  tell [text]
  return text

log :: Verbosity -> String -> Hsenv ()
log minLevel str = do
  text <- privateLog str
  flag <- asks verbosity
  when (flag >= minLevel) $
    liftIO $ putStrLn text

debug :: String -> Hsenv ()
debug = log Verbose

info :: String -> Hsenv ()
info = log Quiet

trace :: String -> Hsenv ()
trace = log VeryVerbose

warning :: String -> Hsenv ()
warning str = do
  text <- privateLog str
  liftIO $ hPutStrLn stderr text