Merge pull request #7 from distrap/termPipes

Pipe termination and rework, Add CI

.github/workflows/ci.yaml

@@ -0,0 +1,38 @@
+jobs:
+  build:
+    runs-on: ubuntu-latest
+    steps:
+      - uses: "actions/checkout@v3"
+      - id: setup-haskell-cabal
+        uses: "haskell-actions/setup@v2"
+        with:
+          cabal-version: '3.10'
+          enable-stack: false
+          ghc-version: '9.4.7'
+      - name: Update Hackage repository
+        run: cabal update
+      - name: cabal.project.local.ci
+        run: |
+          if [ -e cabal.project.local.ci ]; then
+            cp cabal.project.local.ci cabal.project.local
+          fi
+      - name: freeze
+        run: cabal freeze
+      - uses: "actions/cache@v3"
+        with:
+          key: "${{ runner.os }}-${{ matrix.ghc }}-cabal-${{ hashFiles('cabal.project.freeze') }}"
+          path: |
+            ${{ steps.setup-haskell-cabal.outputs.cabal-store }}
+            dist-newstyle
+      - name: Install dependencies
+        run: cabal build all --enable-tests --enable-benchmarks --only-dependencies
+      - name: build all
+        run: cabal build all --enable-tests --enable-benchmarks
+      - name: test all
+        run: cabal test all --enable-tests
+      - name: haddock all
+        run: cabal haddock all 
+name: Haskell CI
+on:
+  - push
+  - pull_request

ci.dhall

@@ -0,0 +1,4 @@
+let haskellCi =
+      https://raw.githubusercontent.com/sorki/github-actions-dhall/pending/haskell-ci.dhall
+
+in  haskellCi.defaultCi

ci.sh

@@ -0,0 +1,12 @@
+#!/usr/bin/env bash
+# Script by @fisx
+
+set -eo pipefail
+cd "$( dirname "${BASH_SOURCE[0]}" )"
+
+echo "regenerating .github/workflows/ci.yaml..."
+mkdir -p .github/workflows
+
+# based on https://github.com/vmchale/github-actions-dhall
+which dhall-to-yaml || cabal install dhall-yaml
+dhall-to-yaml --file ci.dhall > .github/workflows/ci.yaml

gcodehs.cabal

@@ -60,15 +60,10 @@ executable gcodehs
   main-is:             Main.hs
   ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N
   build-depends:       base
-                     , attoparsec
                      , bytestring
-                     , containers
-                     , double-conversion
                      , gcodehs
                      , pipes
                      , pipes-safe
-                     , text
-                     , transformers
                      , optparse-applicative
                      , optparse-applicative
   default-language:    Haskell2010
@@ -83,13 +78,12 @@ test-suite gcodehs-test
                        SpecHelper
   build-depends:       base
                      , attoparsec
-                     , ansi-wl-pprint
                      , bytestring
                      , gcodehs
                      , hspec
-                     , hspec-discover
-                     , text
-  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
+
+  build-tool-depends: hspec-discover:hspec-discover
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wall
   default-language:    Haskell2010
 
 source-repository head

src/Data/GCode/Pipes.hs

@@ -1,5 +1,32 @@
 {-# LANGUAGE OverloadedStrings #-}
-module Data.GCode.Pipes where
+{-# LANGUAGE RankNTypes #-}
+module Data.GCode.Pipes (
+    runPipe
+  , gcodePipe
+  , pipeToList
+
+  , evalP
+  , evalCanonP
+  , evalCanonStateP
+  , evalCanonLinesP
+  , totalizeP
+
+  , gcodeToLines
+  , gcodeToCanonList
+
+  , compactSink
+  , prettySink
+  , prettySinkWith
+  , wrapPrinter
+
+  , gcodePipe'
+  , pipeToList'
+  , evalCanonLinesP'
+  , evalCanonStateP'
+  , trackAllLimits
+  , trackWorkLimits
+
+  ) where
 
 import Control.Monad
 import Control.Monad.Trans.State.Strict
@@ -17,6 +44,7 @@ import Data.GCode.Pretty
 import qualified Data.GCode.Canon.Convert
 
 import Pipes
+import Pipes.Core
 import Pipes.Attoparsec (ParsingError)
 import Pipes.Safe (SafeT)
 
@@ -28,62 +56,64 @@ import qualified Pipes.Prelude
 import qualified Pipes.Safe
 import qualified System.IO
 
--- something fishy about this type
-parseProducer :: Handle -> Producer Code (SafeT IO) (Either (ParsingError, Producer ByteString (SafeT IO) ()) ())
+-- | Parse GCodes from @Handle@ producing @Code@ stream
+parseProducer
+  :: Handle
+  -> Producer Code (SafeT IO) (Either (ParsingError, Producer ByteString (SafeT IO) ()) ())
 parseProducer = parseProducer' 1024
 
-parseProducer' :: MonadIO m
-               => Int
-               -> Handle
-               -> Producer Code m (Either (ParsingError, Producer ByteString m ()) ())
+-- | Generalized @parseProducer@ with buffer size parameter
+parseProducer'
+  :: MonadIO m
+   => Int
+   -> Handle
+   -> Producer Code m (Either (ParsingError, Producer ByteString m ()) ())
 parseProducer' bufSize handle = Pipes.Attoparsec.parsed
   parseGCodeLine (Pipes.ByteString.hGetSome bufSize handle)
 
+-- | Run job with file handle in @SafeT IO@
 withFile :: FilePath -> (Handle -> (SafeT IO) r) -> IO r
 withFile filepath job =
   System.IO.withFile filepath System.IO.ReadMode $ \handle ->
     Pipes.Safe.runSafeT $ job handle
 
+-- | Run pipe to completion and collect results as list
 pipeToList :: FilePath -> Proxy () Code () a (SafeT IO) () -> IO [a]
 pipeToList filepath pipeTail = withFile filepath $ \h ->
   Pipes.Prelude.toListM
     $ (() <$ parseProducer h)
       >-> pipeTail
 
+-- | Evaluate GCode file to list of @Canon@s
 gcodeToCanonList :: FilePath -> IO [Canon]
 gcodeToCanonList filepath = pipeToList filepath $ evalP >-> evalCanonP
 
+-- | Evaluate GCode file to list of @Line@s
 gcodeToLines :: FilePath -> IO [Line]
 gcodeToLines filepath = pipeToList filepath $ evalP >-> evalCanonLinesP
 
-gcodePipe :: FilePath -> (Consumer Code (SafeT IO) ()) -> IO ()
+-- | Run @Consumer Code@ with input file
+gcodePipe :: FilePath -> Consumer Code (SafeT IO) () -> IO ()
 gcodePipe filepath pipeTail =
-  System.IO.withFile filepath System.IO.ReadMode $ \handle ->
-    Pipes.Safe.runSafeT . runEffect $
+  withFile filepath $ \handle ->
+    runEffect $
       (() <$ parseProducer handle)
       >-> pipeTail
 
--- needs better name
-runPipe :: FilePath
-        -> Maybe FilePath
-        -> (Pipe Code ByteString (SafeT IO) ())
+-- | Run @Pipe Code ByteString (SafeT IO)@ with input file, optionally
+-- writing contents to output file.
+runPipe :: FilePath       -- ^ Input file
+        -> Maybe FilePath -- ^ Nothing mean stdout, Just file output
+        -> Pipe Code ByteString (SafeT IO) ()
         -> IO ()
 runPipe input Nothing pipeMiddle = gcodePipe input (pipeMiddle >-> Pipes.ByteString.stdout)
 runPipe input (Just output) pipeMiddle =
   System.IO.withFile output System.IO.WriteMode $ \outhandle ->
     gcodePipe input (pipeMiddle >-> Pipes.ByteString.toHandle outhandle)
 
-
-foldedPipe :: FilePath
-           -> (Producer Code (Pipes.Safe.SafeT IO) () -> Effect (Pipes.Safe.SafeT IO) r)
-           -> IO r
-foldedPipe filepath fold =
-  System.IO.withFile filepath System.IO.ReadMode $ \handle ->
-    Pipes.Safe.runSafeT . runEffect $
-        fold (() <$ parseProducer handle)
-
 -- evaluators
 
+-- | Run stateful @Code@ evaluator, applying @totalize@
 totalizeP :: Pipe Code Code (SafeT IO) ()
 totalizeP = flip evalStateT Data.Map.Strict.empty $ forever $ do
   x <- lift await
@@ -94,6 +124,7 @@ totalizeP = flip evalStateT Data.Map.Strict.empty $ forever $ do
   put updatedModals
   lift $ yield updatedCode
 
+-- | Run stateful @Code@ evaluator.
 evalP :: Pipe Code Code (SafeT IO) ()
 evalP = flip evalStateT newState $ forever $ do
   x <- lift await
@@ -106,6 +137,7 @@ evalP = flip evalStateT newState $ forever $ do
     Just r -> lift $ yield r
     Nothing -> return ()
 
+-- | Stateful pipe evaluating `Code` to `Canon`
 evalCanonP :: Pipe Code Canon (SafeT IO) ()
 evalCanonP = flip evalStateT initCanonState $ forever $ do
   x <- lift await
@@ -116,6 +148,19 @@ evalCanonP = flip evalStateT initCanonState $ forever $ do
     put steppedState
     lift $ yield c
 
+-- | Stateful pipe evaluating `Code` to `Canon` `CanonState` tuples
+-- Similar to @evalCanonP@ but also forwards @CanonState@ downstream.
+evalCanonStateP :: Pipe Code (Canon, CanonState) (SafeT IO) ()
+evalCanonStateP = flip evalStateT initCanonState $ forever $ do
+  x <- lift await
+  st <- get
+
+  forM_ (Data.GCode.Canon.Convert.toCanon x) $ \c -> do
+    let steppedState = stepCanon st c
+    put steppedState
+    lift $ yield (c, steppedState)
+
+-- | Stateful pipe evaluating `Code` to `Line`
 evalCanonLinesP :: Pipe Code Line (SafeT IO) ()
 evalCanonLinesP = flip evalStateT initCanonState $ forever $ do
   x <- lift await
@@ -126,6 +171,121 @@ evalCanonLinesP = flip evalStateT initCanonState $ forever $ do
     put steppedState
     forM_ (toLines st steppedState c) $ lift . yield
 
+-- * Pipes with termination including result values
+
+type Downstreamed a =
+  (Either
+    (Either
+      (ParsingError , Producer ByteString (SafeT IO) ())
+      ()
+    )
+    a
+  )
+
+-- | Similar to @gcodePipe@ but uses @Downstreamed@
+-- to indicate termination to downstream pipe with @Left@
+--
+-- Usage:
+-- > gcodePipe' "./sample.gcode"
+-- >   $ (fmap Left evalCanonStateP')
+-- >     >-> (fmap Right trackAllLimits)
+-- >     >-> (fmap Left (prettySinkWith (wrapPrinter Prelude.show)
+-- >          >-> Pipes.ByteString.stdout))
+gcodePipe'
+ :: FilePath
+ -> Proxy () (Downstreamed Code) () X (Pipes.Safe.SafeT IO) r
+  -> IO (Either b r)
+gcodePipe' filepath pipeTail =
+  System.IO.withFile filepath System.IO.ReadMode $ \handle ->
+    Pipes.Safe.runSafeT . runEffect $
+      returnDownstream (parseProducer handle)
+      >-> fmap Right pipeTail
+
+-- | Similar to @pipeToList@ but uses @Downstreamed@
+-- to indicate termination to downstream pipe with @Left@
+--
+-- Usage:
+-- > pipeToList' "./sample.gcode"
+-- >   $ (fmap Left evalCanonStateP' )
+-- >     >-> (fmap Right trackWorkLimits)
+pipeToList'
+ :: FilePath
+ -> Proxy () (Downstreamed Code) () a (Pipes.Safe.SafeT IO) r
+ -> IO ([a], Either b r)
+pipeToList' filepath pipeTail = withFile filepath $ \h ->
+  Pipes.Prelude.toListM'
+    $ returnDownstream (parseProducer h)
+      >-> fmap Right pipeTail
+
+-- | Turn `Proxy` into another `Proxy` capturing its return value and sending it downstream
+-- in form of `Either`
+returnDownstream :: Monad m => Proxy a' a b' b m r -> Proxy a' a b' (Either r b) m r'
+returnDownstream = (forever . respond . Left) <=< (respond . Right <\\)
+
+-- | Stateful pipe evaluating `Code` to `Canon` `CanonState` tuples.
+-- Variant of @evalCanonState@ using @Downstreamed@, where Left
+-- indicates time to stop evaluation.
+evalCanonStateP' :: Pipe
+  (Downstreamed Code) (Either () (Canon, CanonState)) (SafeT IO) ()
+evalCanonStateP' = flip evalStateT initCanonState $ go
+  where
+  go = do
+    x' <- lift await
+    case x' of
+      Left _ -> lift $ yield $ Left ()
+      Right x -> do
+        st <- get
+        forM_ (Data.GCode.Canon.Convert.toCanon x) $ \c -> do
+          let steppedState = stepCanon st c
+          put steppedState
+          lift $ yield $ Right (c, steppedState)
+        go
+
+-- | Wrapper for stateful evaluators where receiving
+-- @Left _@ means query local state and use it as return value.
+untilLeft
+  :: Functor m
+  => (t -> StateT b (Proxy () (Either a1 t) y' y m) a2)
+  -> StateT b (Proxy () (Either a1 t) y' y m) b
+untilLeft p = do
+  x' <- lift await
+  case x' of
+    Left _ -> get
+    Right x -> p x >> untilLeft p
+
+-- | Track limits of working area, including travel moves
+trackAllLimits:: (Monad m) => Pipe (Either () (Canon, CanonState)) (Canon, CanonState) m Limits
+trackAllLimits =
+  flip evalStateT mempty
+    $ untilLeft
+      $ \(c,s) -> do
+            modify (`updateLimits` canonPosition s)
+            lift $ yield (c, s)
+
+-- | Track limits of working area, excluding travel moves
+trackWorkLimits :: (Monad m) => Pipe (Either () (Canon, CanonState)) (Canon, CanonState) m Limits
+trackWorkLimits =
+  flip evalStateT mempty
+    $ untilLeft
+      $ \(c,s) -> do
+            -- TODO: shouldn't ignore arcs
+            -- TODO: maybe flip the logic to ignore @StraightTraverse@
+            case c of
+              StraightFeed _ -> modify (`updateLimits` canonPosition s)
+              _              -> return ()
+
+            lift $ yield (c, s)
+
+-- | Stateful pipe evaluating `Canon` to `Line`
+evalCanonLinesP' :: Pipe Canon Line (SafeT IO) ()
+evalCanonLinesP' = flip evalStateT initCanonState $ forever $ do
+  x <- lift await
+  st <- get
+
+  let steppedState = stepCanon st x
+  put steppedState
+  forM_ (toLines st steppedState x) $ lift . yield
+
 -- mmaped experiment, requires pipes-bytestring-mmap
 --import qualified Pipes.ByteString.MMap
 --main' = do
@@ -137,8 +297,7 @@ evalCanonLinesP = flip evalStateT initCanonState $ forever $ do
 
 -- pretty print
 prettySinkWith :: (a -> ByteString) -> Pipe a ByteString (SafeT IO) ()
-prettySinkWith fn =
-      Pipes.Prelude.map fn
+prettySinkWith = Pipes.Prelude.map
 
 prettySink :: Pipe Code ByteString (SafeT IO) ()
 prettySink =