{-# LANGUAGE RecordWildCards #-}
{- | Logging infra for the compiler

-}

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Language.Giml.Logging
  ( module Language.Giml.Logging
  , Colog.LogAction
  , MonadBase, liftBase
  )
  where

import Utils
import System.IO
import Control.Monad.Identity
import Control.Monad.Except
import Control.Monad.Reader
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Colog.Core as Colog
import Records.Generic.HasField
import Control.Monad.Base

-- * Logging API

runWithoutLogger :: ExceptT e (ReaderT (CompileInfo Identity) Identity) a -> Either e a
runWithoutLogger :: ExceptT e (ReaderT (CompileInfo Identity) Identity) a -> Either e a
runWithoutLogger =
  Identity (Either e a) -> Either e a
forall a. Identity a -> a
runIdentity (Identity (Either e a) -> Either e a)
-> (ExceptT e (ReaderT (CompileInfo Identity) Identity) a
    -> Identity (Either e a))
-> ExceptT e (ReaderT (CompileInfo Identity) Identity) a
-> Either e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReaderT (CompileInfo Identity) Identity (Either e a)
 -> CompileInfo Identity -> Identity (Either e a))
-> CompileInfo Identity
-> ReaderT (CompileInfo Identity) Identity (Either e a)
-> Identity (Either e a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT (CompileInfo Identity) Identity (Either e a)
-> CompileInfo Identity -> Identity (Either e a)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT CompileInfo Identity
mkCompileInfoPure (ReaderT (CompileInfo Identity) Identity (Either e a)
 -> Identity (Either e a))
-> (ExceptT e (ReaderT (CompileInfo Identity) Identity) a
    -> ReaderT (CompileInfo Identity) Identity (Either e a))
-> ExceptT e (ReaderT (CompileInfo Identity) Identity) a
-> Identity (Either e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT e (ReaderT (CompileInfo Identity) Identity) a
-> ReaderT (CompileInfo Identity) Identity (Either e a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT

runWithoutLoggerEnv :: ExceptT e Identity a -> Either e a
runWithoutLoggerEnv :: ExceptT e Identity a -> Either e a
runWithoutLoggerEnv =
  Identity (Either e a) -> Either e a
forall a. Identity a -> a
runIdentity (Identity (Either e a) -> Either e a)
-> (ExceptT e Identity a -> Identity (Either e a))
-> ExceptT e Identity a
-> Either e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT e Identity a -> Identity (Either e a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT

runIOLogger :: Verbosity -> FilePath -> ExceptT e (ReaderT (CompileInfo IO) IO) a -> IO (Either e a)
runIOLogger :: Verbosity
-> FilePath
-> ExceptT e (ReaderT (CompileInfo IO) IO) a
-> IO (Either e a)
runIOLogger Verbosity
v FilePath
path = (ReaderT (CompileInfo IO) IO (Either e a)
 -> CompileInfo IO -> IO (Either e a))
-> CompileInfo IO
-> ReaderT (CompileInfo IO) IO (Either e a)
-> IO (Either e a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT (CompileInfo IO) IO (Either e a)
-> CompileInfo IO -> IO (Either e a)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Verbosity -> FilePath -> CompileInfo IO
mkCompileInfoIO Verbosity
v FilePath
path) (ReaderT (CompileInfo IO) IO (Either e a) -> IO (Either e a))
-> (ExceptT e (ReaderT (CompileInfo IO) IO) a
    -> ReaderT (CompileInfo IO) IO (Either e a))
-> ExceptT e (ReaderT (CompileInfo IO) IO) a
-> IO (Either e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT e (ReaderT (CompileInfo IO) IO) a
-> ReaderT (CompileInfo IO) IO (Either e a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT

runIOLoggerWithoutLogging :: ExceptT e (ReaderT (CompileInfo IO) IO) a -> IO (Either e a)
runIOLoggerWithoutLogging :: ExceptT e (ReaderT (CompileInfo IO) IO) a -> IO (Either e a)
runIOLoggerWithoutLogging = (ReaderT (CompileInfo IO) IO (Either e a)
 -> CompileInfo IO -> IO (Either e a))
-> CompileInfo IO
-> ReaderT (CompileInfo IO) IO (Either e a)
-> IO (Either e a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT (CompileInfo IO) IO (Either e a)
-> CompileInfo IO -> IO (Either e a)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT CompileInfo IO
mkCompileInfoIONoLogging (ReaderT (CompileInfo IO) IO (Either e a) -> IO (Either e a))
-> (ExceptT e (ReaderT (CompileInfo IO) IO) a
    -> ReaderT (CompileInfo IO) IO (Either e a))
-> ExceptT e (ReaderT (CompileInfo IO) IO) a
-> IO (Either e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT e (ReaderT (CompileInfo IO) IO) a
-> ReaderT (CompileInfo IO) IO (Either e a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT

runIOLoggerWithoutEnv :: ExceptT e IO a -> IO (Either e a)
runIOLoggerWithoutEnv :: ExceptT e IO a -> IO (Either e a)
runIOLoggerWithoutEnv = ExceptT e IO a -> IO (Either e a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT

runLog :: Colog.LogAction m1 LogMsg -> ReaderT (CompileInfo m1) m2 a -> m2 a
runLog :: LogAction m1 LogMsg -> ReaderT (CompileInfo m1) m2 a -> m2 a
runLog = (ReaderT (CompileInfo m1) m2 a -> CompileInfo m1 -> m2 a)
-> CompileInfo m1 -> ReaderT (CompileInfo m1) m2 a -> m2 a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT (CompileInfo m1) m2 a -> CompileInfo m1 -> m2 a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (CompileInfo m1 -> ReaderT (CompileInfo m1) m2 a -> m2 a)
-> (LogAction m1 LogMsg -> CompileInfo m1)
-> LogAction m1 LogMsg
-> ReaderT (CompileInfo m1) m2 a
-> m2 a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogAction m1 LogMsg -> CompileInfo m1
forall (m :: * -> *). LogAction m LogMsg -> CompileInfo m
CompileInfo

withLogAction :: MonadBase b m => Colog.LogAction b LogMsg -> ReaderT (CompileInfo b) m () -> m ()
withLogAction :: LogAction b LogMsg -> ReaderT (CompileInfo b) m () -> m ()
withLogAction LogAction b LogMsg
logact ReaderT (CompileInfo b) m ()
m = ReaderT (CompileInfo b) m () -> CompileInfo b -> m ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (CompileInfo b) m ()
m (LogAction b LogMsg -> CompileInfo b
forall (m :: * -> *). LogAction m LogMsg -> CompileInfo m
CompileInfo LogAction b LogMsg
logact)

warn :: HasLog' LogMsg env b m => Text -> m ()
warn :: Text -> m ()
warn Text
msg = LogMsg -> m ()
forall msg env (b :: * -> *) (m :: * -> *).
HasLog' msg env b m =>
msg -> m ()
logMsg (LogMsg -> m ()) -> LogMsg -> m ()
forall a b. (a -> b) -> a -> b
$ LogMsg
emptyLogMsg
  { _lmVerbosity :: Verbosity
_lmVerbosity = Verbosity
Warning
  , _lmMessage :: Text
_lmMessage = Text
msg
  }

logGeneral :: HasLog' LogMsg env b m => Text -> m ()
logGeneral :: Text -> m ()
logGeneral Text
msg = LogMsg -> m ()
forall msg env (b :: * -> *) (m :: * -> *).
HasLog' msg env b m =>
msg -> m ()
logMsg (LogMsg -> m ()) -> LogMsg -> m ()
forall a b. (a -> b) -> a -> b
$ LogMsg
emptyLogMsg
  { _lmVerbosity :: Verbosity
_lmVerbosity = Verbosity
General
  , _lmMessage :: Text
_lmMessage = Text
msg
  }

logConcise :: HasLog' LogMsg env b m => Text -> m ()
logConcise :: Text -> m ()
logConcise Text
msg = LogMsg -> m ()
forall msg env (b :: * -> *) (m :: * -> *).
HasLog' msg env b m =>
msg -> m ()
logMsg (LogMsg -> m ()) -> LogMsg -> m ()
forall a b. (a -> b) -> a -> b
$ LogMsg
emptyLogMsg
  { _lmVerbosity :: Verbosity
_lmVerbosity = Verbosity
Concise
  , _lmMessage :: Text
_lmMessage = Text
msg
  }

logDetailed :: HasLog' LogMsg env b m => Text -> m ()
logDetailed :: Text -> m ()
logDetailed Text
msg = LogMsg -> m ()
forall msg env (b :: * -> *) (m :: * -> *).
HasLog' msg env b m =>
msg -> m ()
logMsg (LogMsg -> m ()) -> LogMsg -> m ()
forall a b. (a -> b) -> a -> b
$ LogMsg
emptyLogMsg
  { _lmVerbosity :: Verbosity
_lmVerbosity = Verbosity
Detailed
  , _lmMessage :: Text
_lmMessage = Text
msg
  }

setStage :: HasLog' LogMsg env b m => Stage -> m a -> m a
setStage :: Stage -> m a -> m a
setStage Stage
stage = (LogMsg -> LogMsg) -> m a -> m a
forall msg env (b :: * -> *) (m :: * -> *) a.
HasLog' msg env b m =>
(msg -> msg) -> m a -> m a
overLogAction (\LogMsg
msg -> LogMsg
msg { _lmStage :: Stage
_lmStage = Stage
stage })

setRewrite :: HasLog' LogMsg env b m => Text -> m a -> m a
setRewrite :: Text -> m a -> m a
setRewrite Text
rewrite = (LogMsg -> LogMsg) -> m a -> m a
forall msg env (b :: * -> *) (m :: * -> *) a.
HasLog' msg env b m =>
(msg -> msg) -> m a -> m a
overLogAction (\LogMsg
msg -> LogMsg
msg { _lmRewrite :: Text
_lmRewrite = Text
rewrite })

-------

logMsg :: HasLog' msg env b m => msg -> m ()
logMsg :: msg -> m ()
logMsg msg
msg = do
  LogAction b msg
act <- m (LogAction b msg)
forall msg (b :: * -> *) (m :: * -> *).
(HasLog msg b m, MonadBase b m) =>
m (LogAction b msg)
getLogAction
  b () -> m ()
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (b () -> m ()) -> b () -> m ()
forall a b. (a -> b) -> a -> b
$ LogAction b msg -> msg -> b ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
Colog.unLogAction LogAction b msg
act msg
msg

overLogAction :: HasLog' msg env b m => (msg -> msg) -> m a -> m a
overLogAction :: (msg -> msg) -> m a -> m a
overLogAction msg -> msg
f m a
m = do
   LogAction b msg
logact <- m (LogAction b msg)
forall msg (b :: * -> *) (m :: * -> *).
(HasLog msg b m, MonadBase b m) =>
m (LogAction b msg)
getLogAction
   let
     logact' :: LogAction b msg
logact' = (msg -> msg) -> LogAction b msg -> LogAction b msg
forall a b (m :: * -> *).
(a -> b) -> LogAction m b -> LogAction m a
Colog.cmap msg -> msg
f LogAction b msg
logact
   LogAction b msg -> m a -> m a
forall msg (b :: * -> *) (m :: * -> *) a.
(HasLog msg b m, MonadBase b m) =>
LogAction b msg -> m a -> m a
setLogAction LogAction b msg
logact' m a
m

-- ** LogActions

mkCompileInfoPure :: CompileInfo Identity
mkCompileInfoPure :: CompileInfo Identity
mkCompileInfoPure =
  LogAction Identity LogMsg -> CompileInfo Identity
forall (m :: * -> *). LogAction m LogMsg -> CompileInfo m
CompileInfo LogAction Identity LogMsg
noLogging

mkCompileInfoIONoLogging :: CompileInfo IO
mkCompileInfoIONoLogging :: CompileInfo IO
mkCompileInfoIONoLogging =
  LogAction IO LogMsg -> CompileInfo IO
forall (m :: * -> *). LogAction m LogMsg -> CompileInfo m
CompileInfo LogAction IO LogMsg
noLoggingIO

mkCompileInfoIO :: Verbosity -> FilePath -> CompileInfo IO
mkCompileInfoIO :: Verbosity -> FilePath -> CompileInfo IO
mkCompileInfoIO Verbosity
v FilePath
path =
  LogAction IO LogMsg -> CompileInfo IO
forall (m :: * -> *). LogAction m LogMsg -> CompileInfo m
CompileInfo (LogAction IO LogMsg -> CompileInfo IO)
-> LogAction IO LogMsg -> CompileInfo IO
forall a b. (a -> b) -> a -> b
$ (LogMsg -> LogMsg) -> LogAction IO LogMsg -> LogAction IO LogMsg
forall a b (m :: * -> *).
(a -> b) -> LogAction m b -> LogAction m a
Colog.cmap (\LogMsg
msg -> LogMsg
msg { _lmFile :: FilePath
_lmFile = FilePath
path }) (Verbosity -> LogAction IO LogMsg
logStdErr Verbosity
v)

logStdErr :: Verbosity -> Colog.LogAction IO LogMsg
logStdErr :: Verbosity -> LogAction IO LogMsg
logStdErr Verbosity
v = (LogMsg -> IO ()) -> LogAction IO LogMsg
forall (m :: * -> *) msg. (msg -> m ()) -> LogAction m msg
Colog.LogAction ((LogMsg -> IO ()) -> LogAction IO LogMsg)
-> (LogMsg -> IO ()) -> LogAction IO LogMsg
forall a b. (a -> b) -> a -> b
$ \LogMsg{FilePath
Text
Verbosity
Stage
_lmMessage :: Text
_lmVerbosity :: Verbosity
_lmRewrite :: Text
_lmStage :: Stage
_lmFile :: FilePath
_lmFile :: LogMsg -> FilePath
_lmRewrite :: LogMsg -> Text
_lmStage :: LogMsg -> Stage
_lmMessage :: LogMsg -> Text
_lmVerbosity :: LogMsg -> Verbosity
..} ->
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
v Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
_lmVerbosity) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords
      [ Text
"[ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Verbosity -> Text
forall a. Show a => a -> Text
pShow Verbosity
_lmVerbosity Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ]"
      , FilePath -> Text
forall a. Show a => a -> Text
pShow FilePath
_lmFile
      , Stage -> Text
forall a. Show a => a -> Text
pShow Stage
_lmStage Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if Text -> Bool
T.null Text
_lmRewrite then Text
"" else Text
" _ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
_lmRewrite)
      , Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
_lmMessage
      ]
    
noLoggingIO :: Colog.LogAction IO LogMsg
noLoggingIO :: LogAction IO LogMsg
noLoggingIO = (LogMsg -> IO ()) -> LogAction IO LogMsg
forall (m :: * -> *) msg. (msg -> m ()) -> LogAction m msg
Colog.LogAction ((LogMsg -> IO ()) -> LogAction IO LogMsg)
-> (LogMsg -> IO ()) -> LogAction IO LogMsg
forall a b. (a -> b) -> a -> b
$ \LogMsg
_ ->
  () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


noLogging :: Colog.LogAction Identity LogMsg
noLogging :: LogAction Identity LogMsg
noLogging = (LogMsg -> Identity ()) -> LogAction Identity LogMsg
forall (m :: * -> *) msg. (msg -> m ()) -> LogAction m msg
Colog.LogAction ((LogMsg -> Identity ()) -> LogAction Identity LogMsg)
-> (LogMsg -> Identity ()) -> LogAction Identity LogMsg
forall a b. (a -> b) -> a -> b
$ \LogMsg
_ ->
  () -> Identity ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- ** Types

{- | The type of a message we wish to log.

- Stage (pre infer, post infer, etc.)
- Specific rewrite/process (parsing, grouping definitions, elaboration, constraint solving)
- Verbosity level (only constraints generated, each constraint, etc.)
- The message in the log
-}
data LogMsg
  = LogMsg
    { LogMsg -> FilePath
_lmFile :: FilePath
    , LogMsg -> Stage
_lmStage :: Stage
    , LogMsg -> Text
_lmRewrite :: Text
    , LogMsg -> Verbosity
_lmVerbosity :: Verbosity
    , LogMsg -> Text
_lmMessage :: Text
    }
  deriving Int -> LogMsg -> ShowS
[LogMsg] -> ShowS
LogMsg -> FilePath
(Int -> LogMsg -> ShowS)
-> (LogMsg -> FilePath) -> ([LogMsg] -> ShowS) -> Show LogMsg
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [LogMsg] -> ShowS
$cshowList :: [LogMsg] -> ShowS
show :: LogMsg -> FilePath
$cshow :: LogMsg -> FilePath
showsPrec :: Int -> LogMsg -> ShowS
$cshowsPrec :: Int -> LogMsg -> ShowS
Show

-- | Which stage did the message come from
data Stage
  = Parsing
  | PreInfer
  | TypeInference
  | PostInfer
  | Compilation Text
  deriving Int -> Stage -> ShowS
[Stage] -> ShowS
Stage -> FilePath
(Int -> Stage -> ShowS)
-> (Stage -> FilePath) -> ([Stage] -> ShowS) -> Show Stage
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Stage] -> ShowS
$cshowList :: [Stage] -> ShowS
show :: Stage -> FilePath
$cshow :: Stage -> FilePath
showsPrec :: Int -> Stage -> ShowS
$cshowsPrec :: Int -> Stage -> ShowS
Show

-- | Verbose level from least detailed to most detailed
data Verbosity
  = Warning
  | General
  | Concise
  | Detailed
  deriving (Int -> Verbosity -> ShowS
[Verbosity] -> ShowS
Verbosity -> FilePath
(Int -> Verbosity -> ShowS)
-> (Verbosity -> FilePath)
-> ([Verbosity] -> ShowS)
-> Show Verbosity
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Verbosity] -> ShowS
$cshowList :: [Verbosity] -> ShowS
show :: Verbosity -> FilePath
$cshow :: Verbosity -> FilePath
showsPrec :: Int -> Verbosity -> ShowS
$cshowsPrec :: Int -> Verbosity -> ShowS
Show, ReadPrec [Verbosity]
ReadPrec Verbosity
Int -> ReadS Verbosity
ReadS [Verbosity]
(Int -> ReadS Verbosity)
-> ReadS [Verbosity]
-> ReadPrec Verbosity
-> ReadPrec [Verbosity]
-> Read Verbosity
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Verbosity]
$creadListPrec :: ReadPrec [Verbosity]
readPrec :: ReadPrec Verbosity
$creadPrec :: ReadPrec Verbosity
readList :: ReadS [Verbosity]
$creadList :: ReadS [Verbosity]
readsPrec :: Int -> ReadS Verbosity
$creadsPrec :: Int -> ReadS Verbosity
Read, Verbosity -> Verbosity -> Bool
(Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool) -> Eq Verbosity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Verbosity -> Verbosity -> Bool
$c/= :: Verbosity -> Verbosity -> Bool
== :: Verbosity -> Verbosity -> Bool
$c== :: Verbosity -> Verbosity -> Bool
Eq, Eq Verbosity
Eq Verbosity
-> (Verbosity -> Verbosity -> Ordering)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Verbosity)
-> (Verbosity -> Verbosity -> Verbosity)
-> Ord Verbosity
Verbosity -> Verbosity -> Bool
Verbosity -> Verbosity -> Ordering
Verbosity -> Verbosity -> Verbosity
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Verbosity -> Verbosity -> Verbosity
$cmin :: Verbosity -> Verbosity -> Verbosity
max :: Verbosity -> Verbosity -> Verbosity
$cmax :: Verbosity -> Verbosity -> Verbosity
>= :: Verbosity -> Verbosity -> Bool
$c>= :: Verbosity -> Verbosity -> Bool
> :: Verbosity -> Verbosity -> Bool
$c> :: Verbosity -> Verbosity -> Bool
<= :: Verbosity -> Verbosity -> Bool
$c<= :: Verbosity -> Verbosity -> Bool
< :: Verbosity -> Verbosity -> Bool
$c< :: Verbosity -> Verbosity -> Bool
compare :: Verbosity -> Verbosity -> Ordering
$ccompare :: Verbosity -> Verbosity -> Ordering
$cp1Ord :: Eq Verbosity
Ord)

emptyLogMsg :: LogMsg
emptyLogMsg :: LogMsg
emptyLogMsg = LogMsg :: FilePath -> Stage -> Text -> Verbosity -> Text -> LogMsg
LogMsg
    { _lmFile :: FilePath
_lmFile = FilePath
""
    , _lmStage :: Stage
_lmStage = Stage
Parsing
    , _lmRewrite :: Text
_lmRewrite = Text
""
    , _lmVerbosity :: Verbosity
_lmVerbosity = Verbosity
General
    , _lmMessage :: Text
_lmMessage = Text
"Empty message"
    }

type CompilePhase e env b m =
  ( MonadError e m
  , HasLog' LogMsg env b m
  )

type Compile e m =
  ExceptT e (ReaderT (CompileInfo m) m)

data CompileInfo m
  = CompileInfo
    { CompileInfo m -> LogAction m LogMsg
logAction :: Colog.LogAction m LogMsg
    }
  deriving (forall x. CompileInfo m -> Rep (CompileInfo m) x)
-> (forall x. Rep (CompileInfo m) x -> CompileInfo m)
-> Generic (CompileInfo m)
forall x. Rep (CompileInfo m) x -> CompileInfo m
forall x. CompileInfo m -> Rep (CompileInfo m) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (m :: * -> *) x. Rep (CompileInfo m) x -> CompileInfo m
forall (m :: * -> *) x. CompileInfo m -> Rep (CompileInfo m) x
$cto :: forall (m :: * -> *) x. Rep (CompileInfo m) x -> CompileInfo m
$cfrom :: forall (m :: * -> *) x. CompileInfo m -> Rep (CompileInfo m) x
Generic

-- We want to be able to:
-- - Log anywhere in the compiler, should work with different monad stacks
-- for that we need to be able to lift the base monad which holds the logging capabilities
-- into the current monad

-- What I'm trying to say here is:
instance
  -- if @b@ is the base monad of @m@, and
  ( MonadBase b m
  -- @m@ is has some Reader monad capabilities with @env@ as the environment
  , MonadReader env m
  -- and @env@ has the field @logAction@ with this type @Colog.LogAction b msg@
  -- which means "a log action of type msg -> b ()"
  , HasField "logAction" (Colog.LogAction b msg) env
  )
  -- then the monad @m@ has logging capabilities as well
  => HasLog msg b m where
  getLogAction :: m (Colog.LogAction b msg)
  getLogAction :: m (LogAction b msg)
getLogAction = (env -> LogAction b msg) -> m (LogAction b msg)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((env -> LogAction b msg) -> m (LogAction b msg))
-> (env -> LogAction b msg) -> m (LogAction b msg)
forall a b. (a -> b) -> a -> b
$ forall a s. HasField "logAction" a s => s -> a
forall (field :: Symbol) a s. HasField field a s => s -> a
getField @"logAction"
  setLogAction :: Colog.LogAction b msg -> m a -> m a
  setLogAction :: LogAction b msg -> m a -> m a
setLogAction = (env -> env) -> m a -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((env -> env) -> m a -> m a)
-> (LogAction b msg -> env -> env) -> LogAction b msg -> m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. HasField "logAction" a s => a -> s -> s
forall (field :: Symbol) a s. HasField field a s => a -> s -> s
setField @"logAction"

class HasLog msg b m | m -> b where
    getLogAction :: MonadBase b m => m (Colog.LogAction b msg)
    setLogAction :: MonadBase b m => Colog.LogAction b msg -> m a -> m a

type HasLog' msg env b m =
  ( MonadBase b m
  , MonadReader env m
  , HasField "logAction" (Colog.LogAction b msg) env
  , HasLog msg b m
  )