{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Hsm.Log
  ( Severity (Attention, Info, Trace)
  , Log
  , Logs
  , LogOptionPrefix
  , getLevel
  , logMsg
  , makeLoggerIO
  , runLog
  , runLogOpt
  , runLogs
  , runLogsOpt
  )
where

import Control.Monad (when)
import Data.Function (applyWhen)
import Data.Kind (Constraint)
import Data.List (intercalate)
import Data.Proxy (Proxy (Proxy))
import Data.Time.Clock (getCurrentTime)
import Data.Time.ISO8601 (formatISO8601Millis)
import Effectful (Dispatch (Static), DispatchOf, Eff, Effect, IOE, (:>))
import Effectful.Dispatch.Static
  ( SideEffects (WithSideEffects)
  , StaticRep
  , evalStaticRep
  , getStaticRep
  , unEff
  , unsafeEff
  , unsafeEff_
  )
import GHC.Conc.Sync (fromThreadId, myThreadId)
import GHC.Records (HasField, getField)
import GHC.TypeLits (AppendSymbol, KnownSymbol, Symbol, symbolVal)
import String.ANSI (blue, green, red, white)

data Severity
  = Attention
  | Info
  | Trace
  deriving (Enum, Eq, Ord, Read, Show)

coloredShow :: Severity -> String
coloredShow Attention = red "ATTENTION"
coloredShow Info = green "INFO"
coloredShow Trace = blue "TRACE"

data Log (d :: Symbol) (a :: * -> *) (b :: *)

type instance DispatchOf (Log d) = Static WithSideEffects

newtype instance StaticRep (Log d)
  = Log Severity

-- Constraint combinator for multiple logger effects
-- Simplifies effect constraints for functions requiring multiple loggers.
--
-- Example:
-- >>> :kind! Logs '["log1", "log2"] es
-- (Log "log1" :> es, Log "log2" :> es)
type family Logs ls es :: Constraint where
  Logs '[] es = ()
  Logs (l : ls) es = (Log l :> es, Logs ls es)

type LogOptionPrefix = "logLevel_"

getLevel :: Log d :> es => Eff es Severity
getLevel = getStaticRep >>= \(Log level) -> return level

logMsg
  :: forall d es
   . (KnownSymbol d, Log d :> es)
  => Severity
  -> String
  -> Eff es ()
logMsg severity message = do
  level <- getLevel
  when (severity <= level) . unsafeEff_ $ do
    time <- formatISO8601Millis <$> getCurrentTime
    domainAndThreadId <- myThreadId >>= \tid -> return . white $ symbolVal (Proxy @d) <> ":" <> show (fromThreadId tid)
    putStrLn $
      unwords
        [ time
        , domainAndThreadId
        , coloredShow severity
        , applyWhen (severity == Attention) red . intercalate "\n ... " $ lines message
        ]

makeLoggerIO
  :: forall d es
   . (KnownSymbol d, Log d :> es)
  => Eff es (Severity -> String -> IO ())
makeLoggerIO = unsafeEff $ \env -> return $ \severity message -> unEff (logMsg severity message) env

runLog
  :: forall d es a
   . IOE :> es
  => Severity
  -> Eff (Log d : es) a
  -> Eff es a
runLog = evalStaticRep . Log

runLogOpt
  :: forall d f o es a
   . (AppendSymbol LogOptionPrefix d ~ f, HasField f o Severity, IOE :> es)
  => o
  -> Eff (Log d : es) a
  -> Eff es a
runLogOpt = runLog . getField @f

class LogsClass (o :: *) (ds :: [Symbol]) (es :: [Effect]) where
  type Insert ds es :: [Effect]
  runLogs :: Severity -> Eff (Insert ds es) a -> Eff es a
  runLogsOpt :: o -> Eff (Insert ds es) a -> Eff es a

instance LogsClass (o :: *) ('[] :: [Symbol]) (es :: [Effect]) where
  type Insert '[] es = es
  runLogs = const id
  runLogsOpt = const id

instance
  (AppendSymbol LogOptionPrefix d ~ f, HasField f o Severity, IOE :> Insert ds es, KnownSymbol d, LogsClass o ds es)
  => LogsClass (o :: *) (d : ds :: [Symbol]) (es :: [Effect])
  where
  type Insert (d : ds) es = Log d : Insert ds es
  runLogs level = runLogs @o @ds level . runLog @d level
  runLogsOpt opts = runLogsOpt @o @ds opts . runLogOpt @d @f @o opts