71 lines
2.7 KiB
Haskell
71 lines
2.7 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(lift)
|
|
import Control.Monad.IO.Unlift
|
|
import Control.Concurrent.MVar (MVar,modifyMVar_,newMVar)
|
|
import System.IO.Unsafe(unsafePerformIO)
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.IO as T
|
|
import Control.Parallel(pseq)
|
|
|
|
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 #-}
|
|
|
|
runEnvM :: Env EnvM -> EnvM a -> IO a
|
|
runEnvM env envm = runReaderT (unEnvM envm) env
|
|
|
|
-- we do not export this MVar (which makes it easier to reason about deadlocks
|
|
syncMVar :: MVar ()
|
|
syncMVar = unsafePerformIO $ newMVar ()
|
|
{-# NOINLINE syncMVar #-}
|
|
|
|
-- Every time you do something like this you should ask yourself: Is this a potential deadlock? And the answer
|
|
-- is in this case is NO. Even if m diverges it won't be able to lock up other threads as it will be forced to
|
|
-- evaluate before we take the MVar. So as long printing to stdout terminates we will always put back the mvar.
|
|
myLogAction :: LogAction EnvM Message
|
|
myLogAction = LogAction $ \x -> let m = formatMessage x in EnvM . lift $ m `pseq` modifyMVar_ syncMVar (const (T.putStrLn m))
|
|
|
|
-- my format Message without fancy colors, but with syslog numbers
|
|
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 "
|