{-# 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   "