From ab4591cb0e074ce98c24645cdb80cb5012aed566 Mon Sep 17 00:00:00 2001
From: Paul Oliver <contact@pauloliver.dev>
Date: Fri, 7 Feb 2025 17:10:05 +0000
Subject: Initial

---
 hsm-readline/Hsm/Readline.hs | 50 ++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 50 insertions(+)
 create mode 100644 hsm-readline/Hsm/Readline.hs

(limited to 'hsm-readline/Hsm')

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
-- 
cgit v1.2.1