1 files changed, 104 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