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