Code now uses `effectful` to manage side-effects

3 files changed, 155 insertions, 0 deletions

diff --git a/hsm-repl/Hsm/Repl.hs b/hsm-repl/Hsm/Repl.hs
new file mode 100644
index 0000000..5265e59
--- /dev/null
+++ b/hsm-repl/Hsm/Repl.hs
@@ -0,0 +1,104 @@
+{-# LANGUAGE TypeFamilies #-}
+
+module Hsm.Repl
+  ( Repl
+  , repl
+  , runRepl
+  )
+where
+
+import Control.Monad (forM_)
+import Data.Typeable (Proxy (Proxy), Typeable, typeRep)
+import Effectful (Dispatch (Static), DispatchOf, Eff, IOE, liftIO, (:>))
+import Effectful.Dispatch.Static
+  ( SideEffects (WithSideEffects)
+  , StaticRep
+  , evalStaticRep
+  , getStaticRep
+  , unsafeEff_
+  )
+import Effectful.Resource (Resource, allocateEff)
+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
+import Generic.Data.Function.Common.Generic.Meta (KnownSymbols, symbolVals)
+import Hsm.Log (Log, Severity (Attention, Info, Trace), logMsg)
+import Language.Haskell.Interpreter
+  ( GhcError (errMsg)
+  , InterpreterError (WontCompile)
+  , as
+  , interpret
+  , runInterpreter
+  , setImports
+  )
+import System.Console.Haskeline
+  ( defaultSettings
+  , getInputLine
+  , handleInterrupt
+  , withInterrupt
+  )
+import System.Console.Haskeline.IO
+  ( InputState
+  , cancelInput
+  , initializeInput
+  , queryInput
+  )
+
+data Repl (p :: Symbol) (ms :: [Symbol]) (t :: *) (a :: * -> *) (b :: *)
+
+type instance DispatchOf (Repl p ms t) = Static WithSideEffects
+
+newtype instance StaticRep (Repl p ms t)
+  = Repl InputState
+
+repl
+  :: forall p ms t es
+   . ( KnownSymbol p
+     , KnownSymbols ms
+     , Log "repl" :> es
+     , Repl p ms t :> es
+     , Show t
+     , Typeable t
+     )
+  => Eff es (Maybe t)
+repl = query >>= maybe (return Nothing) parse
+  where
+    query = do
+      Repl inputState <- getStaticRep
+      logMsg Trace $ "Expecting a value of type: " <> show (typeRep $ Proxy @t)
+      unsafeEff_
+        . queryInput inputState
+        . handleInterrupt (return Nothing)
+        . withInterrupt
+        . getInputLine
+        $ symbolVal (Proxy @p)
+    parse string = do
+      logMsg Trace $ "Parsing string: " <> string
+      eitherValue <-
+        unsafeEff_ . runInterpreter $ do
+          setImports $ symbolVals @ms
+          interpret string as
+      case eitherValue of
+        Right value -> do
+          logMsg Trace $ "Parsed value: " <> show value
+          return $ Just value
+        Left (WontCompile errors) -> do
+          forM_ errors $ logMsg Attention . errMsg
+          repl
+        Left err -> do
+          logMsg Attention $ show err
+          repl
+
+runRepl
+  :: forall p ms t es a
+   . (IOE :> es, Log "repl" :> es, Resource :> es)
+  => Eff (Repl p ms t : es) a
+  -> Eff es a
+runRepl action = do
+  inputState <- snd <$> allocateEff inputStateAlloc inputStateDealloc
+  evalStaticRep (Repl inputState) action
+  where
+    inputStateAlloc = do
+      logMsg Info "Initializing input"
+      liftIO $ initializeInput defaultSettings
+    inputStateDealloc inputState = do
+      logMsg Info "Cancelling input"
+      liftIO $ cancelInput inputState
diff --git a/hsm-repl/Test/Repl.hs b/hsm-repl/Test/Repl.hs
new file mode 100644
index 0000000..9052ef1
--- /dev/null
+++ b/hsm-repl/Test/Repl.hs
@@ -0,0 +1,15 @@
+import Control.Monad (void)
+import Control.Monad.Loops (whileJust_)
+import Data.Function ((&))
+import Effectful (runEff)
+import Effectful.Resource (runResource)
+import Hsm.Log (Severity (Trace), runLog)
+import Hsm.Repl (repl, runRepl)
+
+main :: IO ()
+main =
+  void (whileJust_ repl return)
+    & runRepl @"exec-repl λ " @'["Prelude"] @[Bool]
+    & runLog @"repl" Trace
+    & runResource
+    & runEff
diff --git a/hsm-repl/hsm-repl.cabal b/hsm-repl/hsm-repl.cabal
new file mode 100644
index 0000000..fd346f9
--- /dev/null
+++ b/hsm-repl/hsm-repl.cabal
@@ -0,0 +1,36 @@
+cabal-version: 3.8
+author:        Paul Oliver
+build-type:    Simple
+maintainer:    contact@pauloliver.dev
+name:          hsm-repl
+version:       0.1.0.0
+
+common common
+  build-depends:
+    , base
+    , effectful-core
+    , effectful-plugin
+    , generic-data-functions
+    , haskeline
+    , hint
+    , hsm-log
+    , resourcet-effectful
+
+  default-language:   GHC2024
+  ghc-options:
+    -O2 -Wall -Werror -Wno-star-is-type -Wunused-packages
+    -fplugin=Effectful.Plugin
+
+library
+  import:          common
+  exposed-modules: Hsm.Repl
+
+executable test-repl
+  import:        common
+  build-depends: monad-loops
+
+  if !arch(x86_64)
+    ghc-options: -optl=-mno-fix-cortex-a53-835769
+
+  main-is:       Test/Repl.hs
+  other-modules: Hsm.Repl