Replace MonadLogger with co-log-core

README.md

@@ -11,15 +11,16 @@ Here's a simple example of loading Markdown files onto a TVar of `Map FilePath T
 ```haskell
 import System.UnionMount qualified as UM
 import Data.Map.Strict qualified as Map
+import Colog.Core (logTextStdout, filterBySeverity, Severity (..))
 
 main :: IO ()
 main = do
-  runStdoutLoggingT $ do
-    let baseDir = "/Users/srid/Documents/Notebook"
-    (model0, modelF) <- UM.mount baseDir (one ((), "*.md")) [] mempty (const $ handlePathUpdate baseDir)
-    modelVar <- newTVarIO model0
-    modelF $ \newModel -> do
-      atomically $ writeTVar modelVar newModel
+  let logger = filterBySeverity Info Severity logTextStdout  -- Log Info and above
+      baseDir = "/Users/srid/Documents/Notebook"
+  (model0, modelF) <- UM.mount logger baseDir (one ((), "*.md")) [] mempty (const $ handlePathUpdate baseDir)
+  modelVar <- newTVarIO model0
+  modelF $ \newModel -> do
+    atomically $ writeTVar modelVar newModel
 
 handlePathUpdate ::
   (MonadIO m) =>
@@ -33,6 +34,25 @@ handlePathUpdate baseDir path action = do
       pure $ Map.delete path
 ```
 
+### Logging
+
+unionmount uses [co-log-core](https://hackage.haskell.org/package/co-log-core) which has zero dependencies and allows you to bring your own logging implementation. The logger type is `LogAction m (WithSeverity Text)`, supporting Debug, Info, Warning, and Error severity levels.
+
+- **No logging**: Pass `mempty` as the logger
+- **co-log**: Use any co-log logger (with severity filtering)
+- **monad-logger**: Create a LogAction that calls your monad-logger functions
+- **Custom**: Implement your own `LogAction m (WithSeverity Text)`
+
+```haskell
+-- No logging
+UM.mount mempty folder pats ignore model handleAction
+
+-- Using co-log with severity filtering
+import Colog.Core (logTextStdout, filterBySeverity, Severity (..))
+let logger = filterBySeverity Info Severity logTextStdout  -- Only Info and above
+UM.mount logger folder pats ignore model handleAction
+```
+
 ### Examples
 
 See [this example](https://github.com/EmaApps/ema/blob/459d3899e0b9ea13e23c81126279dc62530b994c/src/Ema/Route/Lib/Extra/PandocRoute.hs#L132-L139) illustrating mounting a directory of Markdown files into (effectively) a `Map FilePath String`. A [more involved example](https://github.com/EmaApps/emanote/blob/7c49c73cd3b7dbeace72353574f3decfb68929f2/src/Emanote/Source/Dynamic.hs#L58-L64) from Emanote demonstrates the "union" aspect of the library.

src/System/UnionMount.hs

@@ -17,12 +17,8 @@ module System.UnionMount
   )
 where
 
+import Colog.Core (LogAction, Severity (..), WithSeverity (..), (<&))
 import Control.Concurrent (threadDelay)
-import Control.Monad.Logger
-  ( LogLevel (LevelDebug, LevelError, LevelInfo, LevelWarn),
-    MonadLogger,
-    logWithoutLoc,
-  )
 import Data.LVar qualified as LVar
 import Data.Map.Strict qualified as Map
 import Data.Set qualified as Set
@@ -49,10 +45,11 @@ mount ::
   forall model m b.
   ( MonadIO m,
     MonadUnliftIO m,
-    MonadLogger m,
     Show b,
     Ord b
   ) =>
+  -- | Logger
+  LogAction m (WithSeverity Text) ->
   -- | The directory to mount.
   FilePath ->
   -- | Only include these files (exclude everything else)
@@ -71,10 +68,10 @@ mount ::
   -- If the action throws an exception, it will be logged and ignored.
   (b -> FilePath -> FileAction () -> m (model -> model)) ->
   m (model, (model -> m ()) -> m ())
-mount folder pats ignore var0 toAction' =
+mount logger folder pats ignore var0 toAction' =
   let tag0 = ()
       sources = one (tag0, (folder, Nothing))
-   in unionMount sources pats ignore var0 $ \ch -> do
+   in unionMount logger sources pats ignore var0 $ \ch -> do
         let fsSet = (fmap . fmap . fmap . fmap) void $ fmap Map.toList <$> Map.toList ch
         (\(tag, xs) -> uncurry (toAction' tag) `chainM` xs) `chainM` fsSet
   where
@@ -95,41 +92,42 @@ unionMount ::
   forall source tag model m.
   ( MonadIO m,
     MonadUnliftIO m,
-    MonadLogger m,
     Ord source,
     Ord tag
   ) =>
+  -- | Logger
+  LogAction m (WithSeverity Text) ->
   Set (source, (FilePath, Maybe FilePath)) ->
   [(tag, FilePattern)] ->
   [FilePattern] ->
   model ->
   (Change source tag -> m (model -> model)) ->
   m (model, (model -> m ()) -> m ())
-unionMount sources pats ignore model0 handleAction = do
-  (x0, xf) <- unionMount' sources pats ignore
-  x0' <- interceptExceptions id $ handleAction x0
+unionMount logger sources pats ignore model0 handleAction = do
+  (x0, xf) <- unionMount' logger sources pats ignore
+  x0' <- interceptExceptions logger id $ handleAction x0
   let initial = x0' model0
   lvar <- LVar.new initial
   let sender send = do
         Cmd_Remount <- xf $ \change -> do
-          change' <- interceptExceptions id $ handleAction change
+          change' <- interceptExceptions logger id $ handleAction change
           LVar.modify lvar change'
           x <- LVar.get lvar
           send x
-        log LevelInfo "Remounting..."
-        (a, b) <- unionMount sources pats ignore model0 handleAction
+        logger <& WithSeverity "Remounting..." Info
+        (a, b) <- unionMount logger sources pats ignore model0 handleAction
         send a
         b send
   pure (x0' model0, sender)
 
 -- Log and ignore exceptions
 --
 -- TODO: Make user define-able?
-interceptExceptions :: (MonadIO m, MonadUnliftIO m, MonadLogger m) => a -> m a -> m a
-interceptExceptions default_ f = do
+interceptExceptions :: (MonadIO m, MonadUnliftIO m) => LogAction m (WithSeverity Text) -> a -> m a -> m a
+interceptExceptions logger default_ f = do
   try f >>= \case
     Left (ex :: SomeException) -> do
-      log LevelError $ "Change handler exception: " <> show ex
+      logger <& WithSeverity ("Change handler exception: " <> show ex) Error
       pure default_
     Right v ->
       pure v
@@ -149,30 +147,29 @@ data Cmd
 
 -- | Like `unionMount` but without exception interrupting or re-mounting.
 unionMount' ::
-  forall source tag m m1.
+  forall source tag m.
   ( MonadIO m,
     MonadUnliftIO m,
-    MonadLogger m,
-    MonadLogger m1,
-    MonadIO m1,
     Ord source,
     Ord tag
   ) =>
+  -- | Logger
+  LogAction m (WithSeverity Text) ->
   Set (source, (FilePath, Maybe FilePath)) ->
   [(tag, FilePattern)] ->
   [FilePattern] ->
-  m1
+  m
     ( Change source tag,
       (Change source tag -> m ()) ->
       m Cmd
     )
-unionMount' sources pats ignore = do
+unionMount' logger sources pats ignore = do
   flip evalStateT (emptyOverlayFs @source) $ do
     -- Initial traversal of sources
     changes0 :: Change source tag <-
       fmap snd . flip runStateT Map.empty $ do
         forM_ sources $ \(src, (folder, mountPoint)) -> do
-          taggedFiles <- filesMatchingWithTag folder pats ignore
+          taggedFiles <- lift . lift $ filesMatchingWithTag logger folder pats ignore
           forM_ taggedFiles $ \(tag, fs) -> do
             forM_ fs $ \fp -> do
               put =<< lift . changeInsert src tag mountPoint fp (Refresh Existing ()) =<< get
@@ -183,7 +180,7 @@ unionMount' sources pats ignore = do
           -- Run fsnotify on sources
           q :: TMVar (x, Maybe FilePath, FilePath, Either (FolderAction ()) (FileAction ())) <- liftIO newEmptyTMVarIO
           fmap (either id id) $
-            race (onChange q (toList sources)) $
+            race (onChange logger q (toList sources)) $
               let readDebounced = do
                     -- Wait for some initial action in the queue.
                     _ <- atomically $ readTMVar q
@@ -201,11 +198,11 @@ unionMount' sources pats ignore = do
                         let reason = "Unhandled folder event on '" <> toText fp <> "'"
                         if shouldIgnore
                           then do
-                            log LevelWarn $ reason <> " on an ignored path"
+                            lift $ logger <& WithSeverity (reason <> " on an ignored path") Warning
                             loop
                           else do
                             -- We don't know yet how to deal with folder events. Just reboot the mount.
-                            log LevelWarn $ reason <> "; suggesting a re-mount"
+                            lift $ logger <& WithSeverity (reason <> "; suggesting a re-mount") Warning
                             pure Cmd_Remount -- Exit, asking user to remokunt
                       Right act -> do
                         case guard (not shouldIgnore) >> getTag pats fp of
@@ -218,17 +215,17 @@ unionMount' sources pats ignore = do
                in evalStateT loop ofs
       )
 
-filesMatching :: (MonadIO m, MonadLogger m) => FilePath -> [FilePattern] -> [FilePattern] -> m [FilePath]
-filesMatching parent' pats ignore = do
+filesMatching :: (MonadIO m) => LogAction m (WithSeverity Text) -> FilePath -> [FilePattern] -> [FilePattern] -> m [FilePath]
+filesMatching logger parent' pats ignore = do
   parent <- liftIO $ canonicalizePath parent'
-  log LevelInfo $ toText $ "Traversing " <> parent <> " for files matching " <> show pats <> ", ignoring " <> show ignore
+  logger <& WithSeverity (toText $ "Traversing " <> parent <> " for files matching " <> show pats <> ", ignoring " <> show ignore) Info
   liftIO $ getDirectoryFilesIgnore parent pats ignore
 
 -- | Like `filesMatching` but with a tag associated with a pattern so as to be
 -- able to tell which pattern a resulting filepath is associated with.
-filesMatchingWithTag :: (MonadIO m, MonadLogger m, Ord b) => FilePath -> [(b, FilePattern)] -> [FilePattern] -> m [(b, [FilePath])]
-filesMatchingWithTag parent' pats ignore = do
-  fs <- filesMatching parent' (snd <$> pats) ignore
+filesMatchingWithTag :: (MonadIO m, Ord b) => LogAction m (WithSeverity Text) -> FilePath -> [(b, FilePattern)] -> [FilePattern] -> m [(b, [FilePath])]
+filesMatchingWithTag logger parent' pats ignore = do
+  fs <- filesMatching logger parent' (snd <$> pats) ignore
   let m = Map.fromListWith (<>) $
         flip mapMaybe fs $ \fp -> do
           tag <- getTag pats fp
@@ -279,22 +276,23 @@ refreshAction = \case
 
 onChange ::
   forall x m.
-  (Eq x, MonadIO m, MonadLogger m, MonadUnliftIO m) =>
+  (Eq x, MonadIO m, MonadUnliftIO m) =>
+  LogAction m (WithSeverity Text) ->
   TMVar (x, Maybe FilePath, FilePath, Either (FolderAction ()) (FileAction ())) ->
   [(x, (FilePath, Maybe FilePath))] ->
   -- | The filepath is relative to the folder being monitored, unless if its
   -- ancestor is a symlink.
   m Cmd
-onChange q roots = do
+onChange logger q roots = do
   withManagerM $ \mgr -> do
     stops <- forM roots $ \(x, (rootRel, mountPoint)) -> do
       -- NOTE: It is important to use canonical path, because this will allow us to
       -- transform fsnotify event's (absolute) path into one that is relative to
       -- @parent'@ (as passed by user), which is what @f@ will expect.
       root <- liftIO $ canonicalizePath rootRel
-      log LevelInfo $ toText $ "Monitoring " <> root <> " for changes"
+      logger <& WithSeverity (toText $ "Monitoring " <> root <> " for changes") Info
       watchTreeM mgr root (const True) $ \event -> do
-        log LevelDebug $ show event
+        logger <& WithSeverity (show event) Debug
         atomically $ do
           lastQ <- tryTakeTMVar q
           let fp = makeRelative root $ eventPath event
@@ -323,7 +321,7 @@ onChange q roots = do
                 (_, Just a) -> reAddQ >> f (Right a)
     liftIO (threadDelay maxBound)
       `finally` do
-        log LevelInfo "Stopping fsnotify monitor."
+        logger <& WithSeverity "Stopping fsnotify monitor." Info
         liftIO $ forM_ stops id
     -- Unreachable
     pure Cmd_Remount
@@ -348,9 +346,6 @@ watchTreeM wm fp pr f =
   withRunInIO $ \run ->
     watchTree wm fp pr $ \evt -> run (f evt)
 
-log :: (MonadLogger m) => LogLevel -> Text -> m ()
-log = logWithoutLoc "System.UnionMount"
-
 -- TODO: Abstract in module with StateT / MonadState
 newtype OverlayFs source = OverlayFs (Map FilePath (Set (source, FilePath)))
 

test/System/UnionMountSpec.hs

@@ -3,7 +3,7 @@
 
 module System.UnionMountSpec where
 
-import Control.Monad.Logger.Extras (logToNowhere, runLoggerLoggingT)
+import Colog.Core (LogAction, WithSeverity)
 import Data.LVar qualified as LVar
 import Data.List (stripPrefix)
 import Data.List.NonEmpty qualified as NE
@@ -106,21 +106,22 @@ unionMountSpec ::
 unionMountSpec folders = do
   withUnionFolderMutations folders $ \tempDirs -> do
     model <- LVar.empty
-    flip runLoggerLoggingT logToNowhere $ do
-      let layers = Set.fromList $ toList tempDirs <&> \(folder, path) -> (path, (path, _folderMountPoint folder))
-      (model0, patch) <- UM.unionMount layers allFiles ignoreNone mempty $ \change -> do
-        let files = Unsafe.fromJust $ Map.lookup () change
-        flip UM.chainM (Map.toList files) $ \(fp, act) -> do
-          case act of
-            UM.Delete -> pure $ Map.delete fp
-            UM.Refresh _ layerFiles -> do
-              contents <- for layerFiles $ \(tempDir, path) ->
-                readFileBS $ tempDir </> path
-              pure $ Map.insert fp contents
-      LVar.set model model0
-      race_
-        (patch $ LVar.set model)
-        (withPaddedThreadDelay 500_000 $ updateUnionFolderMutations tempDirs)
+    let logger :: LogAction IO (WithSeverity Text)
+        logger = mempty -- no logging
+        layers = Set.fromList $ toList tempDirs <&> \(folder, path) -> (path, (path, _folderMountPoint folder))
+    (model0, patch) <- UM.unionMount logger layers allFiles ignoreNone mempty $ \change -> do
+      let files = Unsafe.fromJust $ Map.lookup () change
+      flip UM.chainM (Map.toList files) $ \(fp, act) -> do
+        case act of
+          UM.Delete -> pure $ Map.delete fp
+          UM.Refresh _ layerFiles -> do
+            contents <- for layerFiles $ \(tempDir, path) ->
+              readFileBS $ tempDir </> path
+            pure $ Map.insert fp contents
+    LVar.set model model0
+    race_
+      (patch $ LVar.set model)
+      (withPaddedThreadDelay 500_000 $ updateUnionFolderMutations tempDirs)
     finalModel <- LVar.get model
     expected <- runUnionFolderMutations folders
     finalModel `shouldBe` expected

unionmount.cabal

@@ -29,14 +29,14 @@ common library-common
     , async
     , base          >=4.13.0 && <5
     , bytestring
+    , co-log-core
     , containers
     , data-default
     , directory
     , filepath
     , filepattern
     , fsnotify      >=0.4.0  && <0.5
     , lvar
-    , monad-logger
     , mtl
     , relude
     , text
@@ -80,8 +80,6 @@ test-suite test
   build-depends:
     , dir-traverse
     , hspec
-    , monad-logger
-    , monad-logger-extras
     , relude
 
   if flag(ghcid)