Add a basic test suite in log-base

.github/workflows/haskell-ci.yml

@@ -233,6 +233,9 @@ jobs:
           ${CABAL} -vnormal check
           cd ${PKGDIR_log_postgres} || false
           ${CABAL} -vnormal check
+      - name: cabal tests
+        run: |
+          ${CABAL} test $ARG_COMPILER all
       - name: haddock
         run: |
           $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all

fourmolu.yaml

@@ -0,0 +1,53 @@
+# Number of spaces per indentation step
+indentation: 2
+
+# Max line length for automatic line breaking
+column-limit: none
+
+# Styling of arrows in type signatures (choices: trailing, leading, or leading-args)
+function-arrows: leading
+
+# How to place commas in multi-line lists, records, etc. (choices: leading or trailing)
+comma-style: leading
+
+# Styling of import/export lists (choices: leading, trailing, or diff-friendly)
+import-export-style: leading
+
+# Whether to full-indent or half-indent 'where' bindings past the preceding body
+indent-wheres: true
+
+# Whether to leave a space before an opening record brace
+record-brace-space: true
+
+# Number of spaces between top-level declarations
+newlines-between-decls: 1
+
+# How to print Haddock comments (choices: single-line, multi-line, or multi-line-compact)
+haddock-style: single-line
+
+# How to print module docstring
+haddock-style-module: null
+
+# Styling of let blocks (choices: auto, inline, newline, or mixed)
+let-style: inline
+
+# How to align the 'in' keyword with respect to the 'let' keyword (choices: left-align, right-align, or no-space)
+in-style: no-space
+
+# Whether to put parentheses around a single constraint (choices: auto, always, or never)
+single-constraint-parens: never
+
+# Whether to put parentheses around a single deriving class (choices: auto, always, or never)
+single-deriving-parens: always
+
+# Output Unicode syntax (choices: detect, always, or never)
+unicode: never
+
+# Give the programmer more choice on where to insert blank lines
+respectful: true
+
+# Fixity information for operators
+fixities: []
+
+# Module reexports Fourmolu should know about
+reexports: []

log-base/CHANGELOG.md

@@ -1,3 +1,7 @@
+# log-base-0.xx.x.x (xxxx-xx-xx)
+* Add base tests in log-base testing message ordering and dropping
+* Add fourmolu config file
+
 # log-base-0.12.1.0 (2025-06-26)
 * Add utility function to log unhandled exceptions.
 

log-base/log-base.cabal

@@ -20,14 +20,33 @@ maintainer:          Andrzej Rybczak <[email protected]>,
 copyright:           Scrive AB
 category:            System
 build-type:          Simple
-extra-source-files:  CHANGELOG.md, README.md
+extra-doc-files:     CHANGELOG.md, README.md
 tested-with:         GHC == { 8.10.7, 9.0.2, 9.2.8, 9.4.8, 9.6.7, 9.8.4, 9.10.2, 9.12.2 }
 
 source-repository head
   type:     git
   location: https://github.com/scrive/log.git
 
+common shared
+  ghc-options:        -Wall
+  default-language:   Haskell2010
+  default-extensions: BangPatterns
+                    , FlexibleContexts
+                    , FlexibleInstances
+                    , GeneralizedNewtypeDeriving
+                    , LambdaCase
+                    , MultiParamTypeClasses
+                    , NumericUnderscores
+                    , OverloadedStrings
+                    , RankNTypes
+                    , RecordWildCards
+                    , ScopedTypeVariables
+                    , TypeFamilies
+                    , UndecidableInstances
+
+
 library
+  import:              shared
   exposed-modules:     Log,
                        Log.Backend.LogList,
                        Log.Backend.StandardOutput,
@@ -39,6 +58,7 @@ library
                        Log.Internal.Logger,
                        Log.Logger,
                        Log.Monad
+
   build-depends:       base >= 4.13 && <5,
                        aeson >= 1.0,
                        aeson-pretty >=0.8.2,
@@ -57,18 +77,23 @@ library
                        unordered-containers
   hs-source-dirs:      src
 
-  ghc-options:         -Wall
-
-  default-language:   Haskell2010
-  default-extensions: BangPatterns
-                    , FlexibleContexts
-                    , FlexibleInstances
-                    , GeneralizedNewtypeDeriving
-                    , LambdaCase
-                    , MultiParamTypeClasses
-                    , OverloadedStrings
-                    , RankNTypes
-                    , RecordWildCards
-                    , ScopedTypeVariables
-                    , TypeFamilies
-                    , UndecidableInstances
+test-suite log-base-tests
+  import: shared
+  type: exitcode-stdio-1.0
+  main-is: Driver.hs
+  hs-source-dirs: tests
+  ghc-options: -threaded -rtsopts
+  build-depends:
+    , base
+    , aeson
+    , log-base
+    , hedgehog
+    , tasty
+    , tasty-hedgehog
+    , tasty-hunit
+    , tasty-discover
+    , text
+  build-tool-depends:
+    tasty-discover:tasty-discover
+  other-modules:
+    LoggerTest

log-base/src/Log/Data.hs

@@ -24,7 +24,7 @@ import qualified Data.Monoid as Monoid
 -- Note that ordering in this definintion determines what the maximum log level is.
 -- See 'Log.Monad.leMaxLogLevel'.
 data LogLevel = LogAttention | LogInfo | LogTrace
-  deriving (Bounded, Eq, Ord, Show)
+  deriving (Bounded, Enum, Eq, Ord, Show)
 
 -- | This function is partial.
 readLogLevel :: T.Text -> LogLevel

log-base/tests/Driver.hs

@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}

log-base/tests/LoggerTest.hs

@@ -0,0 +1,130 @@
+module LoggerTest where
+
+import Control.Concurrent
+import Control.Monad.IO.Class
+import Data.Foldable (for_, traverse_)
+import Data.List
+import qualified Data.Text as T
+import qualified Hedgehog as H
+import qualified Hedgehog.Gen as H
+import qualified Hedgehog.Range as HR
+import Log
+import Log.Internal.Logger
+import Test.Tasty
+import Test.Tasty.Hedgehog
+
+test_logger :: [TestTree]
+test_logger =
+  [ testProperty "Sends all messages in order" $ H.property $ do
+      inorderTest mkTestLogger
+  , testProperty "Drops messages after capacity is reached" $ H.property $ do
+      dropMessagesTest mkTestLogger
+  , testProperty "Obeys log levels" $ H.property $ do
+      inputs <- H.forAll $ H.list (HR.linear 0 1000) (H.int HR.linearBounded)
+      mask <- H.forAll $ H.list (HR.singleton (length inputs)) H.enumBounded
+      let logInputs = zip (fmap (T.pack . show) inputs) mask
+
+      logTrail@LogTrail {..} <- liftIO mkLogTrail
+      logger <- liftIO $ mkTestLogger 1000 logTrail
+      runLogT "test" logger LogInfo $ do
+        for_ logInputs $ \(msg, level) -> do
+          case level of
+            LogAttention -> logAttention_ msg
+            LogInfo -> logInfo_ msg
+            LogTrace -> logTrace_ msg
+
+      liftIO $ loggerWaitForWrite logger
+      let expectedOutput = map fst $ filter ((<= LogInfo) . snd) logInputs
+      let traceOutput = filter ((== LogTrace) . snd) logInputs
+
+      outputs <- liftIO trail
+      expectedOutput H.=== fmap lmMessage (concat outputs)
+      length logInputs - length (concat outputs) H.=== length traceOutput
+  ]
+
+test_bulkLogger :: [TestTree]
+test_bulkLogger =
+  [ testProperty "Sends all messages in order" $ H.property $ do
+      inorderTest $ \cap -> mkBulkTestLogger cap 10_000
+  , testProperty "Drops messages after capacity is reached" $ H.property $ do
+      dropMessagesTest $ \cap -> mkBulkTestLogger cap 10_000
+  , testProperty "Sends all messages in multiple bulks" $ H.property $ do
+      inputs <- H.forAll $ H.list (HR.singleton 70) (H.int HR.linearBounded)
+      bulkSizes <- H.forAll $ H.int (HR.linear 10 40)
+      let logInputs = fmap (T.pack . show) inputs
+
+      logTrail@LogTrail {..} <- liftIO mkLogTrail
+      logger <- liftIO $ mkBulkTestLogger 1000 10_000 logTrail
+      let chunks = chunksOf bulkSizes logInputs
+      for_ chunks $ \chunk -> runLogT "test" logger LogInfo $ do
+        traverse_ logInfo_ chunk
+        liftIO $ loggerWaitForWrite logger
+
+      outputs <- liftIO trail
+      logInputs H.=== fmap lmMessage (concat outputs)
+      (length outputs >= 2) H.=== True
+  ]
+
+inorderTest :: (Monad m, MonadIO m) => (Int -> LogTrail -> IO Logger) -> H.PropertyT m ()
+inorderTest mkTestLog = do
+  inputs <- H.forAll $ H.list (HR.linear 0 100) (H.int HR.linearBounded)
+  let logInputs = fmap (T.pack . show) inputs
+
+  logTrail@LogTrail {..} <- liftIO mkLogTrail
+  logger <- liftIO $ mkTestLog 1000 logTrail
+  liftIO $ runLogT "test" logger LogInfo $ do
+    traverse_ logInfo_ logInputs
+  liftIO $ loggerWaitForWrite logger
+
+  outputs <- liftIO trail
+  logInputs H.=== fmap lmMessage (concat outputs)
+  if null logInputs
+    then length outputs H.=== 0
+    else not (null outputs) H.=== True
+
+dropMessagesTest :: (Monad m, MonadIO m) => (Int -> LogTrail -> IO Logger) -> H.PropertyT m ()
+dropMessagesTest mkTestLog = do
+  let capacity = 10
+  inputs <- H.forAll $ H.list (HR.linear capacity 100) (H.int HR.linearBounded)
+  let logInputs = fmap (T.pack . show) inputs
+
+  logTrail@LogTrail {..} <- liftIO mkLogTrail
+  logger <- liftIO $ mkTestLog 10 logTrail
+  liftIO $ runLogT "test" logger LogInfo $ do
+    traverse_ logInfo_ logInputs
+  liftIO $ loggerWaitForWrite logger
+
+  outputs <- liftIO trail
+  fmap lmMessage (concat outputs) `isSubsequenceOf` logInputs H.=== True
+  (length outputs <= length logInputs) H.=== True
+
+-- | Test utility for tracking the calls the bulk logger makes in the background
+-- grouping logmessages that were sent in the same action.
+data LogTrail = LogTrail
+  { trail :: IO [[LogMessage]]
+  , trailAdd :: [LogMessage] -> IO ()
+  }
+
+mkLogTrail :: IO LogTrail
+mkLogTrail = do
+  logTrailRef <- newMVar []
+  let addLogs new = modifyMVar_ logTrailRef (\logs -> pure (new : logs))
+  pure $
+    LogTrail
+      { trail = reverse <$> swapMVar logTrailRef []
+      , trailAdd = addLogs
+      }
+
+mkBulkTestLogger :: Int -> Int -> LogTrail -> IO Logger
+mkBulkTestLogger capacity delayUSec LogTrail {..} = do
+  mkBulkLogger' capacity delayUSec "testLogger" trailAdd (pure ())
+
+mkTestLogger :: Int -> LogTrail -> IO Logger
+mkTestLogger capacity LogTrail {..} = do
+  mkLogger' capacity "testLogger" (trailAdd . (: []))
+
+-- | Test utility for tracking the calls the bulk logger makes in the background
+-- grouping logmessages that were sent in the same action.
+chunksOf :: Int -> [a] -> [[a]]
+chunksOf _ [] = []
+chunksOf n xs = take n xs : chunksOf n (drop n xs)