70 lines
2.3 KiB
Haskell
70 lines
2.3 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE InstanceSigs #-}
|
|
{-# LANGUAGE DerivingStrategies #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE Rank2Types #-}
|
|
module Environment(Env (..), EnvM, runEnvM, myLogAction,defaultEnv) where
|
|
|
|
import Prelude hiding (log)
|
|
import Colog
|
|
import Control.Monad.Reader (ReaderT (..), MonadReader)
|
|
import Control.Monad.Trans
|
|
import Control.Monad.IO.Unlift
|
|
import Control.Concurrent.MVar (MVar,modifyMVar_,newMVar)
|
|
import System.IO.Unsafe(unsafePerformIO)
|
|
import qualified Control.Concurrent.MVar as M
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.IO as T
|
|
|
|
newtype Env m = Env {logAction :: LogAction m Message}
|
|
|
|
defaultEnv :: Env EnvM
|
|
defaultEnv = Env myLogAction
|
|
|
|
instance HasLog (Env EnvM) Message EnvM where
|
|
getLogAction :: Env EnvM -> LogAction EnvM Message
|
|
getLogAction = logAction
|
|
{-# INLINE getLogAction #-}
|
|
setLogAction ::LogAction EnvM Message -> Env EnvM -> Env EnvM
|
|
setLogAction lact env = env {logAction = lact}
|
|
{-# INLINE setLogAction #-}
|
|
|
|
-- instead of hardcoding IO we could be parametric over a Monad
|
|
-- but I don't see any use in that as we don't write a lib
|
|
newtype EnvM a = EnvM {unEnvM :: ReaderT (Env EnvM) IO a }
|
|
deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader (Env EnvM))
|
|
|
|
instance MonadUnliftIO EnvM where
|
|
withRunInIO :: ((forall a .EnvM a -> IO a) -> IO b) -> EnvM b
|
|
withRunInIO inner = EnvM $ withRunInIO (\fromReader -> inner (fromReader . unEnvM))
|
|
{-# INLINE withRunInIO #-}
|
|
|
|
modifyMVar :: M.MVar a -> (a -> EnvM (a,b)) -> EnvM b
|
|
modifyMVar mvar action = withRunInIO $ \run -> M.modifyMVar mvar (run . action)
|
|
|
|
|
|
runEnvM :: Env EnvM -> EnvM a -> IO a
|
|
runEnvM env envm = runReaderT (unEnvM envm) env
|
|
|
|
syncMVar :: MVar ()
|
|
syncMVar = unsafePerformIO $ newMVar ()
|
|
{-# NOINLINE syncMVar #-}
|
|
|
|
myLogAction :: LogAction EnvM Message
|
|
myLogAction = LogAction $ \x -> EnvM . lift $ modifyMVar_ syncMVar (const (T.putStrLn . formatMessage $ x))
|
|
|
|
formatMessage :: Message -> T.Text
|
|
formatMessage Msg{..} =
|
|
showMyServerity msgSeverity
|
|
<> showSourceLoc msgStack
|
|
<> msgText
|
|
|
|
showMyServerity :: Severity -> T.Text
|
|
showMyServerity s = case s of
|
|
Debug -> "<7>Debug "
|
|
Info -> "<6>Info "
|
|
Warning -> "<4>Warning "
|
|
Error -> "<3>Error "
|