diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml new file mode 100644 index 0000000..ae27d4f --- /dev/null +++ b/.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 diff --git a/ci.dhall b/ci.dhall new file mode 100644 index 0000000..98a9829 --- /dev/null +++ b/ci.dhall @@ -0,0 +1,4 @@ +let haskellCi = + https://raw.githubusercontent.com/sorki/github-actions-dhall/pending/haskell-ci.dhall + +in haskellCi.defaultCi diff --git a/ci.sh b/ci.sh new file mode 100755 index 0000000..6994761 --- /dev/null +++ b/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 diff --git a/gcodehs.cabal b/gcodehs.cabal index 037dcee..f2b959b 100644 --- a/gcodehs.cabal +++ b/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 diff --git a/src/Data/GCode/Pipes.hs b/src/Data/GCode/Pipes.hs index 116a869..9420a2f 100644 --- a/src/Data/GCode/Pipes.hs +++ b/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 =