feat: initial commit

drlkf · drlkf · commit 2438dfd55863 · 2025-12-05T21:03:30.000+01:00
diff --git a/.gitignore b/.gitignore
@@ -0,0 +1,3 @@
+.stack-work/
+dist-newstyle/
+*.log
diff --git a/LICENSE b/LICENSE
diff --git a/README.md b/README.md
@@ -0,0 +1,4 @@
+# fused-effects-logger
+A logger effects for the
+[`fused-effects`](https://github.com/fused-effects/fused-effects) library, based
+on the [`monad-logger`](https://github.com/snoyberg/monad-logger) API.
diff --git a/fused-effects-logger.cabal b/fused-effects-logger.cabal
@@ -0,0 +1,57 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.37.0.
+--
+-- see: https://github.com/sol/hpack
+
+name:           fused-effects-logger
+version:        0.0.0.0
+synopsis:       Logger effect for the `fused-effects` library
+description:    A logger effect for the `fused-effects` library based on the `monad-logger` api.
+category:       Effect
+author:         drlkf
+maintainer:     drlkf@drlkf.net
+copyright:      2025 drlkf
+license:        GPL-3
+license-file:   LICENSE
+build-type:     Simple
+extra-source-files:
+    README.md
+
+library
+  exposed-modules:
+      Control.Carrier.Logger.IO
+      Control.Carrier.Logger.Writer
+      Control.Effect.Logger
+  other-modules:
+      Paths_fused_effects_logger
+  hs-source-dirs:
+      src
+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints
+  build-depends:
+      base >=4.7 && <5
+    , bytestring >=0.12 && <1
+    , fused-effects >=1.1 && <2
+    , monad-logger >=0.3 && <1
+  default-language: Haskell2010
+
+test-suite fused-effects-logger-test
+  type: exitcode-stdio-1.0
+  main-is: Spec.hs
+  other-modules:
+      Control.Carrier.Logger.IOSpec
+      Control.Carrier.Logger.WriterSpec
+      Paths_fused_effects_logger
+  hs-source-dirs:
+      test
+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+      base >=4.7 && <5
+    , bytestring >=0.12 && <1
+    , directory
+    , fused-effects >=1.1 && <2
+    , fused-effects-logger
+    , ghc-prim
+    , hspec
+    , monad-logger >=0.3 && <1
+  default-language: Haskell2010
diff --git a/package.yaml b/package.yaml
@@ -0,0 +1,49 @@
+name:       fused-effects-logger
+version:    0.0.0.0
+license:    GPL-3
+author:     drlkf
+maintainer: drlkf@drlkf.net
+copyright:  2025 drlkf
+category:   Effect
+
+extra-source-files:
+  - README.md
+
+synopsis: Logger effect for the `fused-effects` library
+description: >-
+  A logger effect for the `fused-effects` library based on the `monad-logger`
+  api.
+
+dependencies:
+  - base >= 4.7 && < 5
+  - bytestring >= 0.12 && < 1
+  - fused-effects >= 1.1 && < 2
+  - monad-logger >= 0.3 && < 1
+
+ghc-options:
+  - -Wall
+  - -Wcompat
+  - -Widentities
+  - -Wincomplete-record-updates
+  - -Wincomplete-uni-patterns
+  - -Wmissing-export-lists
+  - -Wmissing-home-modules
+  - -Wpartial-fields
+  - -Wredundant-constraints
+
+library:
+  source-dirs: src
+
+tests:
+  fused-effects-logger-test:
+    main: Spec.hs
+    source-dirs: test
+    ghc-options:
+      - -threaded
+      - -rtsopts
+      - -with-rtsopts=-N
+    dependencies:
+      - fused-effects-logger
+      - directory
+      - ghc-prim
+      - hspec
diff --git a/src/Control/Carrier/Logger/IO.hs b/src/Control/Carrier/Logger/IO.hs
@@ -0,0 +1,68 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Control.Carrier.Logger.IO (
+  HandleSelector,
+  singleHandle,
+  runLoggerIO,
+) where
+
+import Control.Algebra (Algebra (..), (:+:) (..))
+import Control.Carrier.Reader (ReaderC, runReader)
+import Control.Effect.Logger (Logger (..))
+import Control.Effect.Reader (ask)
+import Control.Monad.IO.Class (MonadIO (..))
+import Control.Monad.Logger (
+  Loc,
+  LogLevel,
+  LogSource,
+  LogStr,
+  ToLogStr (..),
+  defaultLogStr,
+  fromLogStr,
+ )
+import qualified Data.ByteString.Char8 as B (hPutStr)
+import System.IO (Handle)
+
+-- | Algebra for a simple IO logger. The inner function allows for selecting a
+-- 'Handle' according to something like 'LogLevel'.
+newtype LoggerIOC f m a = LoggerIOC
+  { runLoggerIOC :: ReaderC f m a
+  }
+  deriving (Applicative, Functor, Monad, MonadIO)
+
+type HandleSelector = Loc -> LogSource -> LogLevel -> LogStr -> Handle
+
+singleHandle :: Handle -> HandleSelector
+singleHandle h _ _ _ _ = h
+
+instance
+  forall sig m
+   . ( Algebra sig m
+     , MonadIO m
+     )
+  => Algebra (Logger :+: sig) (LoggerIOC HandleSelector m)
+  where
+  alg hdl sig ctx = case sig of
+    L (LoggerLog loc src lvl msg) -> LoggerIOC $ do
+      f <- ask
+      ctx
+        <$ liftIO
+          ( B.hPutStr
+              (f loc src lvl (toLogStr msg))
+              (fromLogStr (defaultLogStr loc src lvl (toLogStr msg)))
+          )
+    R other -> LoggerIOC (alg (runLoggerIOC . hdl) (R other) ctx)
+
+-- | Run a logger by writing to a 'Handle'.
+runLoggerIO
+  :: HandleSelector
+  -> LoggerIOC HandleSelector m a
+  -> m a
+runLoggerIO f = runReader f . runLoggerIOC
diff --git a/src/Control/Carrier/Logger/Writer.hs b/src/Control/Carrier/Logger/Writer.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Control.Carrier.Logger.Writer (
+  LoggerWriterC (..),
+  runLoggerW,
+) where
+
+import Control.Algebra (Algebra (..), (:+:) (..))
+import Control.Carrier.Writer.Strict (WriterC, runWriter, tell)
+import Control.Effect.Logger (Logger (..))
+import Control.Monad.IO.Class (MonadIO (..))
+import Control.Monad.Logger (
+  LogLine,
+  ToLogStr (..),
+ )
+
+-- | Reinterpreter from logger to writer. The underlying 'Writer' is always
+-- 'Control.Carrier.Writer.Strict'.
+newtype LoggerWriterC w m a = LoggerWriterC
+  { runLoggerWriterC :: WriterC (w LogLine) m a
+  }
+  deriving (Applicative, Functor, Monad, MonadIO)
+
+instance
+  forall sig w m
+   . ( Algebra sig m
+     , Applicative w
+     , Monoid (w LogLine)
+     )
+  => Algebra (Logger :+: sig) (LoggerWriterC w m)
+  where
+  alg hdl sig ctx = case sig of
+    L (LoggerLog loc src lvl msg) ->
+      ctx <$ LoggerWriterC (tell (pure (loc, src, lvl, toLogStr msg) :: w LogLine))
+    R other ->
+      LoggerWriterC (alg (runLoggerWriterC . hdl) (R other) ctx)
+
+runLoggerW
+  :: Monoid (w LogLine)
+  => LoggerWriterC w m a
+  -> m (w LogLine, a)
+runLoggerW = runWriter . runLoggerWriterC
diff --git a/src/Control/Effect/Logger.hs b/src/Control/Effect/Logger.hs
@@ -0,0 +1,40 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Control.Effect.Logger (
+  Logger (..),
+) where
+
+import Control.Effect.Labelled (Has, send)
+import Control.Monad.Logger (
+  Loc,
+  LogLevel,
+  LogSource,
+  MonadLogger (..),
+  ToLogStr (..),
+ )
+import Data.Kind (Type)
+
+--
+-- Effect definition
+--
+
+-- | A simple logger effect that takes all information a 'MonadLogger' monad
+-- would take. In order to be able to use the same interface as 'MonadLogger',
+-- that unfortunately means it needs to implement the 'MonadLogger' instance as
+-- an orphan.
+data Logger (m :: Type -> Type) k where
+  LoggerLog
+    :: ToLogStr msg
+    => Loc
+    -> LogSource
+    -> LogLevel
+    -> msg
+    -> Logger m ()
+
+-- ORPHAN :(
+instance (Has Logger sig m, Monad m) => MonadLogger m where
+  monadLoggerLog loc src lvl msg = send (LoggerLog loc src lvl msg)
diff --git a/stack.yaml b/stack.yaml
@@ -0,0 +1,6 @@
+---
+resolver:
+  url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/24/11.yaml
+
+packages:
+  - .
diff --git a/stack.yaml.lock b/stack.yaml.lock
@@ -0,0 +1,13 @@
+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+#   https://docs.haskellstack.org/en/stable/topics/lock_files
+
+packages: []
+snapshots:
+- completed:
+    sha256: 468e1afa06cd069e57554f10e84fdf1ac5e8893e3eefc503ef837e2449f7e60c
+    size: 726310
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/24/11.yaml
+  original:
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/24/11.yaml
diff --git a/test/Control/Carrier/Logger/IOSpec.hs b/test/Control/Carrier/Logger/IOSpec.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Control.Carrier.Logger.IOSpec (
+  spec,
+) where
+
+import Control.Carrier.Lift (runM)
+import Control.Carrier.Logger.IO (runLoggerIO, singleHandle)
+import Control.Monad.Logger (logDebugN, logInfoN, logWarnN)
+import System.Directory (removePathForcibly)
+import System.IO (hClose, openTempFile)
+import Test.Hspec (Spec, describe, it, shouldReturn)
+
+spec :: Spec
+spec = do
+  let runTestLogger action = do
+        (fp, h) <- openTempFile "." "LoggerIOC.log"
+        _ <- runM (runLoggerIO (singleHandle h) action)
+        hClose h
+        readFile fp <* removePathForcibly fp
+
+  describe "LoggerIOC" $ do
+    it "no log" $ do
+      runTestLogger (pure ()) `shouldReturn` ""
+
+    it "3 logs" $ do
+      let action = do
+            logDebugN "1"
+            logInfoN "2"
+            logWarnN "3"
+          logLines =
+            [ "[Debug] 1"
+            , "[Info] 2"
+            , "[Warn] 3"
+            ]
+
+      lines <$> runTestLogger action `shouldReturn` logLines
diff --git a/test/Control/Carrier/Logger/WriterSpec.hs b/test/Control/Carrier/Logger/WriterSpec.hs
@@ -0,0 +1,29 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Control.Carrier.Logger.WriterSpec (
+  spec,
+) where
+
+import Control.Carrier.Interpret (run)
+import Control.Carrier.Logger.Writer (runLoggerW)
+import Control.Monad.Logger (LogLevel (..), defaultLoc, logDebugN, logInfoN, logWarnN)
+import Test.Hspec (Spec, describe, it, shouldBe)
+
+spec :: Spec
+spec = do
+  describe "LoggerWriterC" $ do
+    it "no log" $
+      run (runLoggerW (pure ())) `shouldBe` ([], ())
+
+    it "3 logs" $ do
+      let action = do
+            logDebugN "1"
+            logInfoN "2"
+            logWarnN "3"
+          logLines =
+            [ (defaultLoc, "", LevelDebug, "1")
+            , (defaultLoc, "", LevelInfo, "2")
+            , (defaultLoc, "", LevelWarn, "3")
+            ]
+
+      run (runLoggerW action) `shouldBe` (logLines, ())
diff --git a/test/Spec.hs b/test/Spec.hs
@@ -0,0 +1,2 @@
+{-# OPTIONS_GHC -Wno-missing-export-lists #-}
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

Original file line number	Diff line number	Diff line change
`@@ -0,0 +1,3 @@`
	`1`	`+.stack-work/`
	`2`	`+dist-newstyle/`
	`3`	`+*.log`