diff options
author | Paul Oliver <contact@pauloliver.dev> | 2024-08-24 11:57:18 -0700 |
---|---|---|
committer | Paul Oliver <contact@pauloliver.dev> | 2024-12-01 07:01:30 -0800 |
commit | f0854265f7a1b59078308965d33fe2583a5c0f9c (patch) | |
tree | d8b06110d84fce783f1cc91aa37155351c655b2c /hsm-command |
Diffstat (limited to 'hsm-command')
-rw-r--r-- | hsm-command/Hsm/Command/Command.hs | 67 | ||||
-rw-r--r-- | hsm-command/Hsm/Command/Readline.hs | 58 | ||||
-rw-r--r-- | hsm-command/Main.hs | 41 | ||||
-rw-r--r-- | hsm-command/hsm-command.cabal | 45 |
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 |