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

module Hsm.Log
  ( Severity (Attention, Info, Trace)
  , Log
  , getLoggerIO
  , logMsg
  , runLog
  )
where

import Control.Monad (when)
import Data.Function (applyWhen)
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
  , unsafeEff_
  )
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import GHC.TypeLits.Printf (printf)
import String.ANSI (red)

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

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

type instance DispatchOf (Log d) = Static WithSideEffects

newtype instance StaticRep (Log d)
  = Log Severity

getLoggerIO
  :: forall d es
   . (KnownSymbol d, Log d :> es)
  => Eff es (Severity -> String -> IO ())
getLoggerIO = do
  Log level <- getStaticRep
  return $ \severity message ->
    when (severity <= level) $ do
      time <- formatISO8601Millis <$> getCurrentTime
      putStrLn . applyWhen (severity == Attention) red $
        printf
          "%s %s [%s] %s"
          time
          (symbolVal $ Proxy @d)
          (show severity)
          message

logMsg
  :: forall d es
   . (KnownSymbol d, Log d :> es)
  => Severity
  -> String
  -> Eff es ()
logMsg severity message =
  getLoggerIO >>= \loggerIO -> unsafeEff_ $ loggerIO severity message

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

class Logs (ds :: [Symbol]) (es :: [Effect]) where
  type Insert ds es :: [Effect]
  runLogs :: Severity -> Eff (Insert ds es) a -> Eff es a

instance Logs ('[] :: [Symbol]) (es :: [Effect]) where
  type Insert '[] es = es
  runLogs _ = id

instance
  (IOE :> Insert ds es, KnownSymbol d, Logs ds es)
  => Logs (d : ds :: [Symbol]) (es :: [Effect])
  where
  type Insert (d : ds) es = Log d : Insert ds es
  runLogs level = runLogs @ds level . runLog @d level