From cc639b06c7126fac7b445d8f778455620d7f8f50 Mon Sep 17 00:00:00 2001
From: Paul Oliver <contact@pauloliver.dev>
Date: Sun, 29 Dec 2024 17:05:34 +0000
Subject: Initial

---
 hsm-command/Hsm/Command/Readline.hs | 51 +++++++++++++++++++++++++++++++++++++
 1 file changed, 51 insertions(+)
 create mode 100644 hsm-command/Hsm/Command/Readline.hs

(limited to 'hsm-command/Hsm/Command/Readline.hs')

diff --git a/hsm-command/Hsm/Command/Readline.hs b/hsm-command/Hsm/Command/Readline.hs
new file mode 100644
index 0000000..3c56453
--- /dev/null
+++ b/hsm-command/Hsm/Command/Readline.hs
@@ -0,0 +1,51 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Hsm.Command.Readline
+  ( Readline
+  , readline
+  , runReadline
+  ) where
+
+import Effectful (Dispatch(Static), DispatchOf, Eff, IOE, (:>))
+import Effectful.Dispatch.Static qualified as S
+import Effectful.Log (Log, getLoggerEnv, leLogger, waitForLogger)
+import Effectful.Resource (Resource, allocate)
+import System.Console.Haskeline qualified as H
+import System.Console.Haskeline.IO qualified as H
+
+data Readline a b
+
+type instance DispatchOf Readline = Static S.WithSideEffects
+
+newtype instance S.StaticRep Readline =
+  Readline H.InputState
+
+readline ::
+     forall es. (Log :> es, Readline :> es)
+  => Eff es (Maybe String)
+readline = do
+  flushLogger
+  Readline hdl <- S.getStaticRep
+  S.unsafeEff_ $ nextLine hdl
+  where
+    flushLogger :: Eff es ()
+    flushLogger = getLoggerEnv >>= S.unsafeEff_ . waitForLogger . leLogger
+    --
+    nextLine :: H.InputState -> IO (Maybe String)
+    nextLine hdl =
+      H.queryInput hdl
+        $ H.handleInterrupt (return Nothing)
+        $ H.withInterrupt
+        $ H.getInputLine "% "
+
+runReadline :: (IOE :> es, Resource :> es) => Eff (Readline : es) a -> Eff es a
+runReadline action = do
+  handle <- snd <$> allocate istate H.cancelInput
+  S.evalStaticRep (Readline handle) action
+  where
+    settings :: H.Settings IO
+    settings = H.defaultSettings {H.historyFile = Just ".hsm_command_history"}
+    --
+    istate :: IO H.InputState
+    istate = H.initializeInput settings
-- 
cgit v1.2.1