{-# 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 Int -> Bool
p m ()
m = do
    Int
v <- m Int
forall (m :: Type -> Type). MonadVerbosity m => m Int
getVerbosity
    Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Int -> Bool
p Int
v) m ()
m

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

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

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

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


instance (Applicative m, MonadIO m) => MonadVerbosity (ReaderT (Handle, Int) m) where
  getVerbosity :: ReaderT (Handle, Int) m Int
getVerbosity = (Handle, Int) -> Int
forall a b. (a, b) -> b
snd ((Handle, Int) -> Int)
-> ReaderT (Handle, Int) m (Handle, Int)
-> ReaderT (Handle, Int) m Int
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT (Handle, Int) m (Handle, Int)
forall r (m :: Type -> Type). MonadReader r m => m r
ask
  getLogFunction :: ReaderT (Handle, Int) m (Int -> String -> IO ())
getLogFunction  = do
    (Handle
h,Int
v) <- ReaderT (Handle, Int) m (Handle, Int)
forall r (m :: Type -> Type). MonadReader r m => m r
ask
    (Int -> String -> IO ())
-> ReaderT (Handle, Int) m (Int -> String -> IO ())
forall a. a -> ReaderT (Handle, Int) m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Int -> String -> IO ())
 -> ReaderT (Handle, Int) m (Int -> String -> IO ()))
-> (Int -> String -> IO ())
-> ReaderT (Handle, Int) m (Int -> String -> IO ())
forall a b. (a -> b) -> a -> b
$ \Int
n String
msg -> do
      Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
v) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall a. IO a -> IO a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStr Handle
h String
msg
  showWarning :: String -> ReaderT (Handle, Int) m ()
showWarning String
msg = do
    (Handle
h, Int
_) <- ReaderT (Handle, Int) m (Handle, Int)
forall r (m :: Type -> Type). MonadReader r m => m r
ask
    IO () -> ReaderT (Handle, Int) m ()
forall a. IO a -> ReaderT (Handle, Int) m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT (Handle, Int) m ())
-> IO () -> ReaderT (Handle, Int) m ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
h String
msg

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