MonadVerbosity.hs

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleInstances #-}

------------------------------------------------------------------------
-- |
-- Module           : Lang.Crucible.Utils.MonadVerbosity
-- Description      : A typeclass for monads equipped with a logging function
-- Copyright        : (c) Galois, Inc 2014
-- License          : BSD3
-- Maintainer       : Joe Hendrix <jhendrix@galois.com>
-- Stability        : provisional
------------------------------------------------------------------------
{-# LANGUAGE CPP #-}
module Lang.Crucible.Utils.MonadVerbosity
  ( MonadVerbosity(..)
  , withVerbosity
  ) where

import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader
import System.IO

-- | This class applies to monads that contain verbosity information,
--   which is used to control the level of debugging messages
--   presented to the user.
class (Applicative m, MonadIO m) => MonadVerbosity m where
  getVerbosity :: m Int

  whenVerbosity :: (Int -> Bool) -> m () -> m ()
  whenVerbosity p m = do
    v <- getVerbosity
    when (p v) m

  getLogFunction :: m (Int -> String -> IO ())

  -- Get function for writing a line of output.
  getLogLnFunction :: m (Int -> String -> IO ())
  getLogLnFunction = do
    w <- getLogFunction
    return (\n s -> w n (s ++ "\n"))

  -- | Print a message.
  showWarning :: String -> m ()

  -- | Print a warning message when verbosity satisfies predicate.
  showWarningWhen :: (Int -> Bool) -> String -> m ()
  showWarningWhen p m = whenVerbosity p $ showWarning m


instance (Applicative m, MonadIO m) => MonadVerbosity (ReaderT (Handle, Int) m) where
  getVerbosity = snd <$> ask
  getLogFunction  = do
    (h,v) <- ask
    return $ \n msg -> do
      when (n < v) $ liftIO $ hPutStr h msg
  showWarning msg = do
    (h, _) <- ask
    liftIO $ hPutStrLn h msg

withVerbosity :: Handle
              -> Int
              -> (forall m. MonadVerbosity m => m a)
              -> IO a
withVerbosity h v f = runReaderT f (h,v)