gcodehs (empty) → 0.1.0.0
raw patch · 9 files changed
+696/−0 lines, 9 filesdep +aesondep +ansi-wl-pprintdep +attoparsecsetup-changed
Dependencies added: aeson, ansi-wl-pprint, attoparsec, base, bytestring, containers, formatting, gcodehs, optparse-applicative, pipes, pipes-aeson, pipes-attoparsec, pipes-bytestring, pipes-parse, pipes-safe, text
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- app/Main.hs +104/−0
- gcodehs.cabal +65/−0
- src/Data/GCode.hs +12/−0
- src/Data/GCode/Parse.hs +95/−0
- src/Data/GCode/Pretty.hs +87/−0
- src/Data/GCode/Types.hs +139/−0
- src/Data/GCode/Utils.hs +162/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Richard Marko (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Data.GCode++import Prelude hiding (readFile, putStrLn)++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 Pipes.Aeson.Unchecked (encode)+import qualified System.IO as IO++import Data.Aeson (decode)+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy as BL++import Options.Applicative+import Options.Applicative.Builder++data Flags = Flags {+ input :: FilePath+ , output :: FilePath+ , json :: Bool+ , pretty :: Bool+ , analyze :: Bool+ } 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")++flags :: Parser Flags+flags = Flags+ <$> strOption ( long "input" <> short 'i' <> metavar "INPUT")+ <*> strOption ( long "output" <> short 'o' <> metavar "OUTPUT" <> value "")+ <*> switch ( long "json" <> short 'j' <> help "JSON output")+ <*> switch ( long "pretty" <> short 'p' <> help "Pretty output")+ <*> switch ( long "analyze" <> short 'a' <> help "Analyze GCode")++main =+ execParser opts >>= run+ where+ opts = info (helper <*> flags)+ ( fullDesc+ <> progDesc "Process GCode from INPUT"+ <> 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 json pretty >-> B.stdout+ _ -> IO.withFile output IO.WriteMode $ \outhandle ->+ gcodepipe input $ fmt json 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 + travel a++--analyzefold' = P.fold step 0 id+-- where step x a | isG a = x + 1+-- step x a | otherwise = x++fmt True _ = for Pipes.cat encode+fmt False True = P.map ppGCodeLine >-> P.map (BS.pack . (++"\n"))+fmt False False = P.map ppGCodeLineCompact >-> P.map (BS.pack . (++"\n"))++-- doesn't work, probably due to bad FromJSON for maps+readjsonmain = do+ f <- BL.readFile "a.json"+ print (decode f :: Maybe GCode)++-- 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
+ gcodehs.cabal view
@@ -0,0 +1,65 @@+name: gcodehs+version: 0.1.0.0+synopsis: GCode processor+description: GCode parser, pretty-printer and processing utils+homepage: https://github.com/hackerspace/gcodehs+license: BSD3+license-file: LICENSE+author: Richard Marko+maintainer: rmarko@base48.cz+copyright: 2016 Richard Marko+category: Parsing+build-type: Simple+-- extra-source-files:+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: Data.GCode, Data.GCode.Types, Data.GCode.Parse, Data.GCode.Pretty, Data.GCode.Utils+ build-depends: base >= 4.7 && < 5+ , aeson+ , attoparsec+ , ansi-wl-pprint+ , bytestring+ , containers+ , text+ , formatting+ default-language: Haskell2010++executable gcodehs+ hs-source-dirs: app+ main-is: Main.hs+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends: base+ , aeson+ , attoparsec+ , bytestring+ , gcodehs+ , text+ , pipes+ , pipes-aeson+ , pipes-attoparsec+ , pipes-bytestring+-- , pipes-bytestring-mmap+ , pipes-safe+ , pipes-parse+ , 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++source-repository head+ type: git+ location: https://github.com/hackerspace/gcodehs
+ src/Data/GCode.hs view
@@ -0,0 +1,12 @@+{-| This module is an entry point to @gcodehs@ library++This module re-exports all 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
+ src/Data/GCode/Parse.hs view
@@ -0,0 +1,95 @@+{-| 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 Data.Attoparsec.ByteString.Char8+import qualified Data.Map.Strict as M++import Data.Either (lefts, rights)++-- |Parse single line of G-code into 'Code'+parseGCodeLine :: Parser Code+parseGCodeLine = between lskip lskip parseCodeParts <* endOfLine++-- |Parse lines of G-code into 'GCode'+parseGCode :: Parser GCode+parseGCode = many1 parseGCodeLine++-- |Parse lines of G-code returning either parsing error or 'GCode'+parseOnlyGCode :: B.ByteString -> Either String GCode+parseOnlyGCode = parseOnly parseGCode+++lskip = skipWhile (inClass " \t")+between open close p = do{ open; x <- p; close; return x }++isEndOfLineChr :: Char -> Bool+isEndOfLineChr '\n' = True+isEndOfLineChr '\r' = True+isEndOfLineChr _ = False++parseLead = do+ a <- satisfy $ inClass "GMTPFS"+ return $ codecls a++parseAxisDes = do+ a <- satisfy $ inClass "XYZABCEL"+ return $ axis a++parseParamDes = do+ a <- satisfy $ inClass "SPF"+ return $ param a++parseParamOrAxis = do+ lskip+ ax <- option Nothing (Just <$> parseAxisDes)+ case ax of+ Just val -> do+ lskip+ f <- double+ return $ Left (val, f)+ Nothing -> do+ param <- parseParamDes+ lskip+ f <- double+ return $ Right (param, f)++parseAxesParams :: Parser (Axes, Params)+parseAxesParams = do+ a <- many parseParamOrAxis+ return (M.fromList $ lefts a, M.fromList $ rights a)++parseCode = do+ lead <- parseLead+ gcode <- decimal+ subcode <- option 0 (Just <$> char '.' *> decimal)+ lskip+ (axes, params) <- parseAxesParams+ lskip+ comment <- option "" $ between lskip lskip parseComment'+ return $ Code lead gcode subcode axes params comment++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]++parseComment = Comment <$> parseComment'++parseOther = do+ a <- takeWhile (not . isEndOfLineChr)+ return $ Other a++parseCodeParts =+ parseCode+ <|> parseComment+ <|> parseOther
+ src/Data/GCode/Pretty.hs view
@@ -0,0 +1,87 @@+{-| GCode pretty-printing functions++Please do note that these are extremely slow as they do conversion+from ByteStrings to Text and vice-verse. Float formatting is probably+not the fastest as well. Colorfull versions are especially slow.++-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+module Data.GCode.Pretty(ppGCode, ppGCodeLine, ppGCodeCompact, ppGCodeLineCompact) where++import Data.ByteString.Char8 (pack, unpack)+import qualified Data.Text as T+import qualified Data.Map.Strict as M+import Formatting (sformat)+import Formatting.ShortFormatters++import Text.PrettyPrint.ANSI.Leijen+import Data.GCode.Types++-- |Pretty-print 'GCode' using colors+ppGCode :: GCode -> String+ppGCode res = displayS (renderPretty 0.4 80 (ppGCode' res)) ""++-- |Pretty-print single 'Code' using colors+ppGCodeLine :: Code -> String+ppGCodeLine res = displayS (renderPretty 0.4 80 (ppCode res)) ""++-- |Pretty-print 'GCode' without colors+ppGCodeCompact :: GCode -> String+ppGCodeCompact res = displayS (renderCompact (ppGCode' res)) ""++-- |Pretty-print single 'Code' without colors+ppGCodeLineCompact :: Code -> String+ppGCodeLineCompact res = displayS (renderCompact (ppCode res)) ""++ppList pp x = hsep $ map pp x++ppGCode' = vsep . map ppCode++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"++--codecolor Code{..} = cc cls code+cc G 0 = dullyellow+cc G 1 = yellow+cc _ _ = red++ppAxis (des, val) =+ bold (axisColor des $ text $ show des)+ <> cyan (text $ T.unpack $ sformat sf val)++axisColor X = red+axisColor Y = green+axisColor Z = yellow+axisColor A = red+axisColor B = green+axisColor C = blue+axisColor E = magenta++ppAxes [] = empty+ppAxes x = space <> ppList ppAxis x++ppParam (des, val) =+ bold (blue $ text $ show des)+ <> white (text $ T.unpack $ sformat sf val)++ppParams [] = empty+ppParams x = space <> ppList ppParam x++ppComment "" = empty+ppComment c = space <> ppComment' c+ppComment' "" = empty+ppComment' c = dullwhite $ parens $ text $ unpack c++ppCode Code{..} =+ cc cls code ( bold $ ppClass cls)+ <> cc cls code ( text $ show code)+ <> ppAxes (M.toList axes)+ <> ppParams (M.toList params)+ <> ppComment comment+ppCode (Comment x) = ppComment' x+ppCode (Other x) = dullred $ text $ unpack x
+ src/Data/GCode/Types.hs view
@@ -0,0 +1,139 @@+{-| GCode types++This module exports types for constructing 'Code' values++-}++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveGeneric #-}+module Data.GCode.Types (+ Class(..)+ , AxisDesignator(..)+ , ParamDesignator(..)+ , Axes+ , Params+ , Code(..)+ , GCode+ , codecls+ , axis+ , param+ ) where++import qualified Data.ByteString as B+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE++import Data.Aeson+import GHC.Generics+import qualified Data.Map.Strict as M++-- | 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+ deriving (Generic, Show, Enum, Eq, Ord)++-- | Axis letter+data AxisDesignator =+ X -- ^ X-axis+ | Y -- ^ Y-axis+ | Z -- ^ Z-axis+ | A -- ^ A-axis+ | B -- ^ B-axis+ | C -- ^ C-axis+ | E -- ^ Extruder axis+ | L+ deriving (Generic, Show, Enum, Eq, Ord)++-- | Param letter+data ParamDesignator =+ S -- ^ S parameter - usually spindle RPM+ | P -- ^ P parameter+ | F -- ^ S parameter - usually feedrate+ deriving (Generic, Show, Enum, Eq, Ord)++-- |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++-- |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++-- |Convert 'Char' representation of a param to its 'ParamDesignator'+param :: Char -> ParamDesignator+param 'S' = S+param 'P' = P+param 'F' = F++-- | Map of 'AxisDesignator' to 'Double'+type Axes = M.Map AxisDesignator Double++-- | Map of 'ParamDesignator' to 'Double'+type Params = M.Map ParamDesignator Double++-- | List of 'Code's+type GCode = [Code]++data Code =+ Code {+ cls :: Class -- ^ Code 'Class' (M in M5)+ , code :: Int -- ^ Code value (81 in G81)+ , sub :: Int -- ^ Code subcode (1 in G92.1)+ , axes :: Axes -- ^ Code 'Axes'+ , params :: Params -- ^ Code 'Params'+ , comment :: B.ByteString -- ^ Comment following this Code+ }+ | Comment B.ByteString -- ^ Standalone comment+ | Other B.ByteString -- ^ Parser unhandled lines (should contain blank lines only)+ deriving (Generic, Show, Eq, Ord)++instance ToJSON ParamDesignator+instance FromJSON ParamDesignator+instance ToJSON Class+instance ToJSON AxisDesignator+instance FromJSON AxisDesignator+instance FromJSON Class+instance ToJSON Code+instance FromJSON Code++instance ToJSON v => ToJSON (M.Map ParamDesignator v) where+ toJSON = toJSON . M.mapKeys show++instance FromJSON v => FromJSON (M.Map ParamDesignator v) where+ parseJSON v = convert <$> parseJSON v+ where convert :: M.Map T.Text v -> M.Map ParamDesignator v+ convert = M.fromList . map (\(x,y) -> (param $ T.head x,y)) . M.toList++instance ToJSON v => ToJSON (M.Map AxisDesignator v) where+ toJSON = toJSON . M.mapKeys show++instance FromJSON v => FromJSON (M.Map AxisDesignator v) where+ parseJSON v = convert <$> parseJSON v+ where convert :: M.Map T.Text v -> M.Map AxisDesignator v+ convert = M.fromList . map (\(x,y) -> (axis $ T.head x,y)) . M.toList++instance ToJSON B.ByteString where+ toJSON = String . TE.decodeUtf8+ {-# INLINE toJSON #-}++instance FromJSON B.ByteString where+ parseJSON = withText "ByteString" $ pure . TE.encodeUtf8+ {-# INLINE parseJSON #-}
+ src/Data/GCode/Utils.hs view
@@ -0,0 +1,162 @@+{-| GCode pretty-printing functions++Utilities for manipulating and filtering 'GCode'++-}+{-# LANGUAGE RecordWildCards #-}+module Data.GCode.Utils where++import Data.GCode.Types+import qualified Data.Map.Strict as M++-- |True if 'Code' is a G-code+isG :: Code -> Bool+isG Code{cls=G, ..} = True+isG _ = False++-- |True if 'Code' is a G{N} code+isGN :: Int -> Code -> Bool+isGN n Code{cls=G, code=x, ..} | x == n = True+isGN _ _ = 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 M-code+isM :: Code -> Bool+isM Code{cls=M, ..} = True+isM _ = False++-- |True if 'Code' has a coordinate in axis 'a'+hasAxis :: AxisDesignator -> Code -> Bool+hasAxis a Code{..} = M.member a axes+hasAxis a _ = False++-- |True if 'Code' contains 'X' axis+hasX :: Code -> Bool+hasX = hasAxis X++-- |True if 'Code' contains 'Y' axis+hasY :: Code -> Bool+hasY = hasAxis Y++-- |True if 'Code' contains 'Z' axis+hasZ :: Code -> Bool+hasZ = hasAxis Z++-- |True if 'Code' contains 'E' axis+hasE :: Code -> Bool+hasE = hasAxis E++-- |True if 'Code' contains parameter with 'ParamDesignator'+hasParam :: ParamDesignator -> Code -> Bool+hasParam p Code{..} = M.member p params+hasParam a _ = False++-- |True if 'Code' contains feedrate parameter (e.g. G0 F3000)+hasFeedrate :: Code -> Bool+hasFeedrate = hasParam F++-- |Filter G-codes+gcodes :: [Code] -> [Code]+gcodes = filter isG++-- |Filter M-codes+mcodes :: [Code] -> [Code]+mcodes = filter isM++-- |Filter rapid moves+rapids :: [Code] -> [Code]+rapids = filter isRapid++-- |Filter moves+moves :: [Code] -> [Code]+moves = filter isMove++-- |Replace 'Class' of 'Code' (e.g. for chaning G0 to M0)+replaceClass :: Class -> Code -> Code+replaceClass newclass Code{..} = Code newclass code sub axes params comment+replaceClass _ x = x++-- |Replace code value of 'Code' (e.g. for chaning G0 to G1)+replaceCode :: Int -> Code -> Code+replaceCode newcode Code{..} = Code cls newcode sub axes params comment+replaceCode _ x = x++-- |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 _ _ c@Code{..} = c++-- |Replace or add axis with 'AxisDesignator' in 'Code' returning new 'Code'+addReplaceAxis :: AxisDesignator -> Double -> Code -> Code+addReplaceAxis de val Code{..} = Code cls code sub (newaxes axes) params comment+ where+ newaxes = M.insert de val+addReplaceAxis _ _ x = x++-- |Replace X axis coordinate+replaceX :: Double -> Code -> Code+replaceX = replaceAxis X++-- |Replace Y axis coordinate+replaceY :: Double -> Code -> Code+replaceY = replaceAxis Y++-- |Replace Z axis coordinate+replaceZ :: Double -> Code -> Code+replaceZ = replaceAxis Z++-- |Replace E axis coordinate+replaceE :: Double -> Code -> Code+replaceE = replaceAxis E++-- |Replace or add X axis coordinate+addReplaceX :: Double -> Code -> Code+addReplaceX = addReplaceAxis X++-- |Replace or add Y axis coordinate+addReplaceY :: Double -> Code -> Code+addReplaceY = addReplaceAxis Y++-- |Replace or add Z axis coordinate+addReplaceZ :: Double -> Code -> Code+addReplaceZ = addReplaceAxis Z++-- |Replace or add E axis coordinate+addReplaceE :: Double -> Code -> Code+addReplaceE = addReplaceAxis E++-- |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 _ _ c@Code{..} = c++-- |Replace or add parameter with 'ParamDesignator' in 'Code' returning new 'Code'+addReplaceParam :: ParamDesignator -> Double -> Code -> Code+addReplaceParam de val Code{..} = Code cls code sub axes (newparams params) comment+ where+ newparams = M.insert de val+addReplaceParam _ _ x = x++-- |Replace feedrate (F parameter) in 'Code' returning new 'Code'+replaceFeedrate :: Double -> Code -> Code+replaceFeedrate = replaceParam F++-- |Sum of all axis distances of this 'Code'+travel :: Code -> Double+travel Code{cls=G, ..} = M.foldl (+) 0 axes+travel _ = 0