1 files changed, 71 insertions, 9 deletions
diff --git a/hsm-log/Hsm/Log.hs b/hsm-log/Hsm/Log.hs
index 0f388be..5321910 100644
--- a/hsm-log/Hsm/Log.hs
+++ b/hsm-log/Hsm/Log.hs
@@ -1,15 +1,77 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 module Hsm.Log
-  ( logMsg
-  ) where
+  ( Severity (Attention, Info, Trace)
+  , Log
+  , logMsg
+  , runLog
+  )
+where
 
-import Data.Text qualified as T
-import Data.Text.IO qualified as T
+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)
 
-logMsg :: [T.Text] -> T.Text -> IO ()
-logMsg domain msg = do
-  time <- T.pack . formatISO8601Millis <$> getCurrentTime
-  T.putStrLn $ T.unwords [time, "[" <> T.intercalate "/" domain <> "]", msg]
+data Severity
+  = Attention
+  | Info
+  | Trace
+  deriving (Eq, Ord, Show)
+
+data Log (d :: Symbol) (a :: * -> *) (b :: *)
+
+type instance DispatchOf (Log d) = Static WithSideEffects
+
+newtype instance StaticRep (Log d)
+  = Log Severity
+
+logMsg
+  :: forall d es
+   . (KnownSymbol d, Log d :> es)
+  => Severity
+  -> String
+  -> Eff es ()
+logMsg severity message = do
+  Log level <- getStaticRep
+  unsafeEff_ . when (severity <= level) $ do
+    time <- formatISO8601Millis <$> getCurrentTime
+    putStrLn . applyWhen (severity == Attention) red $
+      printf "%s %s [%s] %s" time (symbolVal $ Proxy @d) (show level) 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