InitialHEADmaster

1 files changed, 50 insertions, 0 deletions

diff --git a/hsm-readline/Hsm/Readline.hs b/hsm-readline/Hsm/Readline.hs
new file mode 100644
index 0000000..8a0c232
--- /dev/null
+++ b/hsm-readline/Hsm/Readline.hs
@@ -0,0 +1,50 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Hsm.Readline
+  ( readline
+  , allocateReadline
+  ) where
+
+import Control.IO.Region (Region, alloc_)
+import Data.Text (Text, pack)
+import Data.Typeable (Proxy(Proxy), Typeable, typeRep)
+import Hsm.Log qualified as L
+import System.Console.Haskeline qualified as H
+import System.Console.Haskeline.IO qualified as H
+import Text.Read (readEither)
+
+logMsg :: Text -> IO ()
+logMsg = L.logMsg ["readline"]
+
+readline ::
+     forall a. (Read a, Show a, Typeable a)
+  => H.InputState
+  -> IO (Maybe a)
+readline handle = do
+  logMsg $ "Expecting value of type " <> pack (show $ typeRep $ Proxy @a)
+  valueMaybe <- queryInput
+  maybe (return Nothing) parseValueStr valueMaybe
+  where
+    queryInput =
+      H.queryInput handle
+        $ H.handleInterrupt (return Nothing)
+        $ H.withInterrupt
+        $ H.getInputLine "% "
+    parseValueStr valueStr =
+      case readEither @a valueStr of
+        Right commandValue -> do
+          logMsg $ "Parsed value " <> pack (show commandValue)
+          return $ Just commandValue
+        Left err -> do
+          logMsg $ pack err
+          readline handle
+
+allocateReadline :: Region -> IO H.InputState
+allocateReadline region = alloc_ region initializeInput cancelInput
+  where
+    initializeInput = do
+      logMsg "Initializing input with default settings"
+      H.initializeInput H.defaultSettings
+    cancelInput handle = do
+      logMsg "Cancelling input"
+      H.cancelInput handle