aboutsummaryrefslogtreecommitdiff
path: root/hsm-command/Hsm/Command/Command.hs
diff options
context:
space:
mode:
Diffstat (limited to 'hsm-command/Hsm/Command/Command.hs')
-rw-r--r--hsm-command/Hsm/Command/Command.hs34
1 files changed, 27 insertions, 7 deletions
diff --git a/hsm-command/Hsm/Command/Command.hs b/hsm-command/Hsm/Command/Command.hs
index 53964c4..902d637 100644
--- a/hsm-command/Hsm/Command/Command.hs
+++ b/hsm-command/Hsm/Command/Command.hs
@@ -1,4 +1,8 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE OverloadedStrings #-}
module Hsm.Command.Command
( Direction(X, Z)
@@ -9,12 +13,16 @@ module Hsm.Command.Command
) where
import Data.Binary (Binary)
+import Data.ByteString (ByteString)
import Data.Maybe (fromJust, isJust)
-import Data.Text (pack)
+import Data.Text (Text, pack)
import Effectful (Eff, (:>))
-import Effectful.Log (Log, logAttention_)
+import Effectful.Log (Log, logAttention_, logTrace_)
+import Effectful.Reader.Static (Reader, ask)
import GHC.Generics (Generic)
+import GHC.Records (HasField)
import Hsm.Command.Readline (Readline, readline)
+import Hsm.Core.Message (message)
import Streamly.Data.Stream qualified as S
import Text.Read (readEither)
@@ -39,11 +47,23 @@ data Command
| Rotate Angle Speed Int
deriving (Binary, Generic, Read, Show)
-commandStream :: (Log :> es, Readline :> es) => S.Stream (Eff es) Command
+commandStream ::
+ forall env es.
+ ( HasField "name" env Text
+ , Log :> es
+ , Reader env :> es
+ , Readline :> es
+ )
+ => S.Stream (Eff es) ByteString
commandStream =
S.mapMaybeM (parse . fromJust) $ S.takeWhile isJust $ S.repeatM readline
where
- parse string =
- case readEither string of
- Left err -> logAttention_ (pack err) >> return Nothing
- Right command -> return $ Just command
+ parse string = do
+ case readEither @Command string of
+ Left err -> do
+ logAttention_ $ pack err
+ return Nothing
+ Right command -> do
+ env <- ask @env
+ logTrace_ $ "Sending command: " <> pack (show command)
+ return $ Just $ message env.name command