4 files changed, 211 insertions, 0 deletions
diff --git a/hsm-command/Hsm/Command/Command.hs b/hsm-command/Hsm/Command/Command.hs
new file mode 100644
index 0000000..2080143
--- /dev/null
+++ b/hsm-command/Hsm/Command/Command.hs
@@ -0,0 +1,67 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE ImportQualifiedPost #-}
+
+module Hsm.Command.Command
+  ( Direction (Forward, Backward, Left, Right)
+  , Angle (CW, CCW)
+  , Speed (Slow, Mid, Fast)
+  , Command (Move, Rotate)
+  , commandStream
+  )
+where
+
+import Data.Binary (Binary)
+import Data.Function ((&))
+import Data.Maybe (fromJust, isJust)
+import Data.Text (pack)
+import Effectful (Eff, (:>))
+import Effectful.Log (Log, logAttention_)
+import GHC.Generics (Generic)
+import Hsm.Command.Readline (Readline, readline)
+import Streamly.Data.Stream (Stream, mapMaybeM, repeatM, takeWhile)
+import Text.Read (readEither)
+import Prelude hiding (Left, Right, takeWhile)
+import Prelude qualified as P
+
+data Direction
+  = Forward
+  | Backward
+  | Left
+  | Right
+  deriving (Binary, Generic, Read, Show)
+
+data Angle
+  = CW
+  | CCW
+  deriving (Binary, Generic, Read, Show)
+
+data Speed
+  = Slow
+  | Mid
+  | Fast
+  deriving (Binary, Generic, Read, Show)
+
+data Command
+  = Move Direction Speed Int
+  | Rotate Angle Speed Int
+  deriving (Binary, Generic, Read, Show)
+
+commandStream
+  :: forall es
+   . ( Log :> es
+     , Readline :> es
+     )
+  => Stream (Eff es) Command
+commandStream =
+  repeatM readline
+    & takeWhile isJust
+    & mapMaybeM (parse . fromJust)
+ where
+  parse
+    :: Log :> es
+    => String
+    -> Eff es (Maybe Command)
+  parse string =
+    case readEither string of
+      P.Left err -> logAttention_ (pack err) >> return Nothing
+      P.Right command -> return $ Just command
diff --git a/hsm-command/Hsm/Command/Readline.hs b/hsm-command/Hsm/Command/Readline.hs
new file mode 100644
index 0000000..66246b5
--- /dev/null
+++ b/hsm-command/Hsm/Command/Readline.hs
@@ -0,0 +1,58 @@
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Hsm.Command.Readline
+  ( Readline
+  , readline
+  , runReadline
+  )
+where
+
+import Data.Function ((&))
+import Effectful (Dispatch (Static), DispatchOf, Eff, Effect, 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
+import Prelude hiding (takeWhile)
+
+data Readline :: Effect
+
+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 handle <- S.getStaticRep
+  H.getInputLine "% "
+    & H.withInterrupt
+    & H.handleInterrupt (return Nothing)
+    & H.queryInput handle
+    & S.unsafeEff_
+ where
+  flushLogger :: Eff es ()
+  flushLogger = getLoggerEnv >>= S.unsafeEff_ . waitForLogger . leLogger
+
+runReadline
+  :: ( IOE :> es
+     , Resource :> es
+     )
+  => Eff (Readline : es) a
+  -> Eff es a
+runReadline action = do
+  handle <- snd <$> allocate state H.cancelInput
+  S.evalStaticRep (Readline handle) action
+ where
+  settings :: H.Settings IO
+  settings = H.defaultSettings {H.historyFile = Just "/tmp/hsm_command_history"}
+
+  state :: IO H.InputState
+  state = H.initializeInput settings
diff --git a/hsm-command/Main.hs b/hsm-command/Main.hs
new file mode 100644
index 0000000..78fa607
--- /dev/null
+++ b/hsm-command/Main.hs
@@ -0,0 +1,41 @@
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Main
+  ( main
+  )
+where
+
+import Data.Aeson.TH (defaultOptions, deriveFromJSON, rejectUnknownFields)
+import Data.Function ((&))
+import Data.Text (Text)
+import Effectful (runEff)
+import Effectful.Log qualified as L
+import Effectful.Reader.Static (runReader)
+import Effectful.Resource (runResource)
+import Hsm.Command.Command (commandStream)
+import Hsm.Command.Readline (runReadline)
+import Hsm.Core.App (launchWithEcho)
+import Hsm.Core.Zmq (runServer, send)
+import Streamly.Data.Fold (drain)
+import Streamly.Data.Stream (fold, mapM)
+import Prelude hiding (mapM, takeWhile)
+
+data Env = Env
+  { name :: Text
+  , pubEp :: Text
+  }
+
+$(deriveFromJSON defaultOptions {rejectUnknownFields = True} ''Env)
+
+main :: IO ()
+main =
+  launchWithEcho @Env "command" $ \env logger level ->
+    (commandStream & mapM (send @_ @Env) & fold drain)
+      & runServer @Env
+      & L.runLog env.name logger level
+      & runReader env
+      & runReadline
+      & runResource
+      & runEff
diff --git a/hsm-command/hsm-command.cabal b/hsm-command/hsm-command.cabal
new file mode 100644
index 0000000..95f9ffa
--- /dev/null
+++ b/hsm-command/hsm-command.cabal
@@ -0,0 +1,45 @@
+cabal-version: 3.4
+author:        Paul Oliver
+build-type:    Simple
+maintainer:    contact@pauloliver.dev
+name:          hsm-command
+version:       0.1.0.0
+
+library
+  build-depends:
+    , base
+    , binary
+    , effectful-core
+    , haskeline
+    , log-effectful
+    , resourcet-effectful
+    , streamly-core
+    , text
+
+  exposed-modules:
+    Hsm.Command.Command
+    Hsm.Command.Readline
+
+  ghc-options:      -Wall -Wunused-packages
+  default-language: GHC2024
+
+executable command
+  build-depends:
+    , aeson
+    , base
+    , binary
+    , effectful-core
+    , haskeline
+    , hsm-core
+    , log-effectful
+    , resourcet-effectful
+    , streamly-core
+    , text
+
+  main-is:          Main.hs
+  other-modules:
+    Hsm.Command.Command
+    Hsm.Command.Readline
+
+  ghc-options:      -Wall -Wunused-packages
+  default-language: GHC2024