diff options
Diffstat (limited to 'hsm-command/Hsm/Command')
| -rw-r--r-- | hsm-command/Hsm/Command/Command.hs | 34 | 
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 | 
