From d522dbaf4f63b3ad9cf713087f37c1bd07e5a990 Mon Sep 17 00:00:00 2001
From: Stefan Risberg <steffenomak@gmail.com>
Date: Fri, 1 Nov 2024 22:12:37 +0100
Subject: [PATCH] Fix offset of severity

---
 package.yaml       | 11 ++++++++++
 ris-utils.cabal    | 51 ++++++++++++++++++++++++++++++++++++++++++++++
 src/Effects/Log.hs |  9 +++++---
 tests/Spec.hs      | 18 ++++++++++++++++
 4 files changed, 86 insertions(+), 3 deletions(-)
 create mode 100644 tests/Spec.hs

diff --git a/package.yaml b/package.yaml
index eb8db7f..cce7bb9 100644
--- a/package.yaml
+++ b/package.yaml
@@ -46,6 +46,17 @@ ghc-options:
 library:
   source-dirs: src
 
+tests:
+  ris-utils-test:
+    main: Spec.hs
+    source-dirs: tests
+    ghc-options:
+      - -threaded
+      - -rtsopts
+      - -with-rtsopts=-N
+    dependencies:
+      - ris-utils
+
 default-extensions:
   - BangPatterns
   - BlockArguments
diff --git a/ris-utils.cabal b/ris-utils.cabal
index cae2dfd..422f2f3 100644
--- a/ris-utils.cabal
+++ b/ris-utils.cabal
@@ -67,3 +67,54 @@ library
     , torsor ==0.1.*
     , unliftio ==0.2.*
   default-language: Haskell2010
+
+test-suite ris-utils-test
+  type: exitcode-stdio-1.0
+  main-is: Spec.hs
+  other-modules:
+      Paths_ris_utils
+  hs-source-dirs:
+      tests
+  default-extensions:
+      BangPatterns
+      BlockArguments
+      ConstraintKinds
+      DataKinds
+      DeriveAnyClass
+      DeriveGeneric
+      DuplicateRecordFields
+      FlexibleContexts
+      FlexibleInstances
+      GADTs
+      LambdaCase
+      MultiParamTypeClasses
+      OverloadedLabels
+      OverloadedStrings
+      PolyKinds
+      QuasiQuotes
+      RankNTypes
+      ScopedTypeVariables
+      TemplateHaskell
+      TupleSections
+      TypeApplications
+      TypeFamilies
+      TypeOperators
+      UndecidableInstances
+      StandaloneDeriving
+      ImportQualifiedPost
+      LambdaCase
+  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.11.*
+    , chronos >=1.1.5 && <2
+    , co-log-core ==0.3.*
+    , effectful >=2.2.2.0 && <3
+    , effectful-core >=2.2.2.0 && <3
+    , effectful-th ==1.*
+    , ris-utils
+    , string-conv ==0.2.*
+    , text ==2.*
+    , torsor ==0.1.*
+    , unliftio ==0.2.*
+  default-language: Haskell2010
diff --git a/src/Effects/Log.hs b/src/Effects/Log.hs
index cd81e71..34cbcbb 100644
--- a/src/Effects/Log.hs
+++ b/src/Effects/Log.hs
@@ -18,7 +18,7 @@ module Effects.Log (
 import Colog.Core
 import Data.String (IsString (..))
 import Data.String.Conv
-import Data.Text (Text, justifyLeft)
+import Data.Text (Text)
 import Data.Text qualified as T
 import Data.Text.IO qualified as T
 import Data.Text.Lazy qualified as LT
@@ -82,11 +82,14 @@ stderrLogger =
     )
 
 fmtMessage :: WithSeverity LogData -> LogData
-fmtMessage (WithSeverity txt sev) = "[" <> ls (justifyLeft 7 ' ' (colorSev sev)) <> "] - " <> txt
+fmtMessage (WithSeverity txt sev) =
+  let sp = T.pack $ replicate (7 - length (show sev)) ' '
+   in "[" <> ls (colorSev sev <> sp) <> "] - " <> txt
  where
   colorSev :: Severity -> Text
+  colorSev I = colorNormal Green . tshow $ I
   colorSev W = colorNormal Yellow . tshow $ W
-  colorSev E = colorBright Red . tshow $ E
+  colorSev E = colorNormal Red . tshow $ E
   colorSev a = tshow a
 
 addTime ::
diff --git a/tests/Spec.hs b/tests/Spec.hs
new file mode 100644
index 0000000..7178156
--- /dev/null
+++ b/tests/Spec.hs
@@ -0,0 +1,18 @@
+import Colog.Core
+import Data.Text qualified as T
+import Data.Text.Lazy qualified as LT
+import Data.Text.Lazy.Builder qualified as T
+import Effects.Log
+
+gen :: String -> Severity -> String
+gen str sev =
+  let (LogData d) = fmtMessage $ ls (T.pack str) `WithSeverity` sev
+   in T.unpack . LT.toStrict . T.toLazyText $ d
+
+main :: IO ()
+main = do
+  putStrLn " "
+  putStrLn $ gen "Test debug" D
+  putStrLn $ gen "Test info" I
+  putStrLn $ gen "Test warn" W
+  putStrLn $ gen "Test error" E