Bump deps

Add a log runner where a syncronizition primitiv can come from the outside.

package.yaml

@@ -1,13 +1,14 @@
-name:                ris-utils
+---
-version:             0.0.1
+name: ris-utils
-homepage:            "https://git.fiskhamn.se/steffenomak/ris-utils#readme"
+version: 0.0.3
-license:             BSD3
+homepage: "https://git.fiskhamn.se/steffenomak/ris-utils#readme"
-author:              "Stefan Risberg"
+license: BSD3
-maintainer:          "steffenomak@gmail.com"
+author: "Stefan Risberg"
-copyright:           "2023 Stefan Risberg"
+maintainer: "steffenomak@gmail.com"
+copyright: "2023 Stefan Risberg"
 
 extra-source-files:
-- README.md
+  - README.md
 
 # Metadata used when publishing your package
 # synopsis:            Short description of your package
@@ -16,33 +17,46 @@ extra-source-files:
 # To avoid duplicated efforts in documentation and dealing with the
 # complications of embedding Haddock markup inside cabal files, it is
 # common to point users to the README.md file.
-description:         Please see the README at <https://git.fiskhamn.se/steffenomak/ris-utils#readme>
+description: Please see the README at <https://git.fiskhamn.se/steffenomak/ris-utils#readme>
 
 dependencies:
-- base >= 4.7 && < 5
+  - base >= 4.7 && < 5
-- text == 1.2.*
+  - text == 2.*
-- effectful-core >= 2.2.2.0 && < 3
+  - effectful-core >= 2.2.2.0 && < 3
-- effectful >= 2.2.2.0 && < 3
+  - effectful >= 2.2.2.0 && < 3
-- effectful-th == 1.*
+  - effectful-th == 1.*
-- chronos >= 1.1.5 && < 2
+  - chronos >= 1.1.5 && < 2
-- torsor == 0.1
+  - torsor == 0.1.*
-- unliftio == 0.2.*
+  - unliftio == 0.2.*
-- co-log-core == 0.3.*
+  - co-log-core == 0.3.*
+  - bytestring == 0.12.*
+  - string-conv == 0.2.*
 
 ghc-options:
-- -Wall
+  - -Wall
-- -Wcompat
+  - -Wcompat
-- -Widentities
+  - -Widentities
-- -Wincomplete-record-updates
+  - -Wincomplete-record-updates
-- -Wincomplete-uni-patterns
+  - -Wincomplete-uni-patterns
-- -Wmissing-export-lists
+  - -Wmissing-export-lists
-- -Wmissing-home-modules
+  - -Wmissing-home-modules
-- -Wpartial-fields
+  - -Wpartial-fields
-- -Wredundant-constraints
+  - -Wredundant-constraints
 
 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

ris-utils.cabal

@@ -1,11 +1,11 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.35.1.
+-- This file has been generated from package.yaml by hpack version 0.38.1.
 --
 -- see: https://github.com/sol/hpack
 
 name:           ris-utils
-version:        0.0.1
+version:        0.0.3
 description:    Please see the README at <https://git.fiskhamn.se/steffenomak/ris-utils#readme>
 homepage:       https://git.fiskhamn.se/steffenomak/ris-utils#readme
 author:         Stefan Risberg
@@ -56,12 +56,65 @@ library
   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.*
     , 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.*
-    , text ==1.2.*
+    , string-conv ==0.2.*
-    , torsor ==0.1
+    , text ==2.*
+    , 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.12.*
+    , 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

src/Effects/Log.hs

@@ -1,22 +1,24 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE PatternSynonyms #-}
 
 module Effects.Log (
-  Severity (..),
+  Severity (.., I, D, W, E),
-  runLogEff,
+  runLog,
+  runLogWithQsem,
   stderrLogger,
   fmtMessage,
   addTime,
   Log,
   log,
-  pattern I,
-  pattern D,
-  pattern W,
-  pattern E,
   LogData (..),
+  ls,
 ) where
 
 import Colog.Core
-import Data.Text (Text, justifyLeft)
+import Data.String (IsString (..))
+import Data.String.Conv
+import Data.Text (Text)
 import Data.Text qualified as T
 import Data.Text.IO qualified as T
 import Data.Text.Lazy qualified as LT
@@ -33,60 +35,75 @@ import Prelude hiding (log)
 
 import Terminal
 
-class Monoid a => LogData a where
+newtype LogData = LogData T.Builder
-  toLog :: a -> T.Builder
+  deriving newtype (IsString)
-
+  deriving newtype (Semigroup)
-instance LogData T.Builder where
+  deriving newtype (Monoid)
-  toLog = id
-
-instance LogData Text where
-  toLog = T.fromText
-
-instance LogData String where
-  toLog = T.fromString
 
 data Log :: Effect where
-  Log :: Severity -> T.Builder -> Log m ()
+  Log :: Severity -> LogData -> Log m ()
 
 makeEffect ''Log
 
-runLogEff ::
+runLog ::
   (Time :> es, Concurrent :> es, IOE :> es) =>
-  LogAction IO T.Builder ->
+  LogAction IO LogData ->
   Eff (Log : es) a ->
   Eff es a
-runLogEff logger e = do
+runLog logger e = do
   lock <- newQSem 1
+  runLogWithQsem lock logger e
 
+runLogWithQsem ::
+  (Time :> es, Concurrent :> es, IOE :> es) =>
+  QSem ->
+  LogAction IO LogData ->
+  Eff (Log : es) a ->
+  Eff es a
+runLogWithQsem lock logger e = do
   reinterpret
     (runReader lock)
     ( \_ -> \case
         Log sev msg -> do
-          l <- ask
+          lock' <- ask
-          bracket_ (waitQSem l) (signalQSem l) $ do
+          bracket_ (waitQSem lock') (signalQSem lock') $ do
-            t <- currentTimeB
+            t <- LogData <$> currentTimeB
             liftIO $ cmap (addTime t . fmtMessage) logger <& msg `WithSeverity` sev
     )
     e
 
 stderrLogger ::
   (MonadIO m) =>
-  LogAction m T.Builder
+  LogAction m LogData
-stderrLogger = LogAction (liftIO . T.hPutStrLn stderr . LT.toStrict . T.toLazyText)
+stderrLogger =
+  LogAction
+    ( \(LogData d) ->
+        liftIO . T.hPutStrLn stderr . LT.toStrict . T.toLazyText $ d
+    )
 
-fmtMessage :: WithSeverity T.Builder -> T.Builder
+fmtMessage :: WithSeverity LogData -> LogData
-fmtMessage (WithSeverity txt sev) = "[" <> T.fromText (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 W = colorNormal Red . tshow $ W
+  colorSev I = colorNormal Green . tshow $ I
+  colorSev W = colorNormal Yellow . tshow $ W
+  colorSev E = colorNormal Red . tshow $ E
   colorSev a = tshow a
 
 addTime ::
-  T.Builder ->
+  LogData ->
-  T.Builder ->
+  LogData ->
-  T.Builder
+  LogData
-addTime t msg = (" [" :: T.Builder) <> t <> ("] " :: T.Builder) <> toLog msg
+addTime t msg = " [" <> t <> "] " <> msg
 
 --- Helpers
-tshow :: Show a => a -> Text
+tshow :: (Show a) => a -> Text
 tshow = T.pack . show
+
+logStr :: (StringConv a Text) => a -> LogData
+logStr t = LogData (T.fromText $ toS t)
+
+ls :: (StringConv a Text) => a -> LogData
+ls = logStr

src/Effects/Time.hs

@@ -2,6 +2,7 @@ module Effects.Time (
   currentTime,
   currentTimeB,
   currentTimeT,
+  benchFunction,
   runTimeEff,
   Time,
 )
@@ -19,14 +20,30 @@ data Time :: Effect where
   CurrentTime :: Time m C.Time
   CurrentTimeB :: Time m T.Builder
   CurrentTimeT :: Time m Text
+  BenchFunction :: m a -> Time m (Timespan, a)
 
-makeEffect ''Time
+makeEffect_ ''Time
+
+currentTime ::
+  Time :> es =>
+  -- | Returns current time
+  Eff es C.Time
+
+currentTimeB ::
+  Time :> es =>
+  -- | Returns current time
+  Eff es T.Builder
+
+currentTimeT ::
+  Time :> es =>
+  -- | Returns current time
+  Eff es Text
 
 runTimeEff ::
   (IOE :> es) =>
   Eff (Time : es) a ->
   Eff es a
-runTimeEff = interpret $ \_ -> \case
+runTimeEff = interpret $ \env -> \case
   CurrentTime -> liftIO now
   CurrentTimeB ->
     builder_YmdHMS (SubsecondPrecisionFixed 4) w3c . timeToDatetime
@@ -34,3 +51,4 @@ runTimeEff = interpret $ \_ -> \case
   CurrentTimeT ->
     encode_YmdHMS (SubsecondPrecisionFixed 4) w3c . timeToDatetime
       <$> liftIO now
+  BenchFunction f -> localSeqUnliftIO env $ \run -> stopwatch . run $ f

stack.yaml

@@ -17,8 +17,7 @@
 #
 # resolver: ./custom-snapshot.yaml
 # resolver: https://example.com/snapshots/2018-01-01.yaml
-resolver: lts-20.16
+snapshot: lts-24.11
-
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.
@@ -30,13 +29,12 @@ resolver: lts-20.16
 #   - auto-update
 #   - wai
 packages:
-- .
+  - .
 # Dependency packages to be pulled from upstream that are not in the resolver.
 # These entries can reference officially published versions as well as
 # forks / in-progress versions pinned to a git hash. For example:
 #
 extra-deps:
-  - chronos-1.1.5
 # - acme-missiles-0.3
 # - git: https://github.com/commercialhaskell/stack.git
 #   commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a

stack.yaml.lock

@@ -1,19 +1,12 @@
 # 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/lock_files
+#   https://docs.haskellstack.org/en/stable/topics/lock_files
 
-packages:
+packages: []
-- completed:
-    hackage: chronos-1.1.5@sha256:ca35be5fdbbb384414226b4467c6d1c8b44defe59a9c8a3af32c1c5fb250c781,3830
-    pantry-tree:
-      sha256: 329bf39a05362a9c1f507a4a529725c757208843b562c55e0b7c88538dc3160f
-      size: 581
-  original:
-    hackage: chronos-1.1.5
 snapshots:
 - completed:
-    sha256: dad15e2ec0c09280a5c2e07190fb18710fc54472f029f34f861f686540824d81
+    sha256: 468e1afa06cd069e57554f10e84fdf1ac5e8893e3eefc503ef837e2449f7e60c
-    size: 649592
+    size: 726310
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/16.yaml
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/24/11.yaml
-  original: lts-20.16
+  original: lts-24.11

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