gcodehs 0.1.1.0 → 0.1.2.0
raw patch · 28 files changed
+2384/−705 lines, 28 filesdep +hspecdep +hspec-discoverdep +template-haskelldep −arraydep −mtldep −pipes-textdep ~base
Dependencies added: hspec, hspec-discover, template-haskell, transformers
Dependencies removed: array, mtl, pipes-text, vty
Dependency ranges changed: base
Files
- CHANGELOG.md +22/−0
- README.md +39/−0
- app/Main.hs +74/−73
- gcodehs.cabal +55/−28
- src/Data/GCode.hs +18/−7
- src/Data/GCode/Ann.hs +17/−0
- src/Data/GCode/Canon.hs +138/−0
- src/Data/GCode/Canon/Convert.hs +172/−0
- src/Data/GCode/Eval.hs +270/−0
- src/Data/GCode/Generate.hs +115/−0
- src/Data/GCode/Generate/Examples.hs +95/−0
- src/Data/GCode/Generate/ExamplesMonad.hs +23/−0
- src/Data/GCode/Line.hs +74/−0
- src/Data/GCode/Monad.hs +34/−0
- src/Data/GCode/Parse.hs +43/−26
- src/Data/GCode/Pipes.hs +159/−0
- src/Data/GCode/Pipes/Transform.hs +29/−0
- src/Data/GCode/Pretty.hs +88/−50
- src/Data/GCode/RS274.hs +50/−0
- src/Data/GCode/RS274/Types.hs +477/−0
- src/Data/GCode/TH.hs +98/−0
- src/Data/GCode/Types.hs +97/−91
- src/Data/GCode/Utils.hs +71/−430
- test/EvalSpec.hs +67/−0
- test/GenSpec.hs +25/−0
- test/ParseSpec.hs +17/−0
- test/Spec.hs +1/−0
- test/SpecHelper.hs +16/−0
+ CHANGELOG.md view
@@ -0,0 +1,22 @@+# Version [0.1.2.0](https://github.com/distrap/gcodehs/compare/0.1.2.0...0.1.1.0) (2020-06-17)++* Changelog started. Previous release was `0.1.1.0`.++* Major rework, only core functionality and types unchanged+ * Little changes to parser and pretty printer, APIs unchaged++* Additions+ * Canonical representation `Data.GCode.Canon`+ * Interepreters for both `GCode` and canonical representation+ * Line output+ * Tests+ * Helpers and monad for generating GCode+ * Pipes now exposed from library via `Data.GCode.Pipes`+ * `Data.GCode.RS274.Types` module with command decriptions++---++`gcodehs` uses [PVP Versioning][1].++[1]: https://pvp.haskell.org+
+ README.md view
@@ -0,0 +1,39 @@+# gcodehs++## Installing++* `git clone https://github.com/distrap/gcodehs/`+* `cd gcodehs`+* `nix-build` or `nix-shell`++## Usage++To pretty-print `sample.gcode`::++```bash+gcodehs pretty sample.gcode+```++See `gcodehs --help` for usage information.++## Development status++Pretty printing is slow due to conversion+to text but we do have colors!++Fast pretty printer is needed that operates+with ByteStrings directly.++## Bash completion++Generating bash completion::++```bash+gcodehs --bash-completion-script `which gcodehs` &> gcodehs-completion.sh+```++or sourcing directly::++```bash+source <(gcodehs --bash-completion-script `which gcodehs`)+```
app/Main.hs view
@@ -2,94 +2,95 @@ {-# LANGUAGE OverloadedStrings #-} module Main where -import Data.GCode -import Prelude hiding (readFile, putStrLn)+import Pipes (Pipe, (>->))+import Pipes.Safe (SafeT)+import Data.ByteString (ByteString) import Control.Applicative--import Pipes-import Pipes.Attoparsec as PA-import qualified Pipes.Prelude as P-import qualified Pipes.ByteString as B---import Pipes.ByteString.MMap-import Pipes.Safe-import qualified System.IO as IO+import Options.Applicative -import Data.Monoid ((<>))-import qualified Data.ByteString.Char8 as BS-import qualified Data.ByteString.Lazy as BL+import Data.GCode+import Data.GCode.Pipes.Transform+import Data.GCode.Line (prettyLine) -import Options.Applicative-import Options.Applicative.Builder+data Command =+ Cat+ | Pretty+ | Analyze+ | Totalize+ | TranslateXY Double Double+ | TranslateZ Double+ | Rotate Double+ | ScaleFeedrate Double+ | ScaleXY Double Double+ | Eval+ | Canon+ | Lines+ -- TODO+ | TravelDistance+ | ExtrusionDistance+ | Generate+ -- disabled for now as they require interepreter not just looking at coords+ -- (due to relative moves)+ | Limits+ | ToOrigin+ deriving (Eq, Show, Ord) -data Flags = Flags {- input :: FilePath- , output :: FilePath- , pretty :: Bool- , analyze :: Bool+data Options = Options {+ cmd :: Command+ , input :: FilePath+ , output :: Maybe FilePath } deriving (Show) --- switch to arguments when following is fixed and tab-completion--- prefers arguments before options--- https://github.com/pcapriotti/optparse-applicative/issues/173--- <$> argument str (metavar "FILE")+cmdParser :: Parser Command+cmdParser = subparser+ ( command "cat" (info (pure Cat) (progDesc "Parse and print GCode"))+ <> command "pretty" (info (pure Pretty) (progDesc "Parse and pretty-print GCode"))+-- <> command "limits" (info (pure Limits) (progDesc "Compute axis movements limits"))+-- <> command "move-to-origin" (info (pure ToOrigin) (progDesc "Move GCode so it starts at X0 Y0"))+ <> command "totalize" (info (pure Totalize) (progDesc "Walk GCode adding missing axes coordinates according to previous moves"))+ <> command "translate-xy" (info (TranslateXY <$> argument auto (metavar "X") <*> argument auto (metavar "Y")) (progDesc "Translate GCode by X Y offsets"))+ <> command "translate-z" (info (TranslateZ <$> argument auto (metavar "Z")) (progDesc "Translate GCode by Z offset"))+ <> command "rotate" (info (Rotate <$> argument auto (metavar "DEG")) (progDesc "Rotate GCode by angle in degrees"))+ <> command "scale-feedrate" (info (ScaleFeedrate <$> argument auto (metavar "MULTIPLIER")) (progDesc "Scale feedrates by multiplier"))+ <> command "scale-xy" (info (ScaleXY <$> argument auto (metavar "X") <*> argument auto (metavar "Y")) (progDesc "Scale X/Y by multiplier"))+ <> command "eval" (info (pure Eval) (progDesc "Evaluate GCode"))+ <> command "canon" (info (pure Canon) (progDesc "Convert to canonical representation"))+ <> command "lines" (info (pure Lines) (progDesc "Convert to lines"))+ ) -flags :: Parser Flags-flags = Flags- <$> strOption ( long "input" <> short 'i' <> metavar "INPUT")- <*> strOption ( long "output" <> short 'o' <> metavar "OUTPUT" <> value "")- <*> switch ( long "pretty" <> short 'p' <> help "Pretty output")- <*> switch ( long "analyze" <> short 'a' <> help "Analyze GCode")+flags :: Parser Options+flags = Options+ <$> cmdParser+ <*> argument str (metavar "INPUT-FILE")+ <*> (optional+ $ strOption (+ long "output"+ <> short 'o'+ <> metavar "OUTPUT-FILE")) +main :: IO () main =- execParser opts >>= run+ execParser opts >>= \Options{..} -> runPipe input output (toSink cmd) where opts = info (helper <*> flags) ( fullDesc- <> progDesc "Process GCode from INPUT"+ <> progDesc "Process GCode from FILE" <> header "gcodehs - GCode processor" ) -run :: Flags -> IO ()-run Flags{..} =- if analyze- then do- r <- foldedpipe input analyzefold- print r- else case output of- "" -> gcodepipe input $ fmt pretty >-> B.stdout- _ -> IO.withFile output IO.WriteMode $ \outhandle ->- gcodepipe input $ fmt pretty >-> B.toHandle outhandle--bufsize = 1024--parseProducer handle = PA.parsed parseGCodeLine (B.hGetSome bufsize handle)--gcodepipe filepath tail =- IO.withFile filepath IO.ReadMode $ \handle ->- runSafeT . runEffect $- (() <$ parseProducer handle)- >-> tail--foldedpipe filepath fold =- IO.withFile filepath IO.ReadMode $ \handle ->- runSafeT . runEffect $- fold (() <$ parseProducer handle)--analyzefold = P.fold step 0 id- where step x a = x + 1 -- travel a----analyzefold' = P.fold step 0 id--- where step x a | isG a = x + 1--- step x a | otherwise = x+toSink :: Command -> Pipe Code ByteString (SafeT IO) ()+toSink Cat = compactSink+toSink Pretty = prettySink+toSink Totalize = totalizeP >-> compactSink+toSink Eval = evalP >-> prettySink+toSink Canon = evalP >-> evalCanonP >-> prettySinkWith (wrapPrinter show)+toSink Lines = evalP >-> evalCanonLinesP >-> (prettySinkWith $ wrapPrinter $ prettyLine defaultStyle) -fmt True = P.map ppGCodeLine >-> P.map (BS.pack . (++"\n"))-fmt False = P.map ppGCodeLineCompact >-> P.map (BS.pack . (++"\n"))+toSink (TranslateXY xt yt) = translateXY xt yt >-> compactSink+toSink (TranslateZ zt) = translateZ zt >-> compactSink+toSink (ScaleXY xs ys) = scaleXY xs ys >-> compactSink+toSink (ScaleFeedrate s) = scaleFeedrate s >-> compactSink+toSink (Rotate a) = rotate a >-> compactSink --- mmaped version, requires pipes-bytestring-mmap---main' = do--- file <- fmap Prelude.head getArgs--- runSafeT . runEffect $--- (() <$ PA.parsed parseGCodeLine (unsafeMMapFile file) )--- >-> P.map ppGCodeLine--- >-> P.stdoutLn+toSink _ = error "Currently not supported, sorry :("
gcodehs.cabal view
@@ -1,8 +1,8 @@ name: gcodehs-version: 0.1.1.0+version: 0.1.2.0 synopsis: GCode processor description: GCode parser, pretty-printer and processing utils-homepage: https://github.com/hackerspace/gcodehs+homepage: https://github.com/distrap/gcodehs license: BSD3 license-file: LICENSE author: Richard Marko@@ -10,61 +10,88 @@ copyright: 2016 Richard Marko category: Parsing build-type: Simple--- extra-source-files: cabal-version: >=1.10+extra-source-files:+ CHANGELOG.md+ README.md+ LICENSE library+ ghc-options: -Wall hs-source-dirs: src- exposed-modules: Data.GCode, Data.GCode.Types, Data.GCode.Parse, Data.GCode.Pretty, Data.GCode.Utils+ exposed-modules: Data.GCode+ , Data.GCode.Ann+ , Data.GCode.Canon+ , Data.GCode.Canon.Convert+ , Data.GCode.Generate+ , Data.GCode.Generate.Examples+ , Data.GCode.Generate.ExamplesMonad+ , Data.GCode.Eval+ , Data.GCode.Line+ , Data.GCode.Monad+ , Data.GCode.Types+ , Data.GCode.Parse+ , Data.GCode.Pipes+ , Data.GCode.Pipes.Transform+ , Data.GCode.Pretty+ , Data.GCode.RS274+ , Data.GCode.RS274.Types+ , Data.GCode.TH+ , Data.GCode.Utils build-depends: base >= 4.7 && < 5 , attoparsec , ansi-wl-pprint , bytestring , containers+ , transformers , double-conversion , text+ , template-haskell , pipes , pipes-attoparsec , pipes-bytestring- , mtl- , vty- , array+-- , pipes-bytestring-mmap+ , pipes-safe+ , pipes-parse default-language: Haskell2010 executable gcodehs hs-source-dirs: app main-is: Main.hs- ghc-options: -threaded -rtsopts -with-rtsopts=-N+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: base , attoparsec , bytestring+ , containers , double-conversion , gcodehs- , text , pipes- , pipes-attoparsec- , pipes-bytestring--- , pipes-bytestring-mmap , pipes-safe- , pipes-parse- , pipes-text+ , text+ , transformers , optparse-applicative+ , optparse-applicative default-language: Haskell2010 ---test-suite gcodehs-test--- type: exitcode-stdio-1.0--- hs-source-dirs: test--- main-is: Spec.hs--- build-depends: base--- , attoparsec--- , ansi-wl-pprint--- , bytestring--- , gcodehs--- , text--- , turtle--- ghc-options: -threaded -rtsopts -with-rtsopts=-N--- default-language: Haskell2010+test-suite gcodehs-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ other-modules: ParseSpec+ GenSpec+ EvalSpec+ SpecHelper+ build-depends: base+ , attoparsec+ , ansi-wl-pprint+ , bytestring+ , gcodehs+ , hspec+ , hspec-discover+ , text+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010 source-repository head type: git- location: https://github.com/hackerspace/gcodehs+ location: https://github.com/distrap/gcodehs
src/Data/GCode.hs view
@@ -1,12 +1,23 @@ {-| This module is an entry point to @gcodehs@ library -This module re-exports all Data.GCode submodules.+This module re-exports most of the "Data.GCode" submodules. -} - {-# LANGUAGE OverloadedStrings #-}-module Data.GCode (module X) where-import Data.GCode.Types as X-import Data.GCode.Parse as X-import Data.GCode.Pretty as X-import Data.GCode.Utils as X+module Data.GCode (+ module Data.GCode.Ann+ , module Data.GCode.Eval+ , module Data.GCode.Types+ , module Data.GCode.Parse+ , module Data.GCode.Pipes+ , module Data.GCode.Pretty+ , module Data.GCode.Utils+ ) where++import Data.GCode.Ann+import Data.GCode.Eval+import Data.GCode.Types+import Data.GCode.Parse+import Data.GCode.Pipes+import Data.GCode.Pretty+import Data.GCode.Utils
+ src/Data/GCode/Ann.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE DeriveFunctor #-}++module Data.GCode.Ann (+ Ann(..)+ , stripAnnotation+ ) where++{-+Type for annotating `Code` or `Canon` with source positions.+-}+++data Ann a = SrcLine Integer a+ deriving (Show, Eq, Ord, Functor)++stripAnnotation :: Ann a -> a+stripAnnotation (SrcLine _ x) = x
+ src/Data/GCode/Canon.hs view
@@ -0,0 +1,138 @@+{- Canonnical representation++Our IR+(work in progress)+-}++module Data.GCode.Canon where++import Data.ByteString (ByteString)+import Data.GCode.Types (Axes, zeroAxes)++import qualified Data.Map++data Plane = XY | YZ | ZX | UV | WU | VW+ deriving (Show, Eq, Ord)++data CutterCompenstationSide =+ CutterCompensationRight+ | CutterCompensationLeft+ | CutterCompensationOff+ deriving (Show, Eq, Ord)++type Speed = Double+type Seconds = Double++data RotationDirection = ClockWise | CounterClockWise+ deriving (Show, Eq, Ord)++data LengthUnit = Inches | MilliMeters | CentiMeters | Meters+ deriving (Show, Eq, Ord)++data HeaterType = HeatedExtruder | HeatedBed | HeatedChamber+ deriving (Show, Eq, Ord)++-- | Some heater with id or Nothing for current / default+data Heater = Heater HeaterType (Maybe Int)+ deriving (Show, Eq, Ord)++-- | Tool length compensation+data CompensationMode =+ NoCompensation -- ^ Tool length compensation is disabled+ | LengthTable -- ^ Following moves will take into account tool offset from tool table+ | Dynamic Axes -- ^ Apply dynamic offset+ | Add Int -- ^ Add tool offset of the tool specified by the parameter to currently selected tool offset+ deriving (Show, Eq, Ord)++-- Like linxucnc arcs, not used, subject to change+data ArcParams = ArcParams {+ arcFirstEnd :: Double -- ^ first second coordinates according to selected plane+ , arcSecondEnd :: Double+ , arcFirstAxis :: Double+ , arcSecondAxis :: Double+ , arcRotation :: Int+ , arcAxisEndPoint :: Double+ , arcA :: Double+ , arcB :: Double+ , arcC :: Double+ , arcU :: Double+ , arcV :: Double+ , arcW :: Double+ } deriving (Eq, Show, Ord)++data Canon =+ StraightTraverse Axes -- ^ Rapid motion to end position specified by Axes+ | StraightFeed Axes -- ^ Machining motion+ | StraightProbe Axes -- ^ Straight probe towards workpeice+ | SetCoords Axes -- ^ Set coordinates to provided values without motion+ | ArcFeed ArcParams -- ^ Movement along arc+ | ProgramEnd -- ^ End of the program+ | SetFeedRate Speed -- ^ Set feed rate for machining moves+ | SetTraverseRate Speed -- ^ Set feed rate for travel moves+ | PlaneSelect Plane -- ^ Set plane+ | PauseSeconds Double -- ^ Do nothing for specified number of seconds+ | SpindleStart {+ spindleDirection :: RotationDirection -- ^ Rotate spindle according to `RotationDirection`+ , spindleWaitForSpeed :: Bool -- ^ Wait for spindle to reach desired RPM+ }+ | SpindleStop -- ^ Stop spindle+ | SpindleSpeed Speed -- ^ Set spindle RPM+ | CoolantMist -- ^ Enable mist coolant+ | CoolantFlood -- ^ Enable flood coolant+ | CoolantStop -- ^ Stop all coolant flows+ -- Tools+ | ToolSelect Int -- ^ Select tool by its index+ | ToolChange -- ^ Perform tool change+ | ToolLengthCompensation CompensationMode -- ^ Enable tool length compensation+ -- Printer+ | FanOn -- ^ Enable fan+ | FanOff -- ^ Disable fan+ | SetTemperature Heater Double -- ^ Set temperature of the specific heater+ | SetTemperatureWait Heater Double -- ^ Set temperature and wait for it to be reached+ | CancelWaitTemperature -- ^ Cancel all temperature waits+ | LevelBed -- ^ Perform automated bed leveling+ -- Misc+ | DisableMotors Axes -- ^ Disable power to motors+ | DisplayMessage ByteString -- ^ Display a message, typically on LCD+ | Comment ByteString -- ^ Just a comment+ deriving (Show, Eq, Ord)++-- | State of the Canon interpreter+data CanonState = CanonState {+ canonPosition :: Axes -- ^ Position+ , canonTraverseRate :: Speed -- ^ Speed for travel moves+ , canonFeedRate :: Speed -- ^ Speed for machining moves+ , canonPlane :: Plane -- ^ Selected plane+ } deriving (Show, Eq, Ord)++-- | Initial state of the Canon interpreter+initCanonState :: CanonState+initCanonState = CanonState {+ canonPosition = zeroAxes+ , canonTraverseRate = 0+ , canonFeedRate = 0+ , canonPlane = XY+ }++-- | Step Canon interpreter, returning new state+stepCanon :: CanonState -> Canon -> CanonState+stepCanon s (StraightTraverse a) = s { canonPosition = Data.Map.union a (canonPosition s) }+stepCanon s (StraightFeed a) = s { canonPosition = Data.Map.union a (canonPosition s) }+stepCanon s (SetFeedRate r) = s { canonFeedRate = r }+stepCanon s (SetTraverseRate r) = s { canonTraverseRate = r }+stepCanon s (SetCoords a) = s { canonPosition = Data.Map.union a (canonPosition s) }+stepCanon s (PlaneSelect p) = s { canonPlane = p }++-- | Fully eval list of `Canon` commands.+--+-- Slow, only useful for testing, use `Data.GCode.Pipes` variant instead+evalCanon :: (CanonState -> CanonState -> Canon -> [a])+ -> [Canon]+ -> [a]+evalCanon f cs = go initCanonState cs+ where+ go _ [] = []+ go st (c:rest) =+ let+ newSt = stepCanon st c+ in (f st newSt c) ++ (go newSt rest)
+ src/Data/GCode/Canon/Convert.hs view
@@ -0,0 +1,172 @@+module Data.GCode.Canon.Convert where++import Control.Applicative++import Data.GCode.Types (Code(..), Class(..), Axes, ParamDesignator(..))+import Data.GCode.Canon (Canon(..))++import qualified Data.Map+import qualified Data.GCode.Canon as C+import qualified Data.GCode.Types as T++import Data.GCode.RS274+import Data.GCode.Utils++-- | Convert code to its canonical representation+toCanon :: Code -> [Canon]+toCanon c | isRapid c =+ ifHasParam F c C.SetTraverseRate+ <> ifNonEmptyAxes c C.StraightTraverse+toCanon c | isMove c =+ ifHasParam F c C.SetFeedRate+ <> ifNonEmptyAxes c C.StraightFeed++-- :((+--toCanon c | isArc c = ArcFeed++toCanon c | isCoordinateSystemOffset c = pure $ C.SetCoords (codeAxes c)++toCanon c | isDwell c+ = pure . C.PauseSeconds $ getParamOrFail P c "No P for Dwell"++-- Converted by step+toCanon c | isMillimeters c = empty+toCanon c | isInches c = empty+toCanon c | isAbsolute c = empty+toCanon c | isRelative c = empty++-- Planes+toCanon c | isXYPlane c = pure $ C.PlaneSelect C.XY+toCanon c | isZXPlane c = pure $ C.PlaneSelect C.ZX+toCanon c | isYZPlane c = pure $ C.PlaneSelect C.YZ+toCanon c | isUVPlane c = pure $ C.PlaneSelect C.UV+toCanon c | isWUPlane c = pure $ C.PlaneSelect C.WU+toCanon c | isVWPlane c = pure $ C.PlaneSelect C.VW++-- Standalone+toCanon Code { codeCls = Just FStandalone, codeNum = Just newFeed }+ = pure $ C.SetFeedRate $ fromIntegral newFeed+toCanon Code { codeCls = Just SStandalone, codeNum = Just spindleRPM }+ = pure $ C.SpindleSpeed $ fromIntegral spindleRPM++-- Units+toCanon c | isUnitsPerMinute c = empty+toCanon c | isUnitsPerRevolution c = error "Don't know how to handle units per revolution"++-- Spindle+toCanon c | isSpindleCW c = pure C.SpindleStart+ { spindleDirection = C.ClockWise+ , spindleWaitForSpeed = True } -- questionable+toCanon c | isSpindleCCW c = pure C.SpindleStart+ { spindleDirection = C.CounterClockWise+ , spindleWaitForSpeed = True } -- questionable+toCanon c | isSpindleStop c = pure C.SpindleStop++-- Coolant+toCanon c | isCoolantMist c = pure C.CoolantMist+toCanon c | isCoolantFlood c = pure C.CoolantFlood+toCanon c | isCoolantStop c = pure C.CoolantStop++-- Tool+toCanon c | isToolChange c = pure C.ToolChange+toCanon (Code{codeCls=(Just T), codeNum=(Just toolId)}) = pure $ C.ToolSelect toolId+toCanon c | isToolLength c = pure $ C.ToolLengthCompensation C.LengthTable+toCanon c | isToolLengthDynamic c = pure $ C.ToolLengthCompensation $ C.Dynamic+ (codeAxes c)+toCanon c | isToolLengthAdd c = pure $ C.ToolLengthCompensation $ C.Add+ (round $ getParamOrFail H c "Add tool change offset requires H parameter of the tool to grab offset from")+toCanon c | isToolLengthCancel c = pure $ C.ToolLengthCompensation C.NoCompensation++-- Printer -- XXX: needs handling in step+toCanon c | isExtruderAbsolute c = empty+toCanon c | isExtruderRelative c = empty++-- Printer heating+toCanon c | isSetExtruderTemperature c = pure $ C.SetTemperature+ (C.Heater C.HeatedExtruder $ round <$> getParam P c)+ (getParamOrFail S c "Set extruder temperature command missing S parameter for temperature value")+toCanon c | isSetBedTemperature c = pure $ C.SetTemperature+ (C.Heater C.HeatedBed $ round <$> getParam P c)+ (getParamOrFail S c "Set bed temperature command missing S parameter for temperature value")+toCanon c | isSetChamberTemperature c = pure $ C.SetTemperature+ (C.Heater C.HeatedChamber $ round <$> getParam P c)+ (getParamOrFail S c "Set heated chamber temperature command missing S parameter for temperature value")+toCanon c | isCancelWaitTemperature c = pure $ C.CancelWaitTemperature+-- Wait variants+toCanon c | isSetExtruderTemperatureAndWait c = pure $ C.SetTemperatureWait+ (C.Heater C.HeatedExtruder $ round <$> getParam P c)+ (getParamOrFail S c "Set extruder temperature and wait command missing S parameter for temperature value")+toCanon c | isSetBedTemperatureAndWait c = pure $ C.SetTemperatureWait+ (C.Heater C.HeatedBed $ round <$> getParam P c)+ (getParamOrFail S c "Set bed temperature and wait command missing S parameter for temperature value")+toCanon c | isSetChamberTemperatureAndWait c = pure $ C.SetTemperatureWait+ (C.Heater C.HeatedChamber $ round <$> getParam P c)+ (getParamOrFail S c "Set chamber temperature and wait command missing S parameter for temperature value")+-- Cancel+toCanon c | isCancelWaitTemperature c = pure $ C.CancelWaitTemperature++-- Printer cooling+toCanon c | isFanOn c = pure C.FanOn+toCanon c | isFanOff c = pure C.FanOff++-- Printer homing, XXX: this clashes with G28 of cnc which is StoredPositionMove+toCanon c | isGN 28 c = empty++-- Printer leveling+toCanon c | isAutoBedLevel c = pure C.LevelBed++-- Printer miscs, XXX: we probably can't even parse M117 Hello world+toCanon c | isDisplayMessage c = empty+toCanon c | isDisableActuators c = pure $ C.DisableMotors (codeAxes c)++toCanon c | isProgramEnd c = pure C.ProgramEnd+toCanon c | isCommentOnly c = pure $ C.Comment (codeComment c) -- XXX: strip spaces+toCanon (T.Comment c) = pure $ C.Comment c+toCanon Empty = empty+toCanon (Other _) = empty -- questionable+-- this is bad but we can't use GHC to tell us about missing clauses+-- due to how Code type is freeform-ish (which is also the reason for Canon).+-- Lets stay on the safe side and error for now as ignoring could lead to+-- missing important commands.+toCanon c = error $ "No canon for " ++ show c++-- Helpers++-- Apply @f@ to parameter value only iff @p@ parameter is found, mempty otherwise+ifHasParam :: (Monoid (f a), Applicative f)+ => ParamDesignator+ -> Code+ -> (Double -> a)+ -> f a+ifHasParam p c f = case getParam p c of+ Nothing -> mempty+ Just val -> pure $ f val++-- Apply @f@ to `Axes` value only iff `Code` has axes, mempty otherwise+ifNonEmptyAxes :: (Applicative f, Monoid (f a))+ => Code+ -> (Axes -> a)+ -> f a+ifNonEmptyAxes c f | codeAxes c /= mempty = pure $ f (codeAxes c)+ifNonEmptyAxes _ _ | otherwise = mempty++-- Get parameter value or fail with `error`, useful for required parameters+getParamOrFail :: ParamDesignator+ -> Code+ -> [Char]+ -> Double+getParamOrFail param code msg = maybe (error msg) id (getParam param code)++-- brr+isCommentOnly :: Code -> Bool+isCommentOnly (Code { codeCls = Nothing+ , codeNum = Nothing+ , codeSub = Nothing+ , codeAxes = a+ , codeParams = p+ , codeComment = x }) |+ Data.Map.null a && Data.Map.null p &&+ x /= mempty = True+isCommentOnly _ = False++
+ src/Data/GCode/Eval.hs view
@@ -0,0 +1,270 @@+{-| GCode evaluator++Evaluates RS274 GCode++-}+{-# LANGUAGE RecordWildCards #-}+module Data.GCode.Eval where++import Data.Maybe+import Data.Monoid+import Data.Map (Map)++import qualified Data.Map++import Data.GCode.Ann (Ann(SrcLine))+import Data.GCode.Types+import Data.GCode.RS274+import Data.GCode.RS274.Types+import Data.GCode.Utils+import Data.GCode.Canon (Canon)+import Data.GCode.Canon.Convert++-- | Interpreter state+data IPState = IPState {+ ipModalGroups :: Map RS274Group Code+ , ipPosition :: Axes+ , ipLine :: Integer+ } deriving (Eq, Show, Ord)++-- | Default modals+defaultModals :: Map RS274Group Code+defaultModals = Data.Map.fromList [+ (Units , millimeters)+ , (Distance , absolute)+ , (ArcDistance, absolute)+ ]++-- | Create new interpreter state+newState :: IPState+newState = IPState {+ ipModalGroups = defaultModals+ , ipPosition = mempty+ , ipLine = 0+ }++-- | Step `Code` interpreter+step :: IPState -> GCode -> (Maybe Code, IPState, GCode)+step is [] = (Nothing, is, [])+step is@IPState{..} (x@Code{}:xs) =+ let (newCode, newModals) = updateCodeAndModals x ipModalGroups+ -- update position with new codeAxes+ newPosition = updateAxes ipPosition (codeAxes newCode)+ in (Just $ newCode+ , is { ipModalGroups = newModals+ , ipPosition = newPosition+ , ipLine = ipLine + 1 }+ , xs)+-- handle empty/comments/other+step is (_:xs) = (Nothing, is, xs)++-- | Evaluate GCode and return each evaluation step+evalSteps :: [Code] -> [([Maybe Code], IPState, [Code])]+evalSteps gcode = go initState+ where+ initState = ([], newState, gcode)+ go x@(_, _, []) = [x]+ go x@(acc, st, codes) = let (result, steppedState, rest) = step st codes in x:(go (result:acc, steppedState, rest))++-- interpreter *always* runs+-- * in absolute mode+-- * with millimeters as units+-- * with total commands in modal groups+-- convert accordingly!+-- | Convert all axis coordinates from inches to millimeters if needed+toMillimeters :: Map RS274Group Code -> Code -> Code+toMillimeters modals x | codeActive millimeters modals = x+toMillimeters modals x | codeActive inches modals = x & axes (Data.Map.map (*25.4) (codeAxes x))+ & modifyParams [F, R, I, J, K] (*25.4)+toMillimeters _ _ | otherwise = error "Neither millimeters nor inches set"++-- | Convert all motion coordinates from relative to absolute+toAbsolute :: Map RS274Group Code -> Code -> Code+toAbsolute modals x | codeActive relative modals && isMotion x =+ case Data.Map.lookup Motion modals of -- motion group+ Nothing -> x+ (Just e) -> x & (axes $ addRelative (codeAxes x) (codeAxes e))+ where+ addRelative :: Axes -> Axes -> Axes+ addRelative existing new = Data.Map.unionWith (+) existing new+toAbsolute _ x | otherwise = x++-- | Convert all arc coordinates from relative to absolute+toAbsoluteArcs :: Map RS274Group Code -> Code -> Code+toAbsoluteArcs modals c | codeActive arcRelative modals && isMotion c =+ case Data.Map.lookup Motion modals of -- motion group+ Nothing -> c+ (Just e) -> c & modifyParamsWithKey [I, J, K] (addRespective e)+ where+ addRespective code I x | hasAxis X code = fromJust (getAxis X code) + x+ addRespective code J x | hasAxis Y code = fromJust (getAxis Y code) + x+ addRespective code K x | hasAxis Z code = fromJust (getAxis Z code) + x+ addRespective _ _ x | otherwise = x+toAbsoluteArcs _ c | otherwise = c++-- | Return True if `code` is active (present) in `modals`+codeActive :: Code -> Map RS274Group Code -> Bool+codeActive code modals = case Data.Map.lookup (decimate code) codesToGroups of+ Just group -> Data.Map.lookup group (Data.Map.map decimate modals) == (Just $ decimate code)+ Nothing -> False++-- | Return True if `code` is a motion comand+isMotion :: Code -> Bool+isMotion = flip codeInGroup Motion++-- | Update `code` according to current `modals`+-- then update `modals` with a resulting code+--+-- Return updated code and modals+updateCodeAndModals :: Code+ -> Map RS274Group Code+ -> (Code, Map RS274Group Code)+updateCodeAndModals code modals =+ -- first we update current GCode with missing data+ let newCode = updateFromCurrentModals modals+ $ updateIncompleteFromCurrentModals modals+ $ toAbsoluteArcs modals+ $ toAbsolute modals+ $ toMillimeters modals code+ -- then we update stored modal groups with updated GCode+ newModals = updateModals modals newCode+ in (newCode, newModals)++-- | Update modal groups according to Code `c`+updateModals :: Map RS274Group Code+ -> Code+ -> Map RS274Group Code+updateModals current c = case Data.Map.lookup (decimate c) codesToGroups of+ Nothing -> current+ Just group -> Data.Map.insert group c current++-- | Take current motion group modal code and update this motion code+-- with missing coordinates of the stored one+updateFromCurrentModals :: Map RS274Group Code -> Code -> Code+updateFromCurrentModals modals x | isMotion x = do+ case Data.Map.lookup Motion modals of -- motion group+ Nothing -> x+ (Just e) -> x & (axes $ appendOnlyAxes (codeAxes x) (codeAxes e))+updateFromCurrentModals _ x | otherwise = x++-- | Return True if this code contains only coordinates+incomplete :: Code -> Bool+incomplete Code{codeCls=Nothing, codeNum=Nothing, ..} | (Data.Map.null codeAxes /= True) = True+incomplete _ = False++-- | Update incomplete motion Code with the stored one+updateIncompleteFromCurrentModals :: Map RS274Group Code -> Code -> Code+updateIncompleteFromCurrentModals modals x | incomplete x = do+ case Data.Map.lookup Motion modals of -- motion group+ Nothing -> x+ (Just e) -> appEndo (mconcat $ map Endo [+ (cls $ fromJust $ codeCls e)+ , (num $ fromJust $ codeNum e)+ , (axes $ appendOnlyAxes (codeAxes x) (codeAxes e))+ ]) x+updateIncompleteFromCurrentModals _ x | otherwise = x++-- | Update axes that aren't defined in target+appendOnlyAxes :: Ord k => Map k b -> Map k b -> Map k b+appendOnlyAxes target from = Data.Map.union target missingOnly+ where missingOnly = Data.Map.difference from target++-- | Update (replace) `target` axes with `from` axes+updateAxes :: Ord k => Map k a -> Map k a -> Map k a+updateAxes target from = Data.Map.union from target -- union in this order so `from` axes are preferred++-- | Update `Limits` from this `Code`+updateLimitsCode :: Limits -> Code -> Limits+updateLimitsCode s Code{..} = updateLimits s codeAxes+updateLimitsCode s _ = s++-- | Update `Limits` from `Axes`+updateLimits :: Limits -> Axes -> Limits+updateLimits s = Data.Map.foldlWithKey adj s+ where+ adj limits ax val = Data.Map.alter (alterfn val) ax limits+ alterfn val (Just (min_c, max_c)) = Just (min min_c val, max max_c val)+ alterfn val Nothing = Just (val, val)++-- Slow evaluators for testing, use streaming variants from `Data.GCode.Pipes` instead.++-- | Fully evaluate GCode+eval :: GCode -> ([Code], IPState)+eval = evalWith (\res _state -> Just res)++-- | Evaluate GCode to canonical representation+evalToCanon :: GCode -> ([Canon], IPState)+evalToCanon = evalWith' (\c _ips -> toCanon c)++-- | Evaluate GCode to annotated canonnical representation+evalToCanonAnn :: GCode -> ([Ann Canon], IPState)+evalToCanonAnn = evalWith' toCanonAnn++-- | Same as toCanon but result is wrapped in `Ann`+-- according to current interpreter line+toCanonAnn :: Code -> IPState -> [Ann Canon]+toCanonAnn c is = SrcLine (ipLine is) <$> toCanon c++-- | Evaluate GCode and and apply function `f` to each successfuly+-- evaluated Code+--+-- Slow due to list concatenation, use streaming variants from `Data.GCode.Pipes` instead.+evalWith :: (Code -> IPState -> Maybe a)+ -> GCode+ -> ([a], IPState)+evalWith f gcode = let (accumulator, resultState, []) = go initState in (catMaybes accumulator, resultState)+ where+ initState = ([], newState, gcode)+ go x@(_, _, []) = x+ go (acc, st, codes) =+ let (result, steppedState, rest) = step st codes+ mapped = case result of+ Nothing -> Nothing+ Just x -> f x steppedState+ in go (acc ++ [mapped], steppedState, rest)++-- Like `evalWith` but allows multiple elements to be generated+evalWith' :: (Code -> IPState -> [a])+ -> GCode+ -> ([a], IPState)+evalWith' f gcode =+ let (accumulator, resultState, []) = go initState+ in (accumulator, resultState)+ where+ initState = ([], newState, gcode)+ go x@(_, _, []) = x+ go (acc, st, codes) =+ let (result, steppedState, rest) = step st codes+ mapped = case result of+ Nothing -> []+ Just r -> f r steppedState+ in go (acc ++ mapped, steppedState, rest)++-- | Walk GCode adding missing axes coordinates according to previous moves+--+-- For example+-- G0 X1+-- G0 Y2+-- G0 Z3+--+-- becomes+-- G0 X1+-- G0 X1 Y2+-- G0 X1 Y2 Z3+--+-- also+--+-- G0 X1+-- Y2 Z2+--+-- becomes+--+-- G0 X1+-- G0 X1 Y2 Z2+totalize :: GCode -> GCode+totalize = totalize' defaultModals+ where+ totalize' _ [] = []+ totalize' modals (x:rest) =+ let (newCode, newModals) = updateCodeAndModals x modals+ in (newCode:totalize' newModals rest)
+ src/Data/GCode/Generate.hs view
@@ -0,0 +1,115 @@+{-| GCode generation++GCode generation functions & shortcuts++-}+module Data.GCode.Generate where++import Data.GCode.Types+import Data.GCode.RS274+import Data.GCode.Utils++-- |Generate G Code+g :: Code+g = cls G emptyCode++-- |Generate M Code+m :: Code+m = cls M emptyCode++-- |Generate S (set spindle feedrate) Code+s :: Code+s = emptyCode & cls SStandalone++-- |Set GCode number+(<#>) :: Code -> Int -> Code+(<#>) a n = num n a++-- |Set GCode feedrate (F parameter)+feed :: Double -> Code -> Code+feed = param F++-- |Set `x` axis target+x :: Double -> Code -> Code+x = axis X++-- |Set `y` axis target+y :: Double -> Code -> Code+y = axis Y++-- |Set `z` axis target+z :: Double -> Code -> Code+z = axis Z++-- |Set `x`, `y` coordinates for this Code+xy :: Double -> Double -> Code -> Code+xy xVal yVal = x xVal . y yVal++-- |Set `x`, `y` and `z` coordinates+xyz :: Double -> Double -> Double -> Code -> Code+xyz xVal yVal zVal = x xVal . y yVal . z zVal++-- |Set G0 and `x`, `y` coordinates+movexy :: Double -> Double -> Code+movexy xVal yVal = move & xy xVal yVal++-- |Set `i`, `j` parameters for this Code+ij :: Double -> Double -> Code -> Code+ij iVal jVal = param I iVal . param J jVal++arc :: Code+arc = arcCW++-- |Generate points on a rectangle+rectangle :: (Num a, Num b) => a -> b -> [(a, b)]+rectangle xv yv = [(0, 0), (xv, 0), (xv, yv), (0, yv), (0,0)]++-- |Rotate X/Y coordinates by angle `by`+rot :: Floating b => b -> b -> b -> (b, b)+rot by xv yv = (xv * (cos by) - yv * (sin by), yv * (cos by) + xv * (sin by))++-- |Generate a list of points laying on a circle with radius `r`, divides circle in `steps` number of points+circle :: (Floating b, Enum b) => b -> b -> [(b, b)]+circle r steps = map (\step -> rot (step * 2*pi / steps) (r/2) 0) [1..steps]++-- |As `circle` with rotated by `rin`+circle' :: (Floating b, Enum b) => b -> b -> b -> [(b, b)]+circle' rin r steps = map (\step -> rot (rin + step * 2*pi / steps) (r/2) 0) [1..steps]++-- |As `circle` but origin is the same as end point+closedCircle :: (Floating a, Enum a) => a -> a -> [(a, a)]+closedCircle r steps = map (\step -> rot (step * 2*pi / steps) (r/2) 0) [1..(steps+1)]++-- |Join list of GCodes with travel moves inbetween+travelCat :: Code -> Code -> [GCode] -> [Code]+travelCat up down (block:rest) = (travel up down block) ++ (travelCat up down rest)+travelCat _ _ [] = []++-- |Join list of drilling GCodes with travel moves inbetween+travelCatDrill :: Code -> [GCode] -> [Code]+travelCatDrill up (block:rest) = (travelDrills up block) ++ (travelCatDrill up rest)+travelCatDrill _ [] = []++-- |Prepend codes with tool up command, rapid move to block start and tool down command+--+-- Prepends `up` GCode representing tool moving up before+-- rapid move followed by `down` command to move tool down again.+travel :: Code -> Code -> GCode -> GCode+travel up down (c:rest) = [up, asRapidXY c, down, c] ++ rest+travel _ _ [] = []++-- |Prepend drilling codes with tool up command and rapid moves+--+-- Prepends `up` GCode representing tool moving up before+-- rapid move to start of this block+travelDrills :: Code -> GCode -> GCode+travelDrills up block = travel up emptyCode block++-- |Take X and Y coordinates of this code+-- and turn it into rapid move+asRapidXY :: Code -> Code+asRapidXY c@Code{} =+ case getAxes [X,Y] c of+ [Just xv, Just yv] -> rapid & xy xv yv+ _ -> c+asRapidXY c = c
+ src/Data/GCode/Generate/Examples.hs view
@@ -0,0 +1,95 @@+{-| Examples of GCode generation++-}+module Data.GCode.Generate.Examples where++import Data.GCode+import Data.GCode.Generate+import Data.GCode.RS274++allExamples :: [(String, GCode)]+allExamples = [+ ("encoder_wheel_drilling", fst $ encoderWheel)+ , ("encoder_wheel_milling", snd $ encoderWheel)+ , ("rectangle10x20", rectangle10mm20mm)+ ]++preamble :: [Code]+preamble = [+ unitsPerMinute+ , absolute+ , millimeters+ , g <#> 0 & param F 3000+ , s <#> 12000+ , spindleCW+ , dwell & param P 10+ ]++postamble :: [Code]+postamble = [+ spindleStop+ , coolantStop+ , programEnd+ ]++returnZ :: Double+returnZ = 1++safeZ :: Double+safeZ = 2++workZ :: Double+workZ = (-2)++rapidFeedrate :: Double+rapidFeedrate = 250++downFeedrate :: Double+downFeedrate = 150++up :: Code+up = rapid & z safeZ & feed rapidFeedrate++down :: Code+down = move & z workZ & feed downFeedrate++program :: [Code] -> [Code]+program code = preamble ++ code ++ postamble++rectangle10mm20mm :: GCode+rectangle10mm20mm = program $ map (uncurry movexy) (rectangle 10 20)++encoderWheel :: (GCode, GCode)+encoderWheel =+ let encoderRadius = 50+ encoderSteps = 100+ drillRadius = 0.6+ endmillRadius = 3.175+ innerOffset = 4+ encoderRadiusInner = encoderRadius - (2*drillRadius) - innerOffset++ -- drilling+ drillPoints = circle encoderRadius encoderSteps+ drillPointsInner = circle' (2*pi/360 * (360 / 200) * 1.5) encoderRadiusInner encoderSteps++ drill xv yv = drillingCycle & xyz xv yv workZ & feed 250 & param R returnZ+ drillBlocks = [ map (uncurry drill) drillPoints+ , map (uncurry drill) drillPointsInner ]+ -- milling+ anchor = circle (5.3 - endmillRadius) 360+ anchorPositions = circle (30) 4++ anchors = travelCat up down $ map (\(xc, yc) ->+ map (\(xv, yv) -> movexy (xc + xv) (yc + yv)) anchor)+ anchorPositions++ encInner = circle (10.4 - endmillRadius) 360+ encOuter = circle (encoderRadius + innerOffset + endmillRadius) 3600++ cut = map (uncurry movexy)+ inner = cut encInner+ outer = cut encOuter++ in ( program $ travelCatDrill up drillBlocks+ , program $ travelCat up down [inner, anchors, outer]+ )
+ src/Data/GCode/Generate/ExamplesMonad.hs view
@@ -0,0 +1,23 @@+module Data.GCode.Generate.ExamplesMonad where++import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.State++import Data.GCode.Generate (x, xy)+import Data.GCode.Monad++xprog :: Program+xprog = prog $ do+ move (x 10)+ rapid (xy 15 15)+ move (xy 0 0)+ coolantStop'++withState :: Program+withState = prog $ do+ void $ flip runStateT 0 $ do+ val <- get+ lift $ rapid (x val)+ forM_ (zip [0..10] [-10..0]) (move . uncurry xy)+
+ src/Data/GCode/Line.hs view
@@ -0,0 +1,74 @@+module Data.GCode.Line (+ Line(..)+ , LineType(..)+ , toLines+ , prettyLine+ ) where++{-+Conversion to `Line` from one set of points to another.+Useful for GCode visualisation tools.+-}++import Data.GCode.Canon (Canon(..), CanonState(..))+import Data.GCode.Types (Axes, Style(..))++import Text.PrettyPrint.ANSI.Leijen++import qualified Data.GCode.Pretty++-- | Given two states of `Canon` interpreter output `Line` or empty list+-- if no line is produced by this `Canon`.+toLines :: CanonState -> CanonState -> Canon -> [Line]+toLines prevS nextS code | isTravelMove code || isSetCoords code = pure $ Line+ (travelMoveType code)+ (canonPosition prevS)+ (canonPosition nextS)+toLines _ _ _ | otherwise = mempty++data LineType =+ LineTraverse -- ^ Travel move+ | LineDrawing -- ^ Machining/drawing move+ | LineJump -- ^ Produced by set coordinates `SetCoords`+ deriving (Eq, Show, Ord)++data Line = Line+ LineType -- ^ Travel, drawing or set coordinates move+ Axes -- ^ Start points+ Axes -- ^ End points+ deriving (Eq, Show, Ord)++-- | Pretty print `Line`+prettyLine :: Style -> Line -> String+prettyLine style x = displayS ((renderer style) (ppLine style x)) ""+ where renderer style' | styleColorful style' == True = renderPretty 0.4 80+ renderer _ = renderCompact++ppLine :: Style -> Line -> Doc+ppLine style (Line typ from to) =+ ppTyp typ+ <+> string "from"+ <+> Data.GCode.Pretty.ppAxesMap style from+ <+> string "to"+ <+> Data.GCode.Pretty.ppAxesMap style to+ where+ ppTyp LineTraverse = char ' '+ ppTyp LineDrawing = char '*'+ ppTyp LineJump = char '>'++-- Helpers++isTravelMove :: Canon -> Bool+isTravelMove (StraightTraverse _) = True+isTravelMove (StraightFeed _) = True+isTravelMove _ = False++isSetCoords :: Canon -> Bool+isSetCoords (SetCoords _) = True+isSetCoords _ = False++travelMoveType :: Canon -> LineType+travelMoveType (StraightTraverse _) = LineTraverse+travelMoveType (StraightFeed _) = LineDrawing+travelMoveType (SetCoords _) = LineJump+travelMoveType _ = error "travelMoveType: Not a travel move"
+ src/Data/GCode/Monad.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module Data.GCode.Monad where++import Data.GCode.TH+import Data.GCode.Types+import Data.GCode.RS274.Types+import Data.GCode.RS274 (codeFromName)++import Control.Monad.Trans.Writer.Lazy+import Data.Semigroup hiding (option)++ -- this gives us someCode and someCode' shortcuts generated from RS274/Types.hs+-- so we can write+-- > myP = prog $ do+-- > rapid (xy 5 10)+-- > move (x 0)+$(genWriterEndos ''RS274Name)++data Program = Program { programCode :: GCode }+ deriving (Eq, Show)++type ProgramWriter a = Writer (Endo Program) a++gen :: Code -> ProgramWriter ()+gen c = tell $ Endo (\x -> x { programCode = c:(programCode x) } )++prog :: ProgramWriter a -> Program+prog builder = appEndo (execWriter (builder >> programEnd')) (Program mempty)++generateName = gen . codeFromName+generateNameArgs name endoF = gen $ codeFromName name & endoF
src/Data/GCode/Parse.hs view
@@ -1,19 +1,26 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+ {-| GCode parsing functions -} -{-# LANGUAGE OverloadedStrings #-} module Data.GCode.Parse (parseGCode, parseGCodeLine, parseOnlyGCode) where import Data.GCode.Types -import Prelude hiding (take, takeWhile, mapM) import Control.Applicative-import qualified Data.ByteString as B++import Prelude hiding (take, takeWhile, mapM) import Data.Attoparsec.ByteString.Char8-import qualified Data.Map.Strict as M -import Data.Either (lefts, rights)+import Data.ByteString (ByteString) +import qualified Data.ByteString+import qualified Data.Char+import qualified Data.Either+import qualified Data.Map+import qualified Data.Maybe+ -- |Parse single line of G-code into 'Code' parseGCodeLine :: Parser Code parseGCodeLine = between lskip lskip parseCodeParts <* endOfLine@@ -23,33 +30,39 @@ parseGCode = many1 parseGCodeLine -- |Parse lines of G-code returning either parsing error or 'GCode'-parseOnlyGCode :: B.ByteString -> Either String GCode+parseOnlyGCode :: ByteString -> Either String GCode parseOnlyGCode = parseOnly parseGCode -+lskip :: Parser () lskip = skipWhile (\x -> x == ' ' || x == '\t')-between open close p = do{ open; x <- p; close; return x } +between :: Monad m => m a1 -> m a2 -> m b -> m b+between open close p = do { _ <- open; x <- p; _ <- close; return x }+ isEndOfLineChr :: Char -> Bool isEndOfLineChr '\n' = True isEndOfLineChr '\r' = True isEndOfLineChr _ = False +parseLead :: Parser Class parseLead = do- a <- satisfy $ (\c -> c == 'G' || c == 'M' || c == 'T' || c == 'P' || c == 'F' || c == 'S')- return $ codecls a+ a <- satisfy $ inClass $ (asChars allClasses) ++ (map Data.Char.toLower $ asChars allClasses)+ return $ Data.Maybe.fromJust $ toCodeClass a {-# INLINE parseLead #-} +parseAxisDes :: Parser AxisDesignator parseAxisDes = do- a <- satisfy $ (\c -> c == 'X' || c == 'Y' || c == 'Z' || c == 'A' || c == 'B' || c == 'C' || c == 'E' || c == 'L')- return $ axis a+ a <- satisfy $ inClass $ asChars allAxisDesignators+ return $ Data.Maybe.fromJust $ toAxis a {-# INLINE parseAxisDes #-} +parseParamDes :: Parser ParamDesignator parseParamDes = do- a <- satisfy $ inClass "SPF"- return $ param a+ a <- satisfy $ inClass $ asChars allParamDesignators+ return $ Data.Maybe.fromJust $ toParam a {-# INLINE parseParamDes #-} +parseParamOrAxis :: Parser (Either (AxisDesignator, Double) (ParamDesignator, Double)) parseParamOrAxis = do lskip ax <- option Nothing (Just <$> parseAxisDes)@@ -59,45 +72,49 @@ f <- double return $ Left (val, f) Nothing -> do- param <- parseParamDes+ paramDes <- parseParamDes lskip f <- double- return $ Right (param, f)+ return $ Right (paramDes, f) parseAxesParams :: Parser (Axes, Params) parseAxesParams = do a <- many parseParamOrAxis- return (M.fromList $ lefts a, M.fromList $ rights a)+ return (Data.Map.fromList $ Data.Either.lefts a, Data.Map.fromList $ Data.Either.rights a) {-# INLINE parseAxesParams #-} -+parseCode :: Parser Code parseCode = do- lead <- optional parseLead- gcode <- optional decimal- subcode <- optional (char '.' *> decimal)+ codeCls <- optional parseLead+ codeNum <- optional decimal+ codeSub <- optional (char '.' *> decimal) lskip- (axes, params) <- parseAxesParams+ (codeAxes, codeParams) <- parseAxesParams lskip- comment <- option "" $ between lskip lskip parseComment'- let c = Code lead gcode subcode axes params comment+ codeComment <- option "" $ between lskip lskip parseComment'+ let c = Code{..} if c == emptyCode then return $ Empty else return c +parseComment' :: Parser ByteString parseComment' = do t <- many $ between (lskip *> char '(') (char ')' <* lskip) $ takeWhile1 (/=')') -- semiclone prefixed comments semisep <- option "" $ char ';' *> takeWhile (not . isEndOfLineChr) rest <- takeWhile (not . isEndOfLineChr)- return $ B.concat $ t ++ [semisep, rest]+ return $ Data.ByteString.concat $ t ++ [semisep, rest] +parseComment :: Parser Code parseComment = Comment <$> parseComment' +parseOther :: Parser Code parseOther = do a <- takeWhile (not . isEndOfLineChr) return $ Other a +parseCodeParts :: Parser Code parseCodeParts = parseCode- <|> parseComment <|> parseOther+ <|> parseComment
+ src/Data/GCode/Pipes.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE OverloadedStrings #-}+module Data.GCode.Pipes where++import Control.Monad+import Control.Monad.Trans.State.Strict++import Data.ByteString (ByteString)++import System.IO (Handle)++import Data.GCode.Types+import Data.GCode.Canon+import Data.GCode.Eval+import Data.GCode.Line+import Data.GCode.Parse+import Data.GCode.Pretty+import qualified Data.GCode.Canon.Convert++import Pipes+import Pipes.Attoparsec (ParsingError)+import Pipes.Safe (SafeT)++import qualified Data.ByteString.Char8+import qualified Data.Map.Strict+import qualified Pipes.Attoparsec+import qualified Pipes.ByteString+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) ()) ())+parseProducer = parseProducer' 1024++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)++withFile :: FilePath -> (Handle -> (SafeT IO) r) -> IO r+withFile filepath job =+ System.IO.withFile filepath System.IO.ReadMode $ \handle ->+ Pipes.Safe.runSafeT $ job handle++pipeToList :: FilePath -> Proxy () Code () a (SafeT IO) () -> IO [a]+pipeToList filepath pipeTail = withFile filepath $ \h ->+ Pipes.Prelude.toListM+ $ (() <$ parseProducer h)+ >-> pipeTail++gcodeToCanonList :: FilePath -> IO [Canon]+gcodeToCanonList filepath = pipeToList filepath $ evalP >-> evalCanonP++gcodeToLines :: FilePath -> IO [Line]+gcodeToLines filepath = pipeToList filepath $ evalP >-> evalCanonLinesP++gcodePipe :: FilePath -> (Consumer Code (SafeT IO) ()) -> IO ()+gcodePipe filepath pipeTail =+ System.IO.withFile filepath System.IO.ReadMode $ \handle ->+ Pipes.Safe.runSafeT . runEffect $+ (() <$ parseProducer handle)+ >-> pipeTail++-- needs better name+runPipe :: FilePath+ -> Maybe FilePath+ -> (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++totalizeP :: Pipe Code Code (SafeT IO) ()+totalizeP = flip evalStateT Data.Map.Strict.empty $ forever $ do+ x <- lift await+ inEffect <- get+ let updatedCode = updateFromCurrentModals inEffect x+ updatedModals = updateModals inEffect updatedCode++ put updatedModals+ lift $ yield updatedCode++evalP :: Pipe Code Code (SafeT IO) ()+evalP = flip evalStateT newState $ forever $ do+ x <- lift await+ st <- get+ let (result, steppedState, _rest) = step st [x]+ -- XXX: add pretty printer for IPState+ --liftIO $ print steppedState+ put steppedState+ case result of+ Just r -> lift $ yield r+ Nothing -> return ()++evalCanonP :: Pipe Code Canon (SafeT IO) ()+evalCanonP = 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++evalCanonLinesP :: Pipe Code Line (SafeT IO) ()+evalCanonLinesP = 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+ forM_ (toLines st steppedState c) $ lift . yield++-- mmaped experiment, requires pipes-bytestring-mmap+--import qualified Pipes.ByteString.MMap+--main' = do+-- file <- fmap Prelude.head getArgs+-- Pipes.Safe.runSafeT . Pipes.Safe.runEffect $+-- (() <$ Pipes.Attoparsec.parsed parseGCodeLine (Pipes.ByteString.MMap.unsafeMMapFile file) )+-- >-> Pipes.Prelude.map ppGCodeLine+-- >-> Pipes.Prelude.stdoutLn++-- pretty print+prettySinkWith :: (a -> ByteString) -> Pipe a ByteString (SafeT IO) ()+prettySinkWith fn =+ Pipes.Prelude.map fn++prettySink :: Pipe Code ByteString (SafeT IO) ()+prettySink =+ Pipes.Prelude.map ppGCodeLine+ >-> Pipes.Prelude.map (Data.ByteString.Char8.pack . (++"\n"))++compactSink :: Pipe Code ByteString (SafeT IO) ()+compactSink =+ Pipes.Prelude.map ppGCodeLineCompact+ >-> Pipes.Prelude.map (Data.ByteString.Char8.pack . (++"\n"))++-- Helpers++addNewLine :: ByteString -> ByteString+addNewLine to = Data.ByteString.Char8.append to "\n"++wrapPrinter :: (a -> String) -> a -> ByteString+wrapPrinter p = addNewLine . Data.ByteString.Char8.pack . p
+ src/Data/GCode/Pipes/Transform.hs view
@@ -0,0 +1,29 @@+module Data.GCode.Pipes.Transform where+{--++These are remnants from refactoring Main with various degree of usability.++Do not rely on these as they might get removed (or ideally improved) in future versions.++--}++import Data.GCode+import Data.GCode.Generate (rot)++import Pipes+import qualified Pipes.Prelude as P++translateXY :: Functor m => Double -> Double -> Pipe Code Code m r+translateXY xtrans ytrans = P.map (modifyXY (\x y -> (x + xtrans, y + ytrans)))++translateZ :: Functor m => Double -> Pipe Code Code m r+translateZ ztrans = P.map (modifyAxis Z (+ztrans))++rotate :: Functor m => Double -> Pipe Code Code m r+rotate angle = P.map (modifyXY (rot (angle*pi/180)))++scaleFeedrate :: Functor m => Double -> Pipe Code Code m r+scaleFeedrate factor = P.map (modifyFeedrate (*factor))++scaleXY :: Functor m => Double -> Double -> Pipe Code Code m r+scaleXY xsc ysc = P.map (modifyXY (\x y -> (x*xsc, y*ysc)))
src/Data/GCode/Pretty.hs view
@@ -7,79 +7,96 @@ -} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-}-module Data.GCode.Pretty(ppGCode, ppGCodeLine, ppGCodeCompact, ppGCodeLineCompact) where+module Data.GCode.Pretty(+ ppGCode+ , ppGCodeLine+ , ppGCodeCompact+ , ppGCodeLineCompact+ , ppGCodeStyle+ , ppGCodeLineStyle+ , ppAxes+ , ppAxesMap+ ) where -import Data.ByteString.Char8 (pack, unpack)-import qualified Data.Text as T-import qualified Data.Map.Strict as M-import Data.Maybe+import Data.Map (Map)+import Data.ByteString (ByteString) -import Text.PrettyPrint.ANSI.Leijen-import Data.GCode.Types-import Data.GCode.Utils+import qualified Data.ByteString.Char8+import qualified Data.Double.Conversion.Text+import qualified Data.Map+import qualified Data.Text -import Data.Double.Conversion.Text+import Data.GCode.Types+import Text.PrettyPrint.ANSI.Leijen --- |Pretty-print 'GCode' using colors+-- | Pretty-print 'GCode' using colors ppGCode :: GCode -> String-ppGCode = ppGCodeStyle defaultStyle---- |Pretty-print 'GCode' using colors with custom floating precision width-ppGCodeStyle :: Style -> GCode -> String-ppGCodeStyle style res = displayS (renderPretty 0.4 80 (ppGCode' style res)) ""+ppGCode = ppGCodeStyle (defaultStyle { styleColorful = True }) --- |Pretty-print single 'Code' using colors+-- | Pretty-print single 'Code' using colors ppGCodeLine :: Code -> String-ppGCodeLine = ppGCodeLineStyle defaultStyle---- |Pretty-print single 'Code' using colors with custom floating precision width-ppGCodeLineStyle :: Style -> Code -> String-ppGCodeLineStyle style res = displayS (renderPretty 0.4 80 (ppCode style res)) ""+ppGCodeLine = ppGCodeLineStyle (defaultStyle { styleColorful = True }) --- |Pretty-print 'GCode' without colors+-- | Pretty-print 'GCode' without colors ppGCodeCompact :: GCode -> String-ppGCodeCompact = ppGCodeCompactStyle defaultStyle---- |Pretty-print 'GCode' without colors with custom floating precision width-ppGCodeCompactStyle :: Style -> GCode -> String-ppGCodeCompactStyle style res = displayS (renderCompact (ppGCode' style res)) ""+ppGCodeCompact = ppGCodeStyle defaultStyle --- |Pretty-print single 'Code' without colors+-- | Pretty-print single 'Code' without colors ppGCodeLineCompact :: Code -> String-ppGCodeLineCompact = ppGCodeLineCompactStyle defaultStyle+ppGCodeLineCompact = ppGCodeLineStyle defaultStyle --- |Pretty-print single 'Code' without colors with custom floating precision width-ppGCodeLineCompactStyle :: Style -> Code -> String-ppGCodeLineCompactStyle style res = displayS (renderCompact (ppCode style res)) ""+-- | Pretty-print 'GCode' with specified `Style`+ppGCodeStyle :: Style -> GCode -> String+ppGCodeStyle style res = displayS ((renderer style) (ppGCode' style res)) ""+ where renderer style' | styleColorful style' == True = renderPretty 0.4 80+ renderer _ = renderCompact +-- | Pretty-print single 'Code' with specified `Style`+ppGCodeLineStyle :: Style -> Code -> String+ppGCodeLineStyle style res = displayS ((renderer style) (ppCode style res)) ""+ where renderer style' | styleColorful style' == True = renderPretty 0.4 80+ renderer _ = renderCompact++ppList :: (a -> Doc) -> [a] -> Doc ppList pp x = hsep $ map pp x -ppGCode' style = vsep . map (ppCode style)+ppGCode' :: Style -> [Code] -> Doc+ppGCode' style code = (vsep $ map (ppCode style) code) <> hardline +ppMaybe :: (t -> Doc) -> Maybe t -> Doc ppMaybe pp (Just x) = pp x-ppMaybe pp Nothing = empty+ppMaybe _ Nothing = empty +ppMaybeClass :: Maybe Class -> Doc ppMaybeClass = ppMaybe ppClass -ppClass G = yellow $ text "G"-ppClass M = red $ text "M"-ppClass T = magenta $ text "T"-ppClass StP = red $ text "P"-ppClass StF = red $ text "F"-ppClass StS = red $ text "S"+ppClass :: Class -> Doc+ppClass G = yellow $ text "G"+ppClass M = red $ text "M"+ppClass T = magenta $ text "T"+ppClass PStandalone = red $ text "P"+ppClass FStandalone = red $ text "F"+ppClass SStandalone = red $ text "S" -ccMaybes (Just cls) (Just num) = cc cls num+ccMaybes :: (Eq a, Num a) => Maybe Class -> Maybe a -> Doc -> Doc+ccMaybes (Just cls') (Just num') = cc cls' num' ccMaybes _ _ = id +cc :: (Eq a, Num a) => Class -> a -> Doc -> Doc cc G 0 = dullyellow cc G 1 = yellow cc _ _ = red +ppAxis :: Style -> (AxisDesignator, Double) -> Doc ppAxis style (des, val) = bold (axisColor des $ text $ show des)- <> cyan (text $ T.unpack $ toPrecision (stylePrecision style) val)-+ <> cyan (+ text+ $ Data.Text.unpack+ $ Data.Double.Conversion.Text.toFixed (stylePrecision style) val+ ) +axisColor :: AxisDesignator -> Doc -> Doc axisColor X = red axisColor Y = green axisColor Z = yellow@@ -87,29 +104,50 @@ axisColor B = green axisColor C = blue axisColor E = magenta+axisColor _ = id -ppAxes _ [] = empty-ppAxes style x = space <> ppList (ppAxis style) x+ppAxes :: Style -> [(AxisDesignator, Double)] -> Doc+ppAxes style x = ppList (ppAxis style) x +ppAxesMap :: Style -> Map AxisDesignator Double -> Doc+ppAxesMap style x = ppList (ppAxis style) (Data.Map.toList x)++ppParam :: Show a => Style -> (a, Double) -> Doc ppParam style (des, val) = bold (blue $ text $ show des)- <> white (text $ T.unpack $ toPrecision (stylePrecision style) val)+ <> white (+ text+ $ Data.Text.unpack+ $ Data.Double.Conversion.Text.toFixed (stylePrecision style) val+ ) +ppParams :: Show a => Style -> [(a, Double)] -> Doc ppParams _ [] = empty ppParams style x = space <> ppList (ppParam style) x +ppComment :: ByteString -> Doc ppComment "" = empty ppComment c = space <> ppComment' c++ppComment' :: ByteString -> Doc ppComment' "" = empty-ppComment' c = dullwhite $ parens $ text $ unpack c+ppComment' c = dullwhite $ parens $ text $ Data.ByteString.Char8.unpack c +ppCode :: Style -> Code -> Doc ppCode style Code{..} = ccMaybes codeCls codeNum ( bold $ ppMaybeClass codeCls) <> ccMaybes codeCls codeNum ( ppMaybe (text . show) codeNum)- <> ppAxes style (M.toList codeAxes)- <> ppParams style (M.toList codeParams)+ <> ppMaybe (\x -> (text ".") <> (text $ show x)) codeSub+ <> ifNonEmpty (\x -> space <> ppAxesMap style x) codeAxes+ <> ppParams style (Data.Map.toList codeParams) <> ppComment codeComment ppCode _ (Comment x) = ppComment' x-ppCode _ (Other x) = dullred $ text $ unpack x+ppCode _ (Other x) = dullred $ text $ Data.ByteString.Char8.unpack x ppCode _ (Empty) = empty {-# INLINE ppCode #-}++ifNonEmpty :: (Eq t, Monoid t)+ => (t -> Doc)+ -> t -> Doc+ifNonEmpty _ x | x == mempty = empty+ifNonEmpty f x | otherwise = f x
+ src/Data/GCode/RS274.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module Data.GCode.RS274 where++import Data.GCode.TH+import Data.GCode.Types+import Data.GCode.RS274.Types++import Data.Maybe (fromJust)+import qualified Data.Map.Strict as M++$(genShortcuts ''RS274Name)++namesToCodes = M.fromList . map (\x -> (defName x, toCode x)) $ allCodes+codesToNames = M.fromList . map (\x -> (toCode x, defName x)) $ allCodes+codesToGroups = M.fromList . map (\x -> (toCode x, defGroup x)) $ allCodes++codesToDefs = M.fromList . map (\x -> (toCode x, x)) $ allCodes++codeIsRS274 code name = (M.lookup (decimate code) codesToNames) == (Just name)+codeInGroup code group = (fmap defGroup $ M.lookup (decimate code) codesToDefs) == (Just group)++explain code@Code{} = case M.lookup (decimate code) codesToDefs of+ Nothing -> ""+ Just def -> defHelp def+explain _ = ""++-- only to be used by TH+codeFromName :: RS274Name -> Code+codeFromName n = fromJust $ M.lookup n namesToCodes++-- unused+eqClassNumSub :: Code -> Code -> Bool+eqClassNumSub a b = (decimate a) == (decimate b)++-- strip this code of its axes/parameters/comments+-- copy just class, code number and subcode+decimate :: Code -> Code+decimate x@Code{} | codeCls x `elem` (map Just [T, FStandalone, PStandalone, SStandalone]) = copyClass x emptyCode+decimate x@Code{} = copyClassNumSub x emptyCode+decimate x = x+++copyClassNumSub from to = to { codeCls = codeCls from+ , codeNum = codeNum from+ , codeSub = codeSub from }++copyClass from to = to { codeCls = codeCls from }
+ src/Data/GCode/RS274/Types.hs view
@@ -0,0 +1,477 @@+module Data.GCode.RS274.Types where++import Data.GCode.Types++ -- G-code command definition+data GCodeDef = GCodeDef+ { defCls :: Maybe Class+ , defNum :: Maybe Int+ , defSub :: Maybe Int+ , defGroup :: RS274Group+ , defName :: RS274Name+ , defHelp :: String+ } deriving (Show, Eq, Ord)++defGCD :: GCodeDef+defGCD = GCodeDef {+ defCls = Nothing+ , defNum = Nothing+ , defSub = Nothing+ , defGroup = Unknown+ , defName = Unnamed+ , defHelp = ""+ }++-- utils for creating GCodeDefs+defG :: GCodeDef+defG = defGCD { defCls = Just G }++defM :: GCodeDef+defM = defGCD { defCls = Just M }++g :: Int -> RS274Name -> GCodeDef+g x n = defG { defNum = Just x , defName = n }++m :: Int -> RS274Name -> GCodeDef+m x n = defM { defNum = Just x , defName = n }++gsub :: Int -> Int -> RS274Name -> GCodeDef+gsub x s n = (g x n) { defSub = Just s }++msub :: Int -> Int -> RS274Name -> GCodeDef+msub x s n = (m x n) { defSub = Just s }++-- | Add help text to `GCodeDef`+help :: String -> GCodeDef -> GCodeDef+help txt x = x {defHelp = txt }++-- | Turn `GCodeDef` into `Code`+toCode :: GCodeDef -> Code+toCode x = emptyCode { codeCls = defCls x+ , codeNum = defNum x+ , codeSub = defSub x+ }++-- set defGroup for each list member+makeGroup :: RS274Group -> [GCodeDef] -> [GCodeDef]+makeGroup group defs = map (\x -> x { defGroup = group }) defs++data RS274Name =+ Unnamed+ | Rapid+ | Move+ | ArcCW+ | ArcCCW+ | Dwell+ | CubicSpline+ | QuadSpline+ | NURBS+ | XYPlane+ | ZXPlane+ | YZPlane+ | UVPlane+ | WUPlane+ | VWPlane+ | Inches+ | Millimeters+ | SpindleSync+ | RigidTap+ | Probe+ | DrillingCycleCB+ | ThreadingCycle+ | DrillingCycleCancel+ | DrillingCycle+ | DrillingCycleDwell+ | DrillingCyclePeck+ | BoringCycle+ | BoringCycleDwell+ | Absolute+ | Relative+ | ArcAbsolute+ | ArcRelative+ | LatheDiameter+ | LatheRadius+ | InverseTime+ | UnitsPerMinute+ | UnitsPerRevolution+ | SpindleOrient+ | SpindleStop+ | SpindleCW+ | SpindleCCW+ | SpindleModeConstantSurfaceSpeed+ | SpindleModeRPM+ | CoolantMist+ | CoolantFlood+ | CoolantStop+ | ToolLength+ | ToolLengthDynamic+ | ToolLengthAdd+ | ToolLengthCancel+ | Pause+ | OptionalPause+ | ProgramEnd+ | PalletChange+ | PalletChangePause+ | CutterCompensationOff+ | CutterCompensationLeft+ | CutterCompensationDynamicLeft+ | CutterCompensationRight+ | CutterCompensationDynamicRight+ | ToolChange+ | SetCurrentTool+ | SetToolTable -- XXX this is composed from like five different commands with L parameter+ | StoredPositionMove+ | StoredPositionSet+ | ToolChangePositionMove+ | ToolChangePositionSet+ | MoveInMachineCoordinates+ | CoordinateSystemOffset+ | ResetOffsetsParams+ | ResetOffsets+ | RestoreOffsets+ | OverridesEnable+ | OverridesDisable+ | FeedRateOverride+ | SpindleSpeedOverride+ | AdaptiveFeedControl+ | FeedStopControl+ -- 3D printer specific+ | ExtruderAbsolute+ | ExtruderRelative+ | SetExtruderTemperature+ | GetExtruderTemperature+ | SetExtruderTemperatureAndWait+ | SetBedTemperature+ | SetBedTemperatureAndWait+ | SetChamberTemperature+ | SetChamberTemperatureAndWait+ | CancelWaitTemperature+ | FanOn+ | FanOff+ | GetCurrentPosition+ | DisplayMessage+ | DisableActuators+ | AutoBedLevel+ deriving (Eq, Ord, Show)++data RS274Group =+ Motion+ | Cycles+ | Distance+ | ArcDistance+ | FeedRateMode+ | SpindleControl+ | CoolantControl+ | Stopping+ | Units+ | Plane+ | ToolLengthOffset+ | CutterRadius+ | LatheDiameterMode+ | OtherModal+ | NonModal+ | Unknown+ -- 3D printer specific+ | Extruder+ | Heating+ | Cooling+ | PrinterMisc+ deriving (Eq, Ord, Show)+++-- G-Codes++groupMotion :: [GCodeDef]+groupMotion = makeGroup Motion [+ g 0 Rapid+ & help "Rapid move"+ , g 1 Move+ & help "Linear move"+ , g 2 ArcCW+ & help "Clock-wise arc"+ , g 3 ArcCCW+ & help "Counter clock-wise arc"+ , g 4 Dwell+ & help "Do nothing for specified time"+ , g 5 CubicSpline+ & help "Cubic B-spline move"+ , gsub 5 1 QuadSpline+ & help "Quadratic B-spline move"+ , gsub 5 2 NURBS+ & help "NURBS curve move"+ , g 33 SpindleSync+ & help "Perform spindle synchronized motion"+ , gsub 33 1 RigidTap+ & help "Rigid Tapping"+ , g 38 Probe+ & help "Straight probe"+ ]++groupPlane :: [GCodeDef]+groupPlane = makeGroup Plane [+ g 17 XYPlane+ & help "Select XY plane (default)"+ , g 18 ZXPlane+ & help "Select ZX plane"+ , g 19 YZPlane+ & help "Select YZ plane"+ , gsub 17 1 UVPlane+ & help "Select UV plane"+ , gsub 18 1 WUPlane+ & help "Select WU plane"+ , gsub 19 1 VWPlane+ & help "Select VW plane"+ ]++groupUnits :: [GCodeDef]+groupUnits = makeGroup Units [+ g 20 Inches+ & help "Set units to inches"+ , g 21 Millimeters+ & help "Set units to millimeters"+ ]++groupCutterRadius :: [GCodeDef]+groupCutterRadius = makeGroup CutterRadius [+ g 40 CutterCompensationOff+ , g 41 CutterCompensationLeft+ , gsub 41 1 CutterCompensationDynamicLeft+ , g 42 CutterCompensationRight+ , gsub 42 1 CutterCompensationDynamicRight+ ]++groupToolLengthOffset :: [GCodeDef]+groupToolLengthOffset = makeGroup ToolLengthOffset [+ g 43 ToolLength+ & help "Enables tool length compensation"+ , gsub 43 1 ToolLengthDynamic+ , gsub 43 2 ToolLengthAdd+ & help "Apply additional tool length offset"+ , g 49 ToolLengthCancel+ & help "Cancel tool length compensation"+ ]++groupCycles :: [GCodeDef]+groupCycles = makeGroup Cycles [+ g 73 DrillingCycleCB+ , g 76 ThreadingCycle+ , g 80 DrillingCycleCancel+ , g 81 DrillingCycle+ , g 82 DrillingCycleDwell+ , g 83 DrillingCyclePeck+ , g 85 BoringCycle+ , g 89 BoringCycleDwell+ ]++groupDistance :: [GCodeDef]+groupDistance = makeGroup Distance [+ g 90 Absolute+ & help "Absolute distance mode"+ , g 91 Relative+ & help "Incremental distance mode"+ ]++groupArcDistance :: [GCodeDef]+groupArcDistance = makeGroup ArcDistance [+ gsub 90 1 ArcAbsolute+ & help "Absolute distance mode for I, J & K offsets"+ , gsub 91 1 ArcRelative+ & help "Incremental distance mode for I, J & K offsets"+ ]++groupLatheDiameterMode :: [GCodeDef]+groupLatheDiameterMode = makeGroup LatheDiameterMode [+ g 7 LatheDiameter+ , g 8 LatheRadius+ ]++groupFeedRateMode :: [GCodeDef]+groupFeedRateMode = makeGroup FeedRateMode [+ g 93 InverseTime+ & help "Iverse time feed rate mode, move should be completed in 1/F minutes"+ , g 94 UnitsPerMinute+ & help "Feed rates in units per minute"+ , g 95 UnitsPerRevolution+ & help "Feed rates in units per revolution"+ ]+++-- mixed M/G++groupSpindleControl :: [GCodeDef]+groupSpindleControl = makeGroup SpindleControl [+ m 3 SpindleCW+ & help "Start the spindle clockwise at the S speed"+ , m 4 SpindleCCW+ & help "Start the spindle counterclockwise at the S speed"+ , m 5 SpindleStop+ & help "Stop spindle"+ , m 19 SpindleOrient+ & help "Orient spindle"+ , g 96 SpindleModeConstantSurfaceSpeed+ , g 97 SpindleModeRPM+ ]++-- M-Codes++groupStopping :: [GCodeDef]+groupStopping = makeGroup Stopping [+ m 0 Pause+ & help "Pause a running program temporarily"+ , m 1 OptionalPause+ & help "Pause a running program temporarily if the optional stop switch is on"+ , m 2 ProgramEnd+ & help "End the program"+ , m 30 PalletChange+ & help "Exchange pallet shuttles and end the program"+ , m 60 PalletChangePause+ & help "Exchange pallet shuttles and then pause a running program temporarily"+ ]++groupCoolantControl :: [GCodeDef]+groupCoolantControl = makeGroup CoolantControl [+ m 7 CoolantMist+ & help "Turn mist coolant on"+ , m 8 CoolantFlood+ & help "Turn flood coolant on"+ , m 9 CoolantStop+ & help "Stop both coolants (M7 & M8)"+ ]++-- non-modal codes+groupNonModal :: [GCodeDef]+groupNonModal = makeGroup NonModal [+ m 6 ToolChange+ & help "Stop machine and prompt for tool change"+ , m 61 SetCurrentTool+ & help "Change current tool number without tool-change (in MDI/Manual mode only)"+ , g 10 SetToolTable -- XXX this is composed from like five different commands with L parameter+ , g 28 StoredPositionMove+ & help "Make a rapid move to position stored with G28.1"+ , gsub 28 1 StoredPositionSet+ & help "Store current absolute position"+ , g 30 ToolChangePositionMove+ & help "Make a rapid move to position stored with G30.1"+ , gsub 30 1 ToolChangePositionSet+ & help "Store current absolute position as tool change position"+ , g 53 MoveInMachineCoordinates+ & help "Move in the machine coordinate system"+ , g 92 CoordinateSystemOffset+ & help "Make the current point have the coordinates you want (without motion)"+ , gsub 92 1 ResetOffsetsParams+ & help "Turn off G92 offsets and reset parameters 5211 - 5219 to zero"+ , gsub 92 2 ResetOffsets+ & help "Turn off G92 offsets but keep parameters 5211 - 5219 available"+ , gsub 92 3 RestoreOffsets+ & help "Set the G92 offsets to the values saved in parameters 5211 - 5219"+ ]++groupOtherModal :: [GCodeDef]+groupOtherModal = makeGroup OtherModal [+ defGCD { defCls = Just FStandalone }+ & help "Set feed rate"+ , defGCD { defCls = Just SStandalone }+ & help "Set spindle speed"+ , defGCD { defCls = Just T }+ & help "Select tool"+ , m 48 OverridesEnable+ & help "Enable the spindle speed and feed rate override controls"+ , m 49 OverridesDisable+ & help "Disable the spindle speed and feed rate override controls"+ , m 50 FeedRateOverride+ & help "Feed rate override control"+ , m 51 SpindleSpeedOverride+ & help "Spindle speed override control"+ , m 52 AdaptiveFeedControl+ & help "Adaptive feed control"+ , m 53 FeedStopControl+ & help "Feed stop control"+ ]++-- 3D printer specific++groupExtruder :: [GCodeDef]+groupExtruder = makeGroup Extruder [+ m 82 ExtruderAbsolute+ & help "Interpret extrusion parameters as absolution positions"+ , m 83 ExtruderRelative+ & help "Interpret extrusion parameters as relative positions"+ ]++groupHeating :: [GCodeDef]+groupHeating = makeGroup Heating [+ m 104 SetExtruderTemperature+ & help "Set extruder temperature"+ , m 105 GetExtruderTemperature+ & help "Get current temperature of the selected extruder"+ , m 109 SetExtruderTemperatureAndWait+ & help "Set extruder temperature and wait for it to be reached"+ , m 140 SetBedTemperature+ & help "Set temperature of the heated bed"+ , m 190 SetBedTemperatureAndWait+ & help "Set heated bed temperature and wait for it to be reached"+ , m 141 SetChamberTemperature+ & help "Set temperature of the heated chamber"+ , m 191 SetChamberTemperatureAndWait+ & help "Set heated chamber and wait for it to be reached"+ , m 108 CancelWaitTemperature+ & help ("Stops waiting for temperature to be reached issued by M109, M190 or M191."+ ++ " This won't disable heaters and will continue the print job.")+ ]++groupCooling :: [GCodeDef]+groupCooling = makeGroup Cooling [+ m 106 FanOn+ & help "Enable fan"+ , m 107 FanOff+ & help "Disable fan"+ ]++groupPrinterMisc :: [GCodeDef]+groupPrinterMisc = makeGroup PrinterMisc [+ g 29 AutoBedLevel+ & help "Run automatic heated bed leveling"+ , m 84 DisableActuators+ & help "Disable actuators, e.g. cut power to steppers"+ , m 114 GetCurrentPosition+ & help "Report current position of all axes and extruders"+ , m 117 DisplayMessage+ & help "Display a text message on LCD display"+ ]++cncGroups :: [(RS274Group, [GCodeDef])]+cncGroups = [+ (Motion , groupMotion)+ , (Plane , groupPlane)+ , (Units , groupUnits)+ , (ToolLengthOffset , groupToolLengthOffset)+ , (Cycles , groupCycles)+ , (Distance , groupDistance)+ , (ArcDistance , groupArcDistance)+ , (FeedRateMode , groupFeedRateMode)+ , (SpindleControl , groupSpindleControl)+ , (Stopping , groupStopping)+ , (CoolantControl , groupCoolantControl)+ , (CutterRadius , groupCutterRadius)+ , (LatheDiameterMode, groupLatheDiameterMode)+ , (OtherModal , groupOtherModal)+ , (NonModal , groupNonModal)+ ]++printerGroups :: [(RS274Group, [GCodeDef])]+printerGroups = [+ (Extruder , groupExtruder)+ , (Heating , groupHeating)+ , (Cooling , groupCooling)+ , (PrinterMisc , groupPrinterMisc)+ ]++allGroups :: [(RS274Group, [GCodeDef])]+allGroups = cncGroups ++ printerGroups++groupNames :: [RS274Group]+groupNames = map fst allGroups++-- | All `GCodeDef`s known to us+allCodes :: [GCodeDef]+allCodes = concatMap snd allGroups
+ src/Data/GCode/TH.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE TemplateHaskell #-}+module Data.GCode.TH where++import Language.Haskell.TH++import qualified Data.Char++-- this walks constructors of a datatype+-- and creates isXYZ checks and CodeMod constructors+-- for example for constructor `Rapid` these two are generated+-- isRapid :: Code -> Bool+-- isRapid x = x `codeIsRS274` Rapid+--+-- rapid :: Code+-- rapid = codeFromName Rapid+genShortcuts :: Name -> Q [Dec]+genShortcuts names = do+ info <- reify names+ case info of+ TyConI (DataD _cxt _name _tyvarbndr _kind constructors _deriv)+ -> do+ a <- mapM genTests constructors+ b <- mapM genConstructors constructors+ return $ a ++ b+ _ -> error "Unexpected reify input for genShortcuts"++ where+ genTests (NormalC name _bangs) = do+ varName <- newName "x"+ let+ funName = mkName $ "is" ++ (nameBase name)++ return $ FunD funName+ [ Clause+ [VarP varName]+ (NormalB (InfixE (Just (VarE varName)) (VarE (mkName "codeIsRS274")) (Just (ConE name))))+ []+ ]+ genTests _ = error "Unexpteced input for genTests"++ genConstructors (NormalC name _bangs) = do+ let+ funName = mkName $ (\(x:rest) -> (Data.Char.toLower x : rest)) (nameBase name)+ return $ FunD funName+ [ Clause+ []+ (NormalB ( (VarE (mkName "codeFromName")) `AppE` (ConE name)) )+ []+ ]+ genConstructors _ = error "Unexpteced input for genConstructors"++-- this walks constructors of a datatype+-- and creates constructors to be used in writer monad+--+-- for example for constructor `Move` these two are generated+-- move' :: Control.Monad.Trans.Writer.Lazy.Writer (Endo Program) ()+-- move' = generateName Move+--+-- and a wariant accepting Code endofunctor so we can do move' and also move (xy 2 3)+-- move :: (Code -> Code) -> Control.Monad.Trans.Writer.Lazy.Writer (Endo Program) ()+-- move fn = generateNameArgs Move fn+--+-- We prefer variant with args as it seems to be more common+-- to have GCodes with arguments than just standalone ones.+genWriterEndos :: Name -> Q [Dec]+genWriterEndos names = do+ info <- reify names+ case info of+ TyConI (DataD _cxt _name _tyvarbndr _kind constructors _deriv)+ -> do+ a <- mapM genConstructors constructors+ b <- mapM genConstructorsArgs constructors+ return $ a ++ b+ _ -> error "Unexpected reify input for genWriterEndos"++ where+ genConstructors (NormalC name _bangs) = do+ let+ funName = mkName $ (\(x:rest) -> (Data.Char.toLower x : rest ++ "'")) (nameBase name)+ return $ FunD funName+ [ Clause+ []+ (NormalB ( (VarE (mkName "generateName")) `AppE` (ConE name)) )+ []+ ]+ genConstructors _ = error "Unexpteced input for genConstructors"++ genConstructorsArgs (NormalC name _bangs) = do+ endoName <- newName "x"+ let+ funName = mkName $ (\(x:rest) -> (Data.Char.toLower x : rest)) (nameBase name)+ return $ FunD funName+ [ Clause+ [VarP endoName]+ (NormalB (((VarE (mkName "generateNameArgs")) `AppE` (ConE name)) `AppE` (VarE endoName)) )+ []+ ]+ genConstructorsArgs _ = error "Unexpteced input for genConstructorArgs"
src/Data/GCode/Types.hs view
@@ -6,59 +6,60 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Data.GCode.Types ( Class(..) , AxisDesignator(..) , ParamDesignator(..)+ , allClasses+ , allAxisDesignators+ , zeroAxes+ , allParamDesignators+ , asChars , Axes , Params , Limits , ParamLimits , Code(..) , GCode- , codecls+ , toCodeClass+ , toAxis+ , toParam+ , (&)+ , cls , axis- , axis' , param- , param'- , CodeMod- , cls , num , sub , axes , params , comment- , appmod- , eval , emptyCode , defaultPrec , Style(..) , defaultStyle ) where -import qualified Data.ByteString as B-import qualified Data.Text as T-import qualified Data.Text.Encoding as TE ---import qualified Foldable as F-import Data.Semigroup hiding (option)-import Control.Monad.State.Strict-import Control.Applicative--import qualified Data.Map.Strict as M-+import Data.ByteString (ByteString)+import Data.Map (Map) +import qualified Data.Char+import qualified Data.Map -- | Code class data Class =- G -- ^ G-code- | M -- ^ M-code- | T -- ^ T-code (temperature)- | StP -- ^ Stand-alone P-code- | StF -- ^ Stand-alone F-code- | StS -- ^ Stand-alone S-code+ G -- ^ G-code+ | M -- ^ M-code+ | T -- ^ T-code (select tool)+ | PStandalone -- ^ Stand-alone P-code+ | FStandalone -- ^ Stand-alone F-code+ | SStandalone -- ^ Stand-alone S-code deriving (Show, Enum, Eq, Ord) +allClasses :: [Class]+allClasses = [G, M, T, PStandalone, FStandalone, SStandalone]+ -- | Axis letter data AxisDesignator = X -- ^ X-axis@@ -67,118 +68,122 @@ | A -- ^ A-axis | B -- ^ B-axis | C -- ^ C-axis+ | U -- ^ U-axis+ | V -- ^ V-axis+ | W -- ^ W-axis | E -- ^ Extruder axis | L deriving (Show, Enum, Eq, Ord) +allAxisDesignators :: [AxisDesignator]+allAxisDesignators = [X, Y, Z, A, B, C, U, V, W, E, L]++-- | Return `Axes` with each known at zero position+zeroAxes :: Axes+zeroAxes = Data.Map.fromList $ map (\a -> (a, 0)) allAxisDesignators+ -- | Param letter data ParamDesignator = S -- ^ S parameter - usually spindle RPM | P -- ^ P parameter | F -- ^ F parameter - usually feedrate+ | H -- ^ H paramater - used by tool length offset | R -- ^ R parameter+ | I -- ^ X offset for arcs+ | J -- ^ Y offset for arcs+ | K -- ^ Z offset for arcs deriving (Show, Enum, Eq, Ord) +allParamDesignators :: [ParamDesignator]+allParamDesignators = [S, P, F, R, I, J, K]++asChars :: Show a => [a] -> [Char]+asChars types = map ((!! 0) . show) types++fromChar :: Show a => Char -> [a] -> Maybe a+fromChar c types = Data.Map.lookup (Data.Char.toUpper c)+ $ Data.Map.fromList (zip (asChars types) types)+ -- |Convert 'Char' representation of a code to its 'Class'-codecls :: Char -> Class-codecls 'G' = G-codecls 'M' = M-codecls 'T' = T-codecls 'P' = StP-codecls 'F' = StF-codecls 'S' = StS+toCodeClass :: Char -> Maybe Class+toCodeClass c = fromChar c allClasses -- |Convert 'Char' representation of an axis to its 'AxisDesignator'-axis :: Char -> AxisDesignator-axis 'X' = X-axis 'Y' = Y-axis 'Z' = Z-axis 'A' = A-axis 'B' = B-axis 'C' = C-axis 'E' = E-axis 'L' = L+toAxis :: Char -> Maybe AxisDesignator+toAxis c = fromChar c allAxisDesignators -- |Convert 'Char' representation of a param to its 'ParamDesignator'-param :: Char -> ParamDesignator-param 'S' = S-param 'P' = P-param 'F' = F-param 'R' = R+toParam :: Char -> Maybe ParamDesignator+toParam c = fromChar c allParamDesignators -- | Map of 'AxisDesignator' to 'Double'-type Axes = M.Map AxisDesignator Double+type Axes = Map AxisDesignator Double -type Limits = M.Map AxisDesignator (Double, Double)+-- | Map of 'AxisDesignator' to pair of 'Double's indicating lower and upper limits of travel+type Limits = Map AxisDesignator (Double, Double) -- | Map of 'ParamDesignator' to 'Double'-type Params = M.Map ParamDesignator Double+type Params = Map ParamDesignator Double -type ParamLimits = M.Map ParamDesignator (Double, Double)+-- | Map of 'ParamDesignator' to pair of 'Double's indicating lower and upper limits of this parameter+type ParamLimits = Map ParamDesignator (Double, Double) -- | List of 'Code's type GCode = [Code] data Code = Code {- codeCls :: Maybe Class -- ^ Code 'Class' (M in M5)- , codeNum :: Maybe Int -- ^ Code value (81 in G81)- , codeSub :: Maybe Int -- ^ Code subcode (1 in G92.1)+ codeCls :: Maybe Class -- ^ Code 'Class' (M in M5)+ , codeNum :: Maybe Int -- ^ Code value (81 in G81)+ , codeSub :: Maybe Int -- ^ Code subcode (1 in G92.1) , codeAxes :: Axes -- ^ Code 'Axes' , codeParams :: Params -- ^ Code 'Params'- , codeComment :: B.ByteString -- ^ Comment following this Code+ , codeComment :: ByteString -- ^ Comment following this Code }- | Comment B.ByteString -- ^ Standalone comment- | Empty -- ^ Empty lines- | Other B.ByteString -- ^ Parser unhandled lines+ | Comment ByteString -- ^ Standalone comment+ | Empty -- ^ Empty lines+ | Other ByteString -- ^ Parser unhandled lines deriving (Show, Eq, Ord) -newtype CodeMod = CodeMod- { applyCodeMod :: Code -> Code } -instance Monoid CodeMod where- mempty = CodeMod id- mappend = (<>)--instance Semigroup CodeMod where- m1 <> m2 = CodeMod $ applyCodeMod m1 . applyCodeMod m2--cls :: Class -> CodeMod-cls x = CodeMod $ \c -> c { codeCls = Just x}--num :: Int -> CodeMod-num x = CodeMod $ \c -> c { codeNum = Just x}--sub :: Int -> CodeMod-sub x = CodeMod $ \c -> c { codeSub = Just x}--axes :: Axes -> CodeMod-axes x = CodeMod $ \c -> c { codeAxes = x}+-- endofunctors for manipulating `Code`+cls :: Class -> Code -> Code+cls x c = c { codeCls = Just x} -axis' :: AxisDesignator -> Double -> CodeMod-axis' des val = CodeMod $ \c -> c { codeAxes = M.insert des val $ codeAxes c }+num :: Int -> Code -> Code+num x c = c { codeNum = Just x} -params :: Params -> CodeMod-params x = CodeMod $ \c -> c { codeParams = x}+sub :: Int -> Code -> Code+sub x c = c { codeSub = Just x} -param' :: ParamDesignator -> Double -> CodeMod-param' des val = CodeMod $ \c -> c { codeParams = M.insert des val $ codeParams c }+axes :: Axes -> Code -> Code+axes x c = c { codeAxes = x} -comment :: B.ByteString -> CodeMod-comment x = CodeMod $ \c -> c { codeComment = x}+axis :: AxisDesignator -> Double -> Code -> Code+axis des val c = c { codeAxes = Data.Map.insert des val $ codeAxes c } -appmod :: CodeMod -> Code -> Code-appmod m c = applyCodeMod m c+params :: Params -> Code -> Code+params x c = c { codeParams = x} ---data Sim = Empty--- | Line Axes Axes--- deriving (Show, Eq)+param :: ParamDesignator -> Double -> Code -> Code+param des val c = c { codeParams = Data.Map.insert des val $ codeParams c } ---eval c1 c2 = Line (codeAxes c1) (codeAxes c2)-eval = undefined+comment :: ByteString -> Code -> Code+comment x c = c { codeComment = x} -emptyCode = Code Nothing Nothing Nothing M.empty M.empty ""+-- code & num 10 & comment "& example"+(&) :: a -> (a -> c) -> c+(&) = flip ($) +emptyCode :: Code+emptyCode = Code {+ codeCls = Nothing+ , codeNum = Nothing+ , codeSub = Nothing+ , codeAxes = mempty+ , codeParams = mempty+ , codeComment = mempty+ } data Style =@@ -190,4 +195,5 @@ defaultPrec :: Int defaultPrec = 6 +defaultStyle :: Style defaultStyle = Style defaultPrec False
src/Data/GCode/Utils.hs view
@@ -4,324 +4,40 @@ -} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE BangPatterns #-} module Data.GCode.Utils where -import Debug.Trace import Data.Maybe-import Data.Monoid import Data.GCode.Types+import Data.GCode.RS274 (isMove, isRapid) import qualified Data.Map.Strict as M -import Control.Monad.State.Strict-import Control.Applicative---- |True if 'Code' is a G-code+-- | True if 'Code' is a G-code isG :: Code -> Bool-isG Code{codeCls=(Just G), ..} = True+isG Code{codeCls=(Just G)} = True isG _ = False --- |True if 'Code' is a M-code+-- | True if 'Code' is a M-code isM :: Code -> Bool-isM Code{codeCls=(Just M), ..} = True+isM Code{codeCls=(Just M)} = True isM _ = False --- |True if 'Code' is a G{N} code+-- | True if 'Code' is a G{N} code isGN :: Int -> Code -> Bool-isGN n Code{codeCls=(Just G), codeNum=(Just x), ..} = x == n+isGN n Code{codeCls=(Just G), codeNum=(Just x)} = x == n isGN _ _ = False --- |True if 'Code' is a G{N}.{sub} code-isGNs n sub Code{codeCls=(Just G), codeNum=(Just x), codeSub=(Just sx), ..} = x == n && sx == sub-isGNs _ _ _ = False---- |True if 'Code' is a M{N} code-isMN :: Int -> Code -> Bool-isMN n Code{codeCls=(Just M), codeNum=(Just x), ..} = x == n-isMN _ _ = False---- |True if 'Code' is a M{N}.{sub} code-isMNs n sub Code{codeCls=(Just M), codeNum=(Just x), codeSub=(Just sx), ..} = x == n && sx == sub-isMNs _ _ _ = False---- |True if 'Code' is a G0 code-isG0 :: Code -> Bool-isG0 = isGN 0---- |True if 'Code' is a G0 (rapid move) code, alias to 'isG0'-isRapid :: Code -> Bool-isRapid = isG0---- |True if 'Code' is a G1 code-isG1 :: Code -> Bool-isG1 = isGN 1---- |True if 'Code' is a G1 (move) code, alias to 'isG1'-isMove :: Code -> Bool-isMove = isG1---- |True if 'Code' is a G2 code-isG2 :: Code -> Bool-isG2 = isGN 2---- |True if 'Code' is a G2 (clockwise circular move) code, alias to 'isG2'-isArcCW :: Code -> Bool-isArcCW = isG2-- -- |True if 'Code' is a G3 code-isG3 :: Code -> Bool-isG3 = isGN 3---- |True if 'Code' is a G3 (counter-clockwise circular move) code, alias to 'isG3'-isArcCCW :: Code -> Bool-isArcCCW = isG3---- |True if 'Code' is a G4 code-isG4 :: Code -> Bool-isG4 = isGN 4---- |True if 'Code' is a G4 (dwell) code, alias to 'isG4'-isDwell :: Code -> Bool-isDwell = isG4---- |True if 'Code' is a G5 code-isG5 :: Code -> Bool-isG5 = isGN 5---- |True if 'Code' is a G5 (cubic spline) code, alias to 'isG5'-isCubicSpline :: Code -> Bool-isCubicSpline = isG5-- -- |True if 'Code' is a G5.1 code-isG5s1 :: Code -> Bool-isG5s1 = isGNs 5 1---- |True if 'Code' is a G5.1 (quadratic spline) code, alias to 'isG5s1'-isQuadSpline :: Code -> Bool-isQuadSpline = isG5s1---- |True if 'Code' is a G5.2 code-isG5s2 :: Code -> Bool-isG5s2 = isGNs 5 2---- |True if 'Code' is a G5.2 (NURBS) code, alias to 'isG5s2'-isNURBS :: Code -> Bool-isNURBS = isG5s2---- |True if 'Code' is a G17 (select XYZ plane) code-isXYZplane :: Code -> Bool-isXYZplane = isGN 17---- |True if 'Code' is a G18 (select XZY plane) code-isXZYplane :: Code -> Bool-isXZYplane = isGN 18---- |True if 'Code' is a G19 (select YZX plane) code-isYZXplane :: Code -> Bool-isYZXplane = isGN 19--groupPlane = [ isXYZplane, isXZYplane, isYZXplane ]---- |True if 'Code' is a G20 (inch mode) code-isInch :: Code -> Bool-isInch = isGN 20---- |True if 'Code' is a G21 (millimeter mode) code-isMM :: Code -> Bool-isMM = isGN 21--groupUnits = [ isInch, isMM ]---- |True if 'Code' is a G33 code-isG33 :: Code -> Bool-isG33 = isGN 33---- |True if 'Code' is a G33 (spindle synchronized motion) code, alias to 'isG33'-isSpindleSync :: Code -> Bool-isSpindleSync = isG33---- |True if 'Code' is a G33.1 code-isG33s1 :: Code -> Bool-isG33s1 = isGNs 33 1---- |True if 'Code' is a G33.1 (rigit tapping) code, alias to 'isG33s1'-isRigidTap :: Code -> Bool-isRigidTap = isG33s1---- |True if 'Code' is a G38 code-isG38 :: Code -> Bool-isG38 = isGN 38---- |True if 'Code' is a G38 (probe) code, alias to 'isG38'-isProbe :: Code -> Bool-isProbe = isG38--groupMotion = [isMove, isRapid, isArcCW, isArcCCW,- isCubicSpline, isQuadSpline, isNURBS, isProbe, isSpindleSync, isRigidTap]---- |True if 'Code' is a G73 (drilling cycle, chip breaking) code-isDrillingCycleCB :: Code -> Bool-isDrillingCycleCB = isGN 73---- |True if 'Code' is a G76 (threading cycle) code-isThreadingCycle :: Code -> Bool-isThreadingCycle = isGN 76---- |True if 'Code' is a G80 (cancel drilling cycle) code-isDrillingCycleCancel :: Code -> Bool-isDrillingCycleCancel = isGN 80---- |True if 'Code' is a G81 (drilling cycle) code-isDrillingCycle :: Code -> Bool-isDrillingCycle = isGN 81---- |True if 'Code' is a G82 (drilling cycle, dwell) code-isDrillingCycleDwell :: Code -> Bool-isDrillingCycleDwell = isGN 82---- |True if 'Code' is a G83 (drilling cycle, pecky) code-isDrillingCyclePeck :: Code -> Bool-isDrillingCyclePeck = isGN 83---- |True if 'Code' is a G85 (boring cycle, feed out) code-isBoringCycle :: Code -> Bool-isBoringCycle = isGN 85---- |True if 'Code' is a G89 (boring cycle, dwell, feed out) code-isBoringCycleDwell :: Code -> Bool-isBoringCycleDwell = isGN 89--groupCycles = [isDrillingCycle, isDrillingCycleCB, isDrillingCyclePeck,- isDrillingCycleDwell, isDrillingCycleCancel,- isThreadingCycle,- isBoringCycle, isBoringCycleDwell ]---- |True if 'Code' is a G90 (absolute mode) code-isAbsolute :: Code -> Bool-isAbsolute = isGN 90---- |True if 'Code' is a G91 (relative mode) code-isRelative :: Code -> Bool-isRelative = isGN 91---- |True if 'Code' is a G90.1 (absolute arc mode) code-isArcAbsolute :: Code -> Bool-isArcAbsolute = isGNs 90 1---- |True if 'Code' is a G91.1 (relative arc mode) code-isArcRelative :: Code -> Bool-isArcRelative = isGNs 91 1---- |True if 'Code' is a G7 (lathe diameter mode) code-isLatheDiameter :: Code -> Bool-isLatheDiameter = isGN 7---- |True if 'Code' is a G8 (lathe radius mode) code-isLatheRadius :: Code -> Bool-isLatheRadius = isGN 8--groupDistance = [ isAbsolute, isRelative,- isArcAbsolute, isArcRelative, isLatheDiameter, isLatheRadius ]----isModal = isModalGMotion || isModalPlane || isModalUnits || isModalAbsRel---- |True if 'Code' is a G93 (inverse time mode) code-isInverseTime :: Code -> Bool-isInverseTime = isGN 93---- |True if 'Code' is a G94 (units per minute time mode) code-isUnitsPerMinute :: Code -> Bool-isUnitsPerMinute = isGN 94---- |True if 'Code' is a G95 (units per revolution time mode) code-isUnitsPerRevolution :: Code -> Bool-isUnitsPerRevolution = isGN 95--groupFeedRateMode = [ isInverseTime, isUnitsPerMinute, isUnitsPerRevolution ]---- |True if 'Code' is a M3 (spindle start clockwise) code-isSpindleCW :: Code -> Bool-isSpindleCW = isMN 3---- |True if 'Code' is a M4 (spindle start counter-clockwise) code-isSpindleCCW :: Code -> Bool-isSpindleCCW = isMN 4---- |True if 'Code' is a M5 (spindle stop) code-isSpindleStop :: Code -> Bool-isSpindleStop = isMN 5--groupSpindleControl = [ isSpindleCW, isSpindleCCW, isSpindleStop,- isMN 19, isGN 96, isGN 97]---- |True if 'Code' is a M7 (turn mist coolant on) code-isCoolantMist :: Code -> Bool-isCoolantMist = isMN 7---- |True if 'Code' is a M8 (turn flood coolant on) code-isCoolantFlood :: Code -> Bool-isCoolantFlood = isMN 8---- |True if 'Code' is a M9 (turn all coolant off) code-isCoolantStop :: Code -> Bool-isCoolantStop = isMN 9--groupCoolantControl = [ isCoolantMist, isCoolantFlood, isCoolantStop ]---- |True if 'Code' is a G43 (tool length offset) code-isToolLength :: Code -> Bool-isToolLength = isGN 43---- |True if 'Code' is a G43.1 (dynamic tool length offset) code-isToolLengthDynamic :: Code -> Bool-isToolLengthDynamic = isGNs 43 1---- |True if 'Code' is a G43.2 (apply additional tool length offset) code-isToolLengthAdd :: Code -> Bool-isToolLengthAdd = isGNs 43 2---- |True if 'Code' is a G49 (cancel tool length offset) code-isToolLengthCancel :: Code -> Bool-isToolLengthCancel = isGN 49--groupToolLengthOffset = [ isToolLength, isToolLengthDynamic,- isToolLengthAdd, isToolLengthCancel ]---- |True if 'Code' is a M0 (pause) code-isPause :: Code -> Bool-isPause = isMN 0---- |True if 'Code' is a M1 (optional pause) code-isOptionalPause :: Code -> Bool-isOptionalPause = isMN 1---- |True if 'Code' is a M2 (program end) code-isEnd :: Code -> Bool-isEnd = isMN 2---- |True if 'Code' is a M30 (exchange pallet shuttles) code-isExchange :: Code -> Bool-isExchange = isMN 30--groupStopping = [ isPause, isOptionalPause, isEnd, isExchange, isMN 60 ]--groups = [ groupMotion, groupCycles, groupDistance, groupFeedRateMode,- groupSpindleControl, groupCoolantControl, groupStopping, groupUnits,- groupPlane ]---- |True if 'Code' has a coordinate in axis 'a'+-- | True if 'Code' has a coordinate in axis 'a' hasAxis :: AxisDesignator -> Code -> Bool hasAxis a Code{..} = M.member a codeAxes-hasAxis a _ = False+hasAxis _ _ = False getAxis :: AxisDesignator -> Code -> Maybe Double getAxis a Code{..} = M.lookup a codeAxes getAxis _ _ = Nothing getAxes :: [AxisDesignator] -> Code -> [Maybe Double]-getAxes as c@Code{..} = map (\a-> getAxis a c) as-getAxes _ _ = []+getAxes as c = map (\a-> getAxis a c) as getAxesToList :: Code -> [(AxisDesignator, Double)] getAxesToList Code{..} = M.toList codeAxes@@ -330,241 +46,166 @@ --filterAxes :: [AxisDesignator] -> Code -> [Double] --filterAxes ax Code{..} = map (\a -> M.lookup a codeAxes) ax --- |True if 'Code' contains 'X' axis+-- | True if 'Code' contains 'X' axis hasX :: Code -> Bool hasX = hasAxis X --- |True if 'Code' contains 'Y' axis+-- | True if 'Code' contains 'Y' axis hasY :: Code -> Bool hasY = hasAxis Y --- |True if 'Code' contains 'Z' axis+-- | True if 'Code' contains 'Z' axis hasZ :: Code -> Bool hasZ = hasAxis Z --- |True if 'Code' contains 'E' axis+-- | True if 'Code' contains 'E' axis hasE :: Code -> Bool hasE = hasAxis E --- |True if 'Code' contains parameter with 'ParamDesignator'+-- | True if 'Code' contains parameter with 'ParamDesignator' hasParam :: ParamDesignator -> Code -> Bool hasParam p Code{..} = M.member p codeParams-hasParam a _ = False+hasParam _ _ = False +-- | Get parameter if defined getParam :: ParamDesignator -> Code -> Maybe Double getParam p Code{..} = M.lookup p codeParams+getParam _ _ = Nothing --- |True if 'Code' contains feedrate parameter (e.g. G0 F3000)+-- | True if 'Code' contains feedrate parameter (e.g. G0 F3000) hasFeedrate :: Code -> Bool hasFeedrate = hasParam F --- |Filter G-codes+-- | Filter G-codes gcodes :: [Code] -> [Code] gcodes = filter isG --- |Filter M-codes+-- | Filter M-codes mcodes :: [Code] -> [Code] mcodes = filter isM --- |Filter rapid moves+-- | Filter rapid moves rapids :: [Code] -> [Code] rapids = filter isRapid --- |Filter moves+-- | Filter moves moves :: [Code] -> [Code] moves = filter isMove --- |Replace 'Class' of 'Code' (e.g. for chaning G0 to M0)+-- | Replace 'Class' of 'Code' (e.g. for chaning G0 to M0) replaceClass :: Class -> Code -> Code-replaceClass newclass c = appmod (cls newclass) c+replaceClass newclass c = cls newclass c --- |Replace code value of 'Code' (e.g. for chaning G0 to G1)+-- | Replace code value of 'Code' (e.g. for chaning G0 to G1) replaceCode :: Int -> Code -> Code-replaceCode newcode c = appmod (num newcode) c+replaceCode newcode c = num newcode c --- |Replace axis with 'AxisDesignator' in 'Code' returning new 'Code'+-- | Replace axis with 'AxisDesignator' in 'Code' returning new 'Code' replaceAxis :: AxisDesignator -> Double -> Code -> Code-replaceAxis de val c@Code{..} | hasAxis de c = addReplaceAxis de val c+replaceAxis de val c | hasAxis de c = addReplaceAxis de val c replaceAxis _ _ c = c +-- | Apply function to axis specified by 'AxisDesignator' modifyAxis :: AxisDesignator -> (Double -> Double) -> Code -> Code-modifyAxis de f c@Code{..} | hasAxis de c = addReplaceAxis de (f $ fromJust $ getAxis de c) c+modifyAxis de f c | hasAxis de c = addReplaceAxis de (f $ fromJust $ getAxis de c) c modifyAxis _ _ c = c +-- | Apply function to axes specified by '[AxisDesignator]' modifyAxes :: [AxisDesignator] -> (Double -> Double) -> Code -> Code-modifyAxes axes f c = foldl (\c1 ax -> modifyAxis ax f c1) c axes+modifyAxes axes' f c = foldl (\c1 ax -> modifyAxis ax f c1) c axes' +-- | Test if Code has X and Y axes+hasXY :: Code -> Bool hasXY c = hasAxis X c && hasAxis Y c +-- | Apply function to X and Y axes modifyXY :: (Double -> Double -> (Double, Double)) -> Code -> Code modifyXY f c | hasXY c = let x = fromJust $ getAxis X c y = fromJust $ getAxis Y c (nx, ny) = f x y- in appmod (axis' X nx <> axis' Y ny) c+ in c & axis X nx & axis Y ny modifyXY _ c = c --- |Replace or add axis with 'AxisDesignator' in 'Code' returning new 'Code'+-- | Replace or add axis with 'AxisDesignator' in 'Code' returning new 'Code' addReplaceAxis :: AxisDesignator -> Double -> Code -> Code-addReplaceAxis de val c@Code{..} = appmod (axes $ newaxes $ codeAxes) c+addReplaceAxis de val c@Code{..} = c & (axes $ newaxes $ codeAxes) where newaxes = M.insert de val addReplaceAxis _ _ x = x --- |Replace X axis coordnate+-- | Replace X axis coordnate replaceX :: Double -> Code -> Code replaceX = replaceAxis X --- |Replace Y axis coordinate+-- | Replace Y axis coordinate replaceY :: Double -> Code -> Code replaceY = replaceAxis Y --- |Replace Z axis coordinate+-- | Replace Z axis coordinate replaceZ :: Double -> Code -> Code replaceZ = replaceAxis Z --- |Replace E axis coordinate+-- | Replace E axis coordinate replaceE :: Double -> Code -> Code replaceE = replaceAxis E --- |Replace or add X axis coordinate+-- | Replace or add X axis coordinate addReplaceX :: Double -> Code -> Code addReplaceX = addReplaceAxis X --- |Replace or add Y axis coordinate+-- | Replace or add Y axis coordinate addReplaceY :: Double -> Code -> Code addReplaceY = addReplaceAxis Y --- |Replace or add Z axis coordinate+-- | Replace or add Z axis coordinate addReplaceZ :: Double -> Code -> Code addReplaceZ = addReplaceAxis Z --- |Replace or add E axis coordinate+-- | Replace or add E axis coordinate addReplaceE :: Double -> Code -> Code addReplaceE = addReplaceAxis E ---- |Replace parameter with 'ParamDesignator' in 'Code' returning new 'Code'+-- | Replace parameter with 'ParamDesignator' in 'Code' returning new 'Code' replaceParam :: ParamDesignator -> Double -> Code -> Code-replaceParam de val c@Code{..} | hasParam de c = addReplaceParam de val c+replaceParam de val c | hasParam de c = addReplaceParam de val c replaceParam _ _ c = c +-- | Apply function to parameter with 'ParamDesignator' modifyParam :: ParamDesignator -> (Double -> Double) -> Code -> Code-modifyParam de f c@Code{..} | hasParam de c = addReplaceParam de (f $ fromJust $ getParam de c) c+modifyParam de f c | hasParam de c = addReplaceParam de (f $ fromJust $ getParam de c) c modifyParam _ _ c = c --- |Replace or add parameter with 'ParamDesignator' in 'Code' returning new 'Code'+-- | Apply function to parameters specified by '[ParamDesignator]'+modifyParams :: [ParamDesignator] -> (Double -> Double) -> Code -> Code+modifyParams params' f c = foldl (\c1 ax -> modifyParam ax f c1) c params'++-- | Apply function to parameters specified by '[ParamDesignator]'+--+-- Function gets 'ParameterDesignator' passed as its first argument+modifyParamsWithKey :: [ParamDesignator] -> (ParamDesignator -> Double -> Double) -> Code -> Code+modifyParamsWithKey params' f c = foldl (\c1 ax -> modifyParam ax (f ax) c1) c params'++-- | Replace or add parameter with 'ParamDesignator' in 'Code' returning new 'Code' addReplaceParam :: ParamDesignator -> Double -> Code -> Code-addReplaceParam de val c@Code{..} = appmod (params $ newparams $ codeParams) c+addReplaceParam de val c@Code{..} = c & (params $ newparams $ codeParams) where newparams = M.insert de val addReplaceParam _ _ x = x --- |Replace feedrate (F parameter) in 'Code' returning new 'Code'+-- | Replace feedrate (F parameter) in 'Code' returning new 'Code' replaceFeedrate :: Double -> Code -> Code replaceFeedrate = replaceParam F +-- | Apply function to feedrate modifyFeedrate :: (Double -> Double) -> Code -> Code modifyFeedrate = modifyParam F --- |Sum of all axis distances of this 'Code'-travel :: Code -> Double-travel Code{codeCls=(Just G), ..} = M.foldl (+) 0 codeAxes-travel _ = 0---- |Test if 'Code' belongs to group g-inGroup c g = any (\x -> x c) g---- |Test if 'Code' belongs to any group-known c = any (\x -> inGroup c x) groups----updateModals current c = trace (show $ zipWith (,) current $ map (\x -> inGroup c x) groups) $ zipWith maybeUpdate current $ map (\x -> inGroup c x) groups--- where--- maybeUpdate Nothing True = trace ("new modal" ++ show c) $ Just c--- maybeUpdate (Just old) True = trace ("change modal" ++ show (appendAxes c old)) $ Just (appendAxes c old)--- maybeUpdate old False = trace ("no match" ++ show old) $ old----updateModals current c = zipWith maybeUpdate current $ map (\x -> inGroup c x) groups- where- maybeUpdate Nothing True = Just c- maybeUpdate (Just old) True = Just (appendAxes c old)- maybeUpdate old False = old--appendAxes cto cfrom = appmod (axes $ appendOnlyAxes (codeAxes cto) (codeAxes cfrom)) cto--incomplete Code{codeCls=Nothing, ..} = True-incomplete Code{codeNum=Nothing, ..} = True-incomplete _ = False--totalize :: GCode -> GCode-totalize = totalize' emptyGroups- where- totalize' inEffect [] = []- totalize' inEffect (x:rest) = (updateFromEffect inEffect x):(totalize' (updateModals inEffect x) rest)---type Evaluator a = State [Maybe Code] a--totalizer :: GCode -> Evaluator GCode-totalizer [] = return $ []-totalizer (x:xs) = do- trace ("x " ++ show x) $ return ()- cs <- get- let nx = updateFromEffect cs x-- modify' (flip updateModals $ nx)-- --trace ("cs " ++ show cs) $ return ()- --trace ("nx " ++ show nx) $ return ()- rest <- totalizer xs-- return $ (nx:rest)--totalize' c = runState (totalizer c) emptyGroups----totalizeTrace' c = do--- (a, b) <- runState (totalizer c) emptyGroups--- return $ (a, b)--updateFromEffect inEffect x = do- case (!!) inEffect 0 of -- motion group- Nothing -> x- (Just e) -> appmod (- (cls $ fromJust $ codeCls e)- <> (num $ fromJust $ codeNum e)- <> (axes $ appendOnlyAxes (codeAxes x) (codeAxes e))- ) x--updateFromEffect _ x | otherwise = x--updateIncompleteFromEffect inEffect x | incomplete x = do- case (!!) inEffect 0 of -- motion group- Nothing -> x- (Just e) -> appmod (- (cls $ fromJust $ codeCls e)- <> (num $ fromJust $ codeNum e)- <> (axes $ appendOnlyAxes (codeAxes x) (codeAxes e))- ) x--updateIncompleteFromEffect _ x | otherwise = x--emptyGroups = map (pure Nothing) groups---- update axes that aren't defined in target-appendOnlyAxes target from = M.union target missingOnly- where missingOnly = M.difference from target--rot by x y = (x * (cos by) - y * (sin by), y * (cos by) + x * (sin by))+-- | Sum of all axis distances of this 'Code'+travelDistance :: Code -> Double+travelDistance Code{codeCls=(Just G), ..} = M.foldl (+) 0 codeAxes+travelDistance _ = 0 +-- | Round `x` with specified precision+roundprec :: (Integral a, RealFrac b, Fractional c) => a -> b -> c roundprec n x = (fromInteger $ round $ x * (10^n)) / (10.0^^n)--updateLimitsCode :: Limits -> Code -> Limits-updateLimitsCode s Code{..} = updateLimits s codeAxes-updateLimitsCode s _ = s--updateLimits :: Limits -> Axes -> Limits-updateLimits s = M.foldlWithKey adj s- where- adj limits ax val = M.alter (alterfn val) ax limits- alterfn val (Just (min_c, max_c)) = Just (min min_c val, max max_c val)- alterfn val Nothing = Just (val, val)
+ test/EvalSpec.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE OverloadedStrings #-}++module EvalSpec where++import SpecHelper++import Data.GCode.Generate+import Data.GCode.RS274+import Data.GCode.Eval+++shouldEvalEqually a b = (ipModalGroups . snd . eval $ a) `shouldBe` (ipModalGroups . snd . eval $ b)+shouldTotalizeEqually a b = (totalize a) `shouldBe` b++spec :: Spec+spec = do+ context "eval" $ do+ it "replaces move commands" $ do+ shouldEvalEqually [ move & xy 6 1 , rapid & xy 0 0 ]+ [ rapid & xy 0 0 ]++ it "updates moves correctly" $ do+ shouldEvalEqually [ move & xyz 6 1 2 , rapid & xy 0 0 ]+ [ rapid & xyz 0 0 2]++ it "handles incompletes correctly" $ do+ shouldEvalEqually [ move & xyz 6 1 2 , emptyCode & xy 0 0 ]+ [ move & xyz 0 0 2]++ it "handles inches" $ do+ shouldEvalEqually [ inches, move & xyz 0 0 1, move & xy 1 1 ]+ [ move & xyz 25.4 25.4 25.4, inches ]++ it "handles feedrate in inches" $ do+ shouldEvalEqually [ inches, move & xyz 0 0 1, move & xy 1 1 & feed 10 ]+ [ move & xyz 25.4 25.4 25.4 & feed 254, inches ]++ it "handles relative moves" $ do+ shouldEvalEqually [ relative, move & xyz 1 1 1, move & xy 2 3 ]+ [ move & xyz 3 4 1, relative ]++ it "handles relative arcs" $ do+ shouldEvalEqually [ arcRelative, move & xyz 1 1 1, arc & xy 10 10 & ij 5 5 ]+ [ arc & xyz 10 10 1 & ij 6 6, arcRelative ]++ it "handles combined relative/absolute moves" $ do+ shouldEvalEqually [ relative, move & xyz 10 15 19, absolute, move & z 20 ]+ [ move & xyz 10 15 20 ]++ context "totalize" $ do+ it "totalizes simple moves" $ do+ shouldTotalizeEqually [ move & x 0 , move & y 1, move & z 2 ]+ [ move & x 0, move & xy 0 1, move & xyz 0 1 2 ]++ it "totalizes incomplete moves" $ do+ shouldTotalizeEqually [ move & x 0 , emptyCode & y 1, emptyCode & z 2 ]+ [ move & x 0, move & xy 0 1, move & xyz 0 1 2 ]++ it "totalizes mixed moves/rapids" $ do+ shouldTotalizeEqually [ spindleCW, move & x 0 , rapid & y 1, move & z 2 ]+ [ spindleCW, move & x 0, rapid & xy 0 1, move & xyz 0 1 2 ]++ context "updateAxes" $ do+ it "updates axes correctly" $ do+ let from = codeAxes $ move & y 1 & z 2+ to = codeAxes $ move & x 0+ (updateAxes from to) `shouldBe` (codeAxes $ move & xyz 0 1 2)
+ test/GenSpec.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE OverloadedStrings #-}++module GenSpec where++import SpecHelper++import Data.GCode.Generate+import Data.GCode.RS274++spec :: Spec+spec = do+ it "moves" $ do+ pp [ move & xyz 1 2 3 ] `shouldBe` "G1 X1.00 Y2.00 Z3.00\n"++ it "rapids" $ do+ pp [ rapid & xy 13.37 48 ] `shouldBe` "G0 X13.37 Y48.00\n"++ it "mcodes" $ do+ pp [ m <#> 5, m <#> 9, m <#> 2 ] `shouldBe` "M5\nM9\nM2\n"++ it "params" $ do+ pp [ g <#> 4 & param P 10 ] `shouldBe` "G4 P10.00\n"++ it "subcodes" $ do+ pp [ g <#> 5 & sub 2 ] `shouldBe` "G5.2\n"
+ test/ParseSpec.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE OverloadedStrings #-}++module ParseSpec where++import SpecHelper++import qualified Data.ByteString.Char8 as BSC++spec :: Spec+spec = do+ let roundTrip n = (fmap pp $ parseOnly parseGCode n) `shouldBe` (Right (BSC.unpack n))+ it "roundtrips" $ do+ roundTrip "M3\n"++ roundTrip "M117 L180.00 S8640.00\n"++ roundTrip "G0 X1.00 Y2.00 Z3.33\nM114\n"
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/SpecHelper.hs view
@@ -0,0 +1,16 @@+module SpecHelper+ ( module Test.Hspec+ , module Data.GCode+ , parseOnly+ , fromString+ , pp+ ) where++import Test.Hspec+import Data.Attoparsec.ByteString (parseOnly)+import Data.GCode+import Data.GCode.Parse+import Data.GCode.Pretty+import Data.String (fromString)++pp = ppGCodeStyle $ defaultStyle { stylePrecision = 2 }