Code now uses `effectful` to manage side-effects

2 files changed, 81 insertions, 14 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
diff --git a/hsm-log/hsm-log.cabal b/hsm-log/hsm-log.cabal
index 65279db..24995da 100644
--- a/hsm-log/hsm-log.cabal
+++ b/hsm-log/hsm-log.cabal
@@ -1,4 +1,4 @@
-cabal-version: 3.4
+cabal-version: 3.8
 author:        Paul Oliver
 build-type:    Simple
 maintainer:    contact@pauloliver.dev
@@ -8,10 +8,15 @@ version:       0.1.0.0
 library
   build-depends:
     , base
+    , effectful-core
+    , effectful-plugin
     , iso8601-time
-    , text
+    , text-ansi
     , time
+    , typelits-printf
 
-  exposed-modules:  Hsm.Log
-  ghc-options:      -Wall -Wunused-packages
-  default-language: GHC2021
+  default-language:   GHC2024
+  exposed-modules:    Hsm.Log
+  ghc-options:
+    -O2 -Wall -Werror -Wno-star-is-type -Wunused-packages
+    -fplugin=Effectful.Plugin