WIP. Update to effectful all except App

hibet.cabal

@@ -24,20 +24,15 @@ extra-source-files:
 tested-with:
   , GHC==8.10.7
   , GHC==9.0.2
-  , GHC==9.2.7
+  , GHC==9.2.8
 
 source-repository head
   type:               git
   location:           https://github.com/willbasky/Hibet.git
 
-common common-rdp
-  build-depends:
-      record-dot-preprocessor
-    , record-hasfield
-
-  ghc-options:
-    -fplugin=RecordDotPreprocessor
-
+common common-dot
+  default-extensions:
+    OverloadedRecordDot
 
 common common-options
   build-depends:       base >= 4.11 && < 5
@@ -86,9 +81,9 @@ common common-options
 library
   import:
       common-options
-    , common-rdp
+    , common-dot
   ghc-options:
-                       -fplugin=Polysemy.Plugin
+                       -fplugin=Effectful.Plugin
   hs-source-dirs:      src
   exposed-modules:
                        App
@@ -119,6 +114,12 @@ library
                      , containers
                      , deepseq
                      , directory
+                     , effectful-th
+                     , effectful
+                     , effectful-core
+                     , effectful-plugin
+                     , log-effectful
+                     , resourcet-effectful
                      , extra
                      , filepath
                      , gitrev
@@ -132,9 +133,6 @@ library
                      , parallel
                      , path
                      , path-io
-                     , polysemy
-                     , polysemy-conc
-                     , polysemy-plugin
                      , prettyprinter
                      , prettyprinter-ansi-terminal
                      , radixtree ^>=0.6.0.0
@@ -199,7 +197,7 @@ test-suite hibet-labels
 test-suite hibet-env
   import:
       common-options
-    , common-rdp
+    , common-dot
   type:                exitcode-stdio-1.0
   hs-source-dirs:      test/env
   main-is:             Main.hs
@@ -212,7 +210,6 @@ test-suite hibet-env
                      , bytestring
                      , hspec
                      , containers
-                     , polysemy
                      , text
                      , unordered-containers
                     --  , directory

src/App.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ConstraintKinds #-}
 
 module App
        ( app
@@ -8,68 +9,88 @@ import Cli (parser, runCommand)
 import Effects.Console
 import Effects.File
 import Effects.PrettyPrint
-import Env (Env, makeEnv)
+import Env (Env, makeEnv, putEnvMVar)
 import Type (HibetError (..))
 import Utility (debugEnabledEnvVar)
-
+import Data.Text.IO as TIO
 import Data.Function ((&))
-import IncipitCore (Async, asyncToIOFinal)
-import Polysemy (Embed, Final, Members, Sem, embedToFinal, runFinal)
-import Polysemy.Conc (Race, Sync, interpretRace, interpretSync, withAsync_)
-import Polysemy.Error (Error, runError)
-import Polysemy.Resource (Resource, runResource)
-import Polysemy.Trace (Trace, ignoreTrace, traceToStdout)
+import IncipitCore (Async, asyncToIOFinal, SomeException)
+import System.IO
+
+import Effectful
+import Effectful.Error.Static
+import Effectful.Concurrent
+import Effectful.Reader.Dynamic
+import Effectful.Concurrent.MVar.Strict
+import Effectful.Reader.Dynamic
+import Effectful.Resource
+import Effectful.Log
+import Control.Exception (finally)
+
+-- import Polysemy (Embed, Final, Members, Sem, embedToFinal, runFinal)
+-- import Polysemy.Conc (Race, Sync, interpretRace, interpretSync, withAsync_)
+-- import Polysemy.Error (Error, runError)
+-- import Polysemy.Resource (Resource, runResource)
+-- import Polysemy.Trace (Trace, ignoreTrace, traceToStdout)
 
 
 app :: IO ()
 app = do
+  print ""
   isDebug <- debugEnabledEnvVar
   handleHibetError =<< interpretHibet hibet isDebug
 
-type HibetEffects =
-  [
-    FileIO
-  , Error HibetError
-  , Resource
-  , Console
-  , PrettyPrint
-  , Trace
-  , Sync Env
-  , Race
-  , Async
-  , Embed IO
-  , Final IO
-  ]
+type HibetEffects es =
+  (
+    Resource :> es
+  , Error HibetError :> es
+  , Error SomeException :> es
+  , FileSystem :> es
+  , Console :> es
+  , Reader (MVar Env) :> es
+  , Concurrent :> es
+  , PrettyPrint :> es
+  , Log :> es
+  -- , Race
+  -- , Async
+  -- , Embed IO
+  -- , Final IO
+  )
 
-interpretHibet :: Sem HibetEffects ()
+interpretHibet :: HibetEffects es => Eff es ()
   -> Bool -- isDebug
-  -> IO (Either HibetError ())
-interpretHibet program isDebug = program
-  & runFile
-  & runError @HibetError
-  & runResource
-  & runConsole
-  & runPrettyPrint
-  & (if isDebug then traceToStdout else ignoreTrace)
-  & interpretSync @Env
-  & interpretRace
-  & asyncToIOFinal
-  & embedToFinal
-  & runFinal
+  -> IO (Either (CallStack, HibetError) ())
+interpretHibet program isDebug = withStdOutLogger $ \logger ->
+  program
+    & runResource
+    & runError @HibetError
+    & runFileSystemIO
+    & runConsole
+    & runPrettyPrint
+    & runConcurrent
+    & runLog "hibet" logger defaultLogLevel
+    $ runReader
+    -- & (if isDebug then traceToStdout else ignoreTrace)
+    -- & interpretSync @Env
+    -- & interpretRace
+    -- & asyncToIOFinal
+    -- & embedToFinal
+    & runEff
 
-hibet :: Members HibetEffects r => Sem r ()
+hibet :: HibetEffects es => Eff es ()
 hibet = do
-  withAsync_ prepareEnv $ do
+  -- withAsync_ prepareEnv $ do
+    prepareEnv
     com <- execParser parser
     runCommand com
 
-prepareEnv :: Members
-  [ FileIO
-  , Error HibetError
-  , Trace
-  , Sync Env
-  , Embed IO
-  ] r => Sem r ()
+prepareEnv ::
+  ( FileSystem :> es
+  , Error HibetError :> es
+  , Log :> es
+  , Reader (MVar Env) :> es
+  , IOE :> es
+  ) => Eff es ()
 prepareEnv = do
   !env <- makeEnv
   putEnvMVar env
@@ -78,5 +99,19 @@ handleHibetError :: Either HibetError a -> IO ()
 handleHibetError = \case
   Right _ -> pure ()
   Left err -> do
-    putStrLn "Hibet application failed with exception:"
+    TIO.putStrLn "Hibet application failed with exception:"
     print err
+
+withStdOutLogger :: (Logger -> IO r) -> IO r
+withStdOutLogger act = do
+  logger <- mkLogger "stdout" $ \msg -> do
+    TIO.putStrLn $ showLogMessage Nothing msg
+    hFlush stdout
+  withLogger logger act
+
+withLogger :: Logger -> (Logger -> IO r) -> IO r
+withLogger logger act = act logger `finally` cleanup
+  where
+    cleanup = waitForLogger logger >> shutdownLogger logger
+-- Prevent GHC from inlining this function so its callers are
+{-# NOINLINE withLogger #-}

src/Cli.hs

@@ -8,12 +8,12 @@ module Cli
 
 import Effects.Console
 import Effects.PrettyPrint
-import Env (Env)
+import Env (Env(..), modifyEnv, readEnv)
 import Label (LabelFull (..), Labels (..), Title(unTitle))
 import Paths_hibet (version)
 import Pretty
 import Translator (translator)
-import Type (HibetError (..))
+-- import Type (HibetError (..))
 import Utility (showT)
 import Dictionary (selectDict)
 
@@ -29,14 +29,15 @@ import Options.Applicative (Parser, ParserInfo, auto, command, fullDesc, help, h
                             infoHeader, infoOption, long, metavar, option, progDesc, short,
                             subparser)
 import Options.Applicative.Help.Chunk (stringChunk)
-import Polysemy (Members, Member, Sem)
-import Polysemy.Conc (Sync)
-import qualified Polysemy.Conc.Effect.Sync as Sync
-import Polysemy.Error (Error)
-import Polysemy.Resource (Resource)
 import Prelude hiding (lookup)
 
-import Polysemy.Trace (Trace)
+import Effectful ( type (:>), Eff, IOE )
+import Effectful.Resource ( Resource )
+import Effectful.Log ( Log )
+import Effectful.Reader.Dynamic (Reader)
+import Effectful.Concurrent.MVar.Strict (MVar, Concurrent)
+
+-- import Polysemy.Trace (Trace)
 
 ---------------------------------------------------------------------------
 -- CLI
@@ -54,15 +55,16 @@ data Command
 data Opt = Names | Meta (Maybe Int)
 
 -- | Run 'hibet' with cli command
-runCommand :: Members
-  [ Sync Env
-  , Trace
-  , Resource
-  , PrettyPrint
-  , Console
-  , Error HibetError
-  ] r
-  => Command -> Sem r ()
+runCommand ::
+  ( IOE :> es
+  , Reader (MVar Env) :> es
+  , Concurrent :> es
+  , Log :> es
+  , Resource :> es
+  , PrettyPrint :> es
+  , Console :> es
+  )
+  => Command -> Eff es ()
 runCommand com = do
   case com of
     Shell selectedDicts -> do
@@ -74,17 +76,22 @@ runCommand com = do
       env <- readEnv
       printDebug env.radixWylie
 
-updateEnv :: Member (Sync Env) r
+updateEnv ::
+     ( Reader (MVar Env) :> es
+     , Concurrent :> es
+     )
   => [Int]
-  -> Sem r ()
+  -> Eff es ()
 updateEnv selectedDicts = do
-  env <- Sync.takeBlock
-  let selectedEnv = env{dictionaryMeta
+  modifyEnv $ \env ->
+    pure $ env{dictionaryMeta
         = selectDict selectedDicts env.dictionaryMeta}
-  Sync.putBlock selectedEnv
 
-runShow :: Members [Sync Env, PrettyPrint] r
-  => Opt -> Sem r ()
+runShow ::
+     ( Reader (MVar Env) :> es
+     , Concurrent :> es
+     , PrettyPrint :> es)
+  => Opt -> Eff es ()
 runShow opt = do
   env <- readEnv
   let Labels labels = env.labels