Convert Log into a dynamically dispatched effect (#10)

haskell-effectful · Jun 6, 2024 · dc19784 · dc19784
1 parent 1f58990
commit dc19784
Show file tree

Hide file tree

Showing 4 changed files with 81 additions and 90 deletions.
diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml
@@ -8,9 +8,9 @@
 #
 # For more information, see https://github.com/haskell-CI/haskell-ci
 #
-# version: 0.17.20231010
+# version: 0.19.20240514
 #
-# REGENDATA ("0.17.20231010",["github","--config=cabal.haskell-ci","cabal.project"])
+# REGENDATA ("0.19.20240514",["github","--config=cabal.haskell-ci","cabal.project"])
 #
 name: Haskell-CI
 on:
@@ -27,24 +27,29 @@ jobs:
     timeout-minutes:
       60
     container:
-      image: buildpack-deps:bionic
+      image: buildpack-deps:jammy
     continue-on-error: ${{ matrix.allow-failure }}
     strategy:
       matrix:
         include:
-          - compiler: ghc-9.8.1
+          - compiler: ghc-9.10.1
             compilerKind: ghc
-            compilerVersion: 9.8.1
+            compilerVersion: 9.10.1
             setup-method: ghcup
             allow-failure: false
-          - compiler: ghc-9.6.3
+          - compiler: ghc-9.8.2
             compilerKind: ghc
-            compilerVersion: 9.6.3
+            compilerVersion: 9.8.2
             setup-method: ghcup
             allow-failure: false
-          - compiler: ghc-9.4.7
+          - compiler: ghc-9.6.5
             compilerKind: ghc
-            compilerVersion: 9.4.7
+            compilerVersion: 9.6.5
+            setup-method: ghcup
+            allow-failure: false
+          - compiler: ghc-9.4.8
+            compilerKind: ghc
+            compilerVersion: 9.4.8
             setup-method: ghcup
             allow-failure: false
           - compiler: ghc-9.2.8
@@ -62,32 +67,17 @@ jobs:
             compilerVersion: 8.10.7
             setup-method: ghcup
             allow-failure: false
-          - compiler: ghc-8.8.4
-            compilerKind: ghc
-            compilerVersion: 8.8.4
-            setup-method: hvr-ppa
-            allow-failure: false
       fail-fast: false
     steps:
       - name: apt
         run: |
           apt-get update
           apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5
-          if [ "${{ matrix.setup-method }}" = ghcup ]; then
-            mkdir -p "$HOME/.ghcup/bin"
-            curl -sL https://downloads.haskell.org/ghcup/0.1.19.5/x86_64-linux-ghcup-0.1.19.5 > "$HOME/.ghcup/bin/ghcup"
-            chmod a+x "$HOME/.ghcup/bin/ghcup"
-            "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false)
-            "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
-          else
-            apt-add-repository -y 'ppa:hvr/ghc'
-            apt-get update
-            apt-get install -y "$HCNAME"
-            mkdir -p "$HOME/.ghcup/bin"
-            curl -sL https://downloads.haskell.org/ghcup/0.1.19.5/x86_64-linux-ghcup-0.1.19.5 > "$HOME/.ghcup/bin/ghcup"
-            chmod a+x "$HOME/.ghcup/bin/ghcup"
-            "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
-          fi
+          mkdir -p "$HOME/.ghcup/bin"
+          curl -sL https://downloads.haskell.org/ghcup/0.1.20.0/x86_64-linux-ghcup-0.1.20.0 > "$HOME/.ghcup/bin/ghcup"
+          chmod a+x "$HOME/.ghcup/bin/ghcup"
+          "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false)
+          "$HOME/.ghcup/bin/ghcup" install cabal 3.10.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
         env:
           HCKIND: ${{ matrix.compilerKind }}
           HCNAME: ${{ matrix.compiler }}
@@ -99,22 +89,13 @@ jobs:
           echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV"
           echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV"
           HCDIR=/opt/$HCKIND/$HCVER
-          if [ "${{ matrix.setup-method }}" = ghcup ]; then
-            HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER")
-            HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#')
-            HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#')
-            echo "HC=$HC" >> "$GITHUB_ENV"
-            echo "HCPKG=$HCPKG" >> "$GITHUB_ENV"
-            echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV"
-            echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV"
-          else
-            HC=$HCDIR/bin/$HCKIND
-            echo "HC=$HC" >> "$GITHUB_ENV"
-            echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV"
-            echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV"
-            echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV"
-          fi
-
+          HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER")
+          HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#')
+          HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#')
+          echo "HC=$HC" >> "$GITHUB_ENV"
+          echo "HCPKG=$HCPKG" >> "$GITHUB_ENV"
+          echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV"
+          echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"
           HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')
           echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV"
           echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV"
@@ -162,9 +143,9 @@ jobs:
         run: |
           $CABAL v2-update -v
       - name: cache (tools)
-        uses: actions/cache/restore@v3
+        uses: actions/cache/restore@v4
         with:
-          key: ${{ runner.os }}-${{ matrix.compiler }}-tools-0f8d33a5
+          key: ${{ runner.os }}-${{ matrix.compiler }}-tools-655fd156
           path: ~/.haskell-ci-tools
       - name: install cabal-plan
         run: |
@@ -177,16 +158,16 @@ jobs:
           cabal-plan --version
       - name: install doctest
         run: |
-          $CABAL --store-dir=$HOME/.haskell-ci-tools/store v2-install $ARG_COMPILER --ignore-project -j2 doctest --constraint='doctest ^>=0.22'
-          doctest --version
+          if [ $((HCNUMVER < 91000)) -ne 0 ] ; then $CABAL --store-dir=$HOME/.haskell-ci-tools/store v2-install $ARG_COMPILER --ignore-project -j2 doctest --constraint='doctest ^>=0.22.0' ; fi
+          if [ $((HCNUMVER < 91000)) -ne 0 ] ; then doctest --version ; fi
       - name: save cache (tools)
-        uses: actions/cache/save@v3
+        uses: actions/cache/save@v4
         if: always()
         with:
-          key: ${{ runner.os }}-${{ matrix.compiler }}-tools-0f8d33a5
+          key: ${{ runner.os }}-${{ matrix.compiler }}-tools-655fd156
           path: ~/.haskell-ci-tools
       - name: checkout
-        uses: actions/checkout@v3
+        uses: actions/checkout@v4
         with:
           path: source
       - name: initial cabal.project for sdist
@@ -214,15 +195,15 @@ jobs:
           echo "    ghc-options: -Werror=missing-methods" >> cabal.project
           cat >> cabal.project <<EOF
           EOF
-          $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: $_ installed\n" unless /^(log-effectful)$/; }' >> cabal.project.local
+          $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(log-effectful)$/; }' >> cabal.project.local
           cat cabal.project
           cat cabal.project.local
       - name: dump install plan
         run: |
           $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all
           cabal-plan
       - name: restore cache
-        uses: actions/cache/restore@v3
+        uses: actions/cache/restore@v4
         with:
           key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }}
           path: ~/.cabal/store
@@ -242,8 +223,8 @@ jobs:
           $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct
       - name: doctest
         run: |
-          cd ${PKGDIR_log_effectful} || false
-          doctest  -XHaskell2010 -XBangPatterns -XConstraintKinds -XDataKinds -XDeriveFunctor -XDeriveGeneric -XDerivingStrategies -XFlexibleContexts -XFlexibleInstances -XGADTs -XGeneralizedNewtypeDeriving -XLambdaCase -XMultiParamTypeClasses -XNoStarIsType -XRankNTypes -XRoleAnnotations -XScopedTypeVariables -XStandaloneDeriving -XTupleSections -XTypeApplications -XTypeFamilies -XTypeOperators src
+          if [ $((HCNUMVER < 91000)) -ne 0 ] ; then cd ${PKGDIR_log_effectful} || false ; fi
+          if [ $((HCNUMVER < 91000)) -ne 0 ] ; then doctest  -XHaskell2010 -XBangPatterns -XConstraintKinds -XDataKinds -XDeriveFunctor -XDeriveGeneric -XDerivingStrategies -XFlexibleContexts -XFlexibleInstances -XGADTs -XGeneralizedNewtypeDeriving -XLambdaCase -XMultiParamTypeClasses -XNoStarIsType -XRankNTypes -XRoleAnnotations -XScopedTypeVariables -XStandaloneDeriving -XTupleSections -XTypeApplications -XTypeFamilies -XTypeOperators src ; fi
       - name: cabal check
         run: |
           cd ${PKGDIR_log_effectful} || false
@@ -256,7 +237,7 @@ jobs:
           rm -f cabal.project.local
           $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all
       - name: save cache
-        uses: actions/cache/save@v3
+        uses: actions/cache/save@v4
         if: always()
         with:
           key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }}

diff --git a/CHANGELOG.md b/CHANGELOG.md
@@ -1,2 +1,5 @@
+# log-effectful-1.0.1.0 (2024-??-??)
+* Convert `Log` into a dynamically dispatched effect.
+
 # log-effectful-1.0.0.0 (2022-10-10)
 * Initial release.
diff --git a/log-effectful.cabal b/log-effectful.cabal
@@ -1,7 +1,7 @@
-cabal-version:      2.4
+cabal-version:      3.0
 build-type:         Simple
 name:               log-effectful
-version:            1.0.0.0
+version:            1.0.1.0
 license:            BSD-3-Clause
 license-file:       LICENSE
 category:           System
@@ -16,8 +16,7 @@ extra-source-files:
   CHANGELOG.md
   README.md
 
-tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.7 || ==9.6.3
-              || ==9.8.1
+tested-with: GHC == { 8.10.7, 9.0.2, 9.2.8, 9.4.8, 9.6.5, 9.8.2, 9.10.1 }
 
 bug-reports: https://github.com/haskell-effectful/log-effectful/issues
 source-repository head
@@ -55,6 +54,7 @@ library
   import:          language
 
   build-depends:     base            <5
+                   , aeson           >=2.0.0.0
                    , effectful-core  >=1.0.0.0    && <3.0.0.0
                    , log-base        >=0.12.0.0
                    , text

diff --git a/src/Effectful/Log.hs b/src/Effectful/Log.hs
@@ -3,7 +3,7 @@
 -- | Logging via 'MonadLog'.
 module Effectful.Log
   ( -- * Effect
-    Log
+    Log (..)
 
     -- ** Handlers
   , runLog
@@ -12,17 +12,23 @@ module Effectful.Log
   , module Log
   ) where
 
+import Data.Aeson.Types
 import Data.Text (Text)
 import Data.Time.Clock
-import Effectful.Dispatch.Static
+import Effectful.Dispatch.Dynamic
+import Effectful.Reader.Static
 import Effectful
 import Log
 
 -- | Provide the ability to log messages via 'MonadLog'.
-data Log :: Effect
+data Log :: Effect where
+  LogMessageOp :: LogLevel -> Text -> Value -> Log m ()
+  LocalData :: [Pair] -> m a -> Log m a
+  LocalDomain :: Text -> m a -> Log m a
+  LocalMaxLogLevel :: LogLevel -> m a -> Log m a
+  GetLoggerEnv :: Log m LoggerEnv
 
-type instance DispatchOf Log = Static WithSideEffects
-newtype instance StaticRep Log = Log LoggerEnv
+type instance DispatchOf Log = Dynamic
 
 -- | Run the 'Log' effect.
 --
@@ -38,30 +44,31 @@ runLog
   -> Eff (Log : es) a
   -- ^ The computation to run.
   -> Eff es a
-runLog component logger maxLogLevel = evalStaticRep $ Log LoggerEnv
-  { leLogger = logger
-  , leComponent = component
-  , leDomain = []
-  , leData = []
-  , leMaxLogLevel = maxLogLevel
-  }
+runLog component logger maxLogLevel = reinterpret reader $ \env -> \case
+  LogMessageOp level message data_ -> do
+    time <- liftIO getCurrentTime
+    logEnv <- ask
+    liftIO $ logMessageIO logEnv time level message data_
+  LocalData data_ action -> localSeqUnlift env $ \unlift -> do
+    (`local` unlift action) $ \logEnv -> logEnv { leData = data_ ++ leData logEnv }
+  LocalDomain domain action -> localSeqUnlift env $ \unlift -> do
+    (`local` unlift action) $ \logEnv -> logEnv { leDomain = leDomain logEnv ++ [domain] }
+  LocalMaxLogLevel level action -> localSeqUnlift env $ \unlift -> do
+    (`local` unlift action) $ \logEnv -> logEnv { leMaxLogLevel = level }
+  GetLoggerEnv -> ask
+  where
+    reader = runReader LoggerEnv
+      { leLogger = logger
+      , leComponent = component
+      , leDomain = []
+      , leData = []
+      , leMaxLogLevel = maxLogLevel
+      }
 
 -- | Orphan, canonical instance.
 instance Log :> es => MonadLog (Eff es) where
-  logMessage level message data_ = do
-    time <- unsafeEff_ getCurrentTime
-    Log logEnv <- getStaticRep
-    unsafeEff_ $ logMessageIO logEnv time level message data_
-
-  localData data_ = localStaticRep $ \(Log logEnv) ->
-    Log logEnv { leData = data_ ++ leData logEnv }
-
-  localDomain domain = localStaticRep $ \(Log logEnv) ->
-    Log logEnv { leDomain = leDomain logEnv ++ [domain] }
-
-  localMaxLogLevel level = localStaticRep $ \(Log logEnv) ->
-    Log logEnv { leMaxLogLevel = level }
-
-  getLoggerEnv = do
-    Log env <- getStaticRep
-    pure env
+  logMessage level message data_ = send $ LogMessageOp level message data_
+  localData data_ action = send $ LocalData data_ action
+  localDomain domain action = send $ LocalDomain domain action
+  localMaxLogLevel level action = send $ LocalMaxLogLevel level action
+  getLoggerEnv = send GetLoggerEnv