From 606a2d80f400c9a72cd59749d310132f31cd9b15 Mon Sep 17 00:00:00 2001 From: Shane O'Brien Date: Thu, 21 Jan 2021 13:52:17 +0000 Subject: [PATCH] Add support for TF command (FileAttribute) from GerberX2 --- gerber/gerber.cabal | 22 +++- gerber/lib/Gerber/Attribute.hs | 40 +++++++ gerber/lib/Gerber/Attribute/Attribute.hs | 17 +++ gerber/lib/Gerber/Attribute/CreationDate.hs | 23 ++++ gerber/lib/Gerber/Attribute/FileFunction.hs | 107 +++++++++++++++++ .../Gerber/Attribute/FileFunction/Copper.hs | 37 ++++++ .../Gerber/Attribute/FileFunction/Drill.hs | 37 ++++++ .../Gerber/Attribute/FileFunction/Types.hs | 108 ++++++++++++++++++ gerber/lib/Gerber/Attribute/FilePolarity.hs | 25 ++++ .../Gerber/Attribute/GenerationSoftware.hs | 25 ++++ gerber/lib/Gerber/Attribute/MD5.hs | 30 +++++ gerber/lib/Gerber/Attribute/Part.hs | 29 +++++ gerber/lib/Gerber/Attribute/ProjectId.hs | 43 +++++++ gerber/lib/Gerber/Command.hs | 2 + gerber/lib/Gerber/Evaluate.hs | 3 + gerber/lib/Gerber/Grammar.hs | 79 ++++++++++--- 16 files changed, 609 insertions(+), 18 deletions(-) create mode 100644 gerber/lib/Gerber/Attribute.hs create mode 100644 gerber/lib/Gerber/Attribute/Attribute.hs create mode 100644 gerber/lib/Gerber/Attribute/CreationDate.hs create mode 100644 gerber/lib/Gerber/Attribute/FileFunction.hs create mode 100644 gerber/lib/Gerber/Attribute/FileFunction/Copper.hs create mode 100644 gerber/lib/Gerber/Attribute/FileFunction/Drill.hs create mode 100644 gerber/lib/Gerber/Attribute/FileFunction/Types.hs create mode 100644 gerber/lib/Gerber/Attribute/FilePolarity.hs create mode 100644 gerber/lib/Gerber/Attribute/GenerationSoftware.hs create mode 100644 gerber/lib/Gerber/Attribute/MD5.hs create mode 100644 gerber/lib/Gerber/Attribute/Part.hs create mode 100644 gerber/lib/Gerber/Attribute/ProjectId.hs diff --git a/gerber/gerber.cabal b/gerber/gerber.cabal index 6e3a2db..3cfa3fa 100644 --- a/gerber/gerber.cabal +++ b/gerber/gerber.cabal @@ -11,6 +11,16 @@ cabal-version: >= 2.0 library exposed-modules: Gerber.ApertureDefinition + Gerber.Attribute + Gerber.Attribute.Attribute + Gerber.Attribute.CreationDate + Gerber.Attribute.FileFunction + Gerber.Attribute.FileFunction.Copper + Gerber.Attribute.FileFunction.Drill + Gerber.Attribute.FileFunction.Types + Gerber.Attribute.FilePolarity + Gerber.Attribute.GenerationSoftware + Gerber.Attribute.Part Gerber.Command Gerber.DCodeNumber Gerber.EncodedDecimal @@ -27,12 +37,16 @@ library Gerber.StepRepeat Gerber.Unit build-depends: base ^>= 4.12 || ^>= 4.13 || ^>= 4.14 - , megaparsec ^>= 7.0 - , text >=1.2 && <1.3 - , generic-deriving + , base16-bytestring < 1 + , bytestring , containers - , monoid-extras , foldl + , generic-deriving + , megaparsec ^>= 7.0 + , monoid-extras + , text >=1.2 && <1.3 + , time + , uuid-types hs-source-dirs: lib default-language: Haskell2010 ghc-options: -Wall diff --git a/gerber/lib/Gerber/Attribute.hs b/gerber/lib/Gerber/Attribute.hs new file mode 100644 index 0000000..695b6b2 --- /dev/null +++ b/gerber/lib/Gerber/Attribute.hs @@ -0,0 +1,40 @@ +{-# language OverloadedStrings #-} + +module Gerber.Attribute + ( FileAttribute(..) + , parseFileAttribute + ) where + +-- gerber +import Gerber.Attribute.Attribute ( Attribute( Attribute ) ) +import Gerber.Attribute.CreationDate ( CreationDate, parseCreationDate ) +import Gerber.Attribute.FileFunction ( FileFunction, parseFileFunction ) +import Gerber.Attribute.FilePolarity ( FilePolarity, parseFilePolarity ) +import Gerber.Attribute.GenerationSoftware ( GenerationSoftware, parseGenerationSoftware ) +import Gerber.Attribute.MD5 ( MD5, parseMD5 ) +import Gerber.Attribute.Part ( Part, parsePart ) +import Gerber.Attribute.ProjectId ( ProjectId, parseProjectId ) + + +data FileAttribute + = Part !Part + | FileFunction !FileFunction + | FilePolarity !FilePolarity + | GenerationSoftware !GenerationSoftware + | CreationDate !CreationDate + | ProjectId !ProjectId + | MD5 !MD5 + | UserAttribute !Attribute + deriving ( Eq, Show ) + + +parseFileAttribute :: MonadFail m => Attribute -> m FileAttribute +parseFileAttribute attribute@(Attribute name fields) = case name of + ".Part" -> Part <$> parsePart fields + ".FileFunction" -> FileFunction <$> parseFileFunction fields + ".FilePolarity" -> FilePolarity <$> parseFilePolarity fields + ".GenerationSoftware" -> GenerationSoftware <$> parseGenerationSoftware fields + ".CreationDate" -> CreationDate <$> parseCreationDate fields + ".ProjectId" -> ProjectId <$> parseProjectId fields + ".MD5" -> MD5 <$> parseMD5 fields + _ -> pure (UserAttribute attribute) diff --git a/gerber/lib/Gerber/Attribute/Attribute.hs b/gerber/lib/Gerber/Attribute/Attribute.hs new file mode 100644 index 0000000..cf5ab77 --- /dev/null +++ b/gerber/lib/Gerber/Attribute/Attribute.hs @@ -0,0 +1,17 @@ +module Gerber.Attribute.Attribute + ( Attribute(..) + , Field + ) where + +-- text +import Data.Text ( Text ) + + +data Attribute = Attribute + { name :: !Text + , value :: ![Field] + } + deriving ( Eq, Show ) + + +type Field = Text diff --git a/gerber/lib/Gerber/Attribute/CreationDate.hs b/gerber/lib/Gerber/Attribute/CreationDate.hs new file mode 100644 index 0000000..26b0600 --- /dev/null +++ b/gerber/lib/Gerber/Attribute/CreationDate.hs @@ -0,0 +1,23 @@ +module Gerber.Attribute.CreationDate + ( CreationDate(..), parseCreationDate + ) where + +-- gerber +import Gerber.Attribute.Attribute ( Field ) + +-- text +import Data.Text ( unpack ) + +-- time +import Data.Time.Clock ( UTCTime ) +import Data.Time.Format.ISO8601 ( formatParseM, iso8601Format ) + + +newtype CreationDate = CreationDate UTCTime + deriving ( Eq, Show ) + + +parseCreationDate :: MonadFail m => [Field] -> m CreationDate +parseCreationDate fields = case fields of + [field] -> CreationDate <$> formatParseM iso8601Format (unpack field) + _ -> fail "Bad .CreationDate: must have exactly 1 field" diff --git a/gerber/lib/Gerber/Attribute/FileFunction.hs b/gerber/lib/Gerber/Attribute/FileFunction.hs new file mode 100644 index 0000000..4574c01 --- /dev/null +++ b/gerber/lib/Gerber/Attribute/FileFunction.hs @@ -0,0 +1,107 @@ +{-# language OverloadedStrings #-} + +module Gerber.Attribute.FileFunction + ( FileFunction(..), parseFileFunction + ) where + +-- gerber +import Gerber.Attribute.Attribute ( Field ) +import Gerber.Attribute.FileFunction.Types + ( Copper, parseCopper + , Drill, parseDrill + , Mask, parseMask + , Profile, parseProfile + , Side, parseSide + ) + +-- text +import Data.Text ( unpack ) + + +data FileFunction + = Copper !Copper + | Soldermask !Mask + | Legend !Mask + | Goldmask !Mask + | Silvermask !Mask + | Tinmask !Mask + | Carbonmask !Mask + | Peelablesoldermask !Mask + | Glue !Mask + | Viatenting !Side + | Viafill + | Heatsink !Side + | Paste !Side + | KeepOut !Side + | Pads !Side + | Scoring !Side + | Plated !Drill + | NonPlated !Drill + | Profile !Profile + | Drillmap + | FabricationDrawing + | ArrayDrawing + | AssemblyDrawing !Side + | Drawing !Field + | Other !Field + deriving ( Eq, Show ) + + +parseFileFunction :: MonadFail m => [Field] -> m FileFunction +parseFileFunction [] = fail "Bad .FileFunction: at least 1 field required" +parseFileFunction (name : values) = case name of + "Copper" -> Copper <$> arity2or3 parseCopper + "Soldermask" -> Soldermask <$> arity1or2 parseMask + "Legend" -> Legend <$> arity1or2 parseMask + "Goldmask" -> Goldmask <$> arity1or2 parseMask + "Silvermask" -> Silvermask <$> arity1or2 parseMask + "Tinmask" -> Tinmask <$> arity1or2 parseMask + "Carbonmask" -> Legend <$> arity1or2 parseMask + "Peelablasoldermask" -> Peelablesoldermask <$> arity1or2 parseMask + "Glue" -> Glue <$> arity1or2 parseMask + "Viatenting" -> Viatenting <$> arity1 parseSide + "Viafill" -> arity0 $ pure Viafill + "Heatsink" -> Heatsink <$> arity1 parseSide + "Paste" -> Paste <$> arity1 parseSide + "Keep-out" -> KeepOut <$> arity1 parseSide + "Scoring" -> Scoring <$> arity1 parseSide + "Plated" -> Plated <$> arity3or4 parseDrill + "NonPlated" -> NonPlated <$> arity3or4 parseDrill + "Profile" -> Profile <$> arity1 parseProfile + "Drillmap" -> arity0 $ pure Drillmap + "FabricationDrawing" -> arity0 $ pure FabricationDrawing + "ArrayDrawing" -> arity0 $ pure ArrayDrawing + "AssemblyDrawing" -> AssemblyDrawing <$> arity1 parseSide + "Drawing" -> Drawing <$> arity1 pure + "Other" -> Other <$> arity1 pure + _ -> fail $ "Bad .FileFunction: unknown value " <> unpack name + where + arity0 f = case values of + [] -> f + _ -> fail $ message "0" + + arity1 f = case values of + [a] -> f a + _ -> fail $ message "1" + + arity1or2 f = case values of + [a, b] -> f a (Just b) + [a] -> f a Nothing + _ -> fail $ message "1 or 2" + + arity2or3 f = case values of + [a, b, c] -> f a b (Just c) + [a, b] -> f a b Nothing + _ -> fail $ message "2 or 3" + + arity3or4 f = case values of + [a, b, c, d] -> f a b c (Just d) + [a, b, c] -> f a b c Nothing + _ -> fail $ message "3 or 4" + + message n = + "Bad .FileFunction: " <> + unpack name <> + " field requires " <> + n <> + " values" diff --git a/gerber/lib/Gerber/Attribute/FileFunction/Copper.hs b/gerber/lib/Gerber/Attribute/FileFunction/Copper.hs new file mode 100644 index 0000000..72c8610 --- /dev/null +++ b/gerber/lib/Gerber/Attribute/FileFunction/Copper.hs @@ -0,0 +1,37 @@ +{-# language OverloadedStrings #-} + +module Gerber.Attribute.FileFunction.Copper + ( Mark(..), parseMark + , Type(..), parseType + ) where + +-- gerber +import Gerber.Attribute.Attribute ( Field ) + +-- text +import Data.Text ( unpack ) + + +data Mark = Top | Inner | Bottom + deriving ( Eq, Show ) + + +parseMark :: MonadFail m => Field -> m Mark +parseMark field = case field of + "Top" -> pure Top + "Inr" -> pure Inner + "Bot" -> pure Bottom + _ -> fail $ "Bad Copper.Mark: " <> unpack field + + +data Type = Plane | Signal | Mixed | Hatched + deriving ( Eq, Show ) + + +parseType :: MonadFail m => Field -> m Type +parseType field = case field of + "Plane" -> pure Plane + "Signal" -> pure Signal + "Mixed" -> pure Mixed + "Hatched" -> pure Hatched + _ -> fail $ "Bad Coppper.Type: " <> unpack field diff --git a/gerber/lib/Gerber/Attribute/FileFunction/Drill.hs b/gerber/lib/Gerber/Attribute/FileFunction/Drill.hs new file mode 100644 index 0000000..f3911e4 --- /dev/null +++ b/gerber/lib/Gerber/Attribute/FileFunction/Drill.hs @@ -0,0 +1,37 @@ +{-# language OverloadedStrings #-} + +module Gerber.Attribute.FileFunction.Drill + ( Type(..), parseType + , Via(..), parseVia + ) where + +-- gerber +import Gerber.Attribute.Attribute ( Field ) + +-- text +import Data.Text ( unpack ) + + +data Type = Drill | Route | Mixed + deriving ( Eq, Show ) + + +parseType :: MonadFail m => Field -> m Type +parseType field = case field of + "Drill" -> pure Drill + "Route" -> pure Route + "Mixed" -> pure Mixed + _ -> fail $ "Bad Drill.Type: " <> unpack field + + +data Via = TH | Blind | Buried + deriving ( Eq, Show ) + + +parseVia :: MonadFail m => Field -> m Via +parseVia field = case field of + "PTH" -> pure TH + "NPTH" -> pure TH + "Blind" -> pure Blind + "Buried" -> pure Buried + _ -> fail $ "Bad Drill.Via: " <> unpack field diff --git a/gerber/lib/Gerber/Attribute/FileFunction/Types.hs b/gerber/lib/Gerber/Attribute/FileFunction/Types.hs new file mode 100644 index 0000000..f6700ec --- /dev/null +++ b/gerber/lib/Gerber/Attribute/FileFunction/Types.hs @@ -0,0 +1,108 @@ +{-# language DuplicateRecordFields #-} +{-# language NamedFieldPuns #-} +{-# language OverloadedStrings #-} + +module Gerber.Attribute.FileFunction.Types + ( Copper(..), parseCopper + , Drill(..), parseDrill + , Index(..), parseIndex + , Mask(..), parseMask + , Profile(..), parseProfile + , Side(..), parseSide + ) where + +-- gerber +import Gerber.Attribute.Attribute ( Field ) +import qualified Gerber.Attribute.FileFunction.Copper as Copper +import qualified Gerber.Attribute.FileFunction.Drill as Drill + +-- text +import Data.Text ( uncons, unpack ) +import Data.Text.Read ( decimal ) + + +data Copper = Copper + { index :: !Index + , mark :: !Copper.Mark + , type_ :: !(Maybe Copper.Type) + } + deriving ( Eq, Show ) + + +parseCopper :: MonadFail m => Field -> Field -> Maybe Field -> m Copper +parseCopper position mark type_ = + Copper + <$> parsePosition position + <*> Copper.parseMark mark + <*> traverse Copper.parseType type_ + where + parsePosition field = case uncons field of + Just ('L', index) -> parseIndex index + _ -> fail "Bad Copper: position must begin with L" + + +data Drill = Drill + { from :: !Index + , to :: !Index + , via :: !Drill.Via + , type_ :: !(Maybe Drill.Type) + } + deriving ( Eq, Show ) + + +parseDrill :: MonadFail m => Field -> Field -> Field -> Maybe Field -> m Drill +parseDrill from to via type_ = + Drill + <$> parseIndex from + <*> parseIndex to + <*> Drill.parseVia via + <*> traverse Drill.parseType type_ + + +newtype Index = Index Word + deriving ( Eq, Show ) + + +parseIndex :: MonadFail m => Field -> m Index +parseIndex field = case decimal field of + Right (n, "") + | n >= 1 -> pure (Index n) + | otherwise -> fail "Bad Index: must be at least 1" + Right (_, rest) -> fail $ "Bad Index: non-numeric suffix " <> unpack rest + Left err -> fail $ "Bad Index: " <> err + + +data Mask = Mask + { side :: !Side + , index :: !(Maybe Index) + } + deriving ( Eq, Show ) + + +parseMask :: MonadFail m => Field -> Maybe Field -> m Mask +parseMask side index = + Mask + <$> parseSide side + <*> traverse parseIndex index + + +data Profile = Plated | NonPlated + deriving ( Eq, Show ) + + +parseProfile :: MonadFail m => Field -> m Profile +parseProfile field = case field of + "P" -> pure Plated + "NP" -> pure NonPlated + _ -> fail $ "Bad Profile: " ++ unpack field + + +data Side = Top | Bottom + deriving ( Eq, Show ) + + +parseSide :: MonadFail m => Field -> m Side +parseSide field = case field of + "Top" -> pure Top + "Bot" -> pure Bottom + _ -> fail $ "Bad Side: " ++ unpack field diff --git a/gerber/lib/Gerber/Attribute/FilePolarity.hs b/gerber/lib/Gerber/Attribute/FilePolarity.hs new file mode 100644 index 0000000..e33c19c --- /dev/null +++ b/gerber/lib/Gerber/Attribute/FilePolarity.hs @@ -0,0 +1,25 @@ +{-# language OverloadedStrings #-} + +module Gerber.Attribute.FilePolarity + ( FilePolarity(..), parseFilePolarity + ) where + +-- gerber +import Gerber.Attribute.Attribute ( Field ) + +-- text +import Data.Text ( unpack ) + + +data FilePolarity + = Positive + | Negative + deriving ( Eq, Show ) + + +parseFilePolarity :: MonadFail m => [Field] -> m FilePolarity +parseFilePolarity [field] = case field of + "Positive" -> pure Positive + "Negative" -> pure Negative + _ -> fail $ "Bad .FilePolarity: unknown value " <> unpack field +parseFilePolarity _ = fail "Bad .FilePolarity: must have exactly 1 field" diff --git a/gerber/lib/Gerber/Attribute/GenerationSoftware.hs b/gerber/lib/Gerber/Attribute/GenerationSoftware.hs new file mode 100644 index 0000000..fd58a79 --- /dev/null +++ b/gerber/lib/Gerber/Attribute/GenerationSoftware.hs @@ -0,0 +1,25 @@ +{-# language NamedFieldPuns #-} + +module Gerber.Attribute.GenerationSoftware + ( GenerationSoftware(..), parseGenerationSoftware + ) where + +-- gerber +import Gerber.Attribute.Attribute ( Field ) + + +data GenerationSoftware = GenerationSoftware + { vendor :: !Field + , application :: !Field + , version :: !(Maybe Field) + } + deriving ( Eq, Show ) + + +parseGenerationSoftware :: MonadFail m => [Field] -> m GenerationSoftware +parseGenerationSoftware fields = case fields of + [vendor, application] -> + pure $ GenerationSoftware vendor application Nothing + [vendor, application, version] -> + pure $ GenerationSoftware vendor application (Just version) + _ -> fail $ "Bad .GenerationSoftware: exactly 2 or 3 fields required" diff --git a/gerber/lib/Gerber/Attribute/MD5.hs b/gerber/lib/Gerber/Attribute/MD5.hs new file mode 100644 index 0000000..bcc79d0 --- /dev/null +++ b/gerber/lib/Gerber/Attribute/MD5.hs @@ -0,0 +1,30 @@ +{-# language OverloadedStrings #-} + +module Gerber.Attribute.MD5 + ( MD5(..), parseMD5 + ) where + +-- base16-bytestring +import Data.ByteString.Base16 ( decode ) + +-- bytestring +import Data.ByteString ( ByteString ) +import qualified Data.ByteString as ByteString + +-- gerber +import Gerber.Attribute.Attribute ( Field ) + +-- text +import Data.Text.Encoding ( encodeUtf8 ) + + +newtype MD5 = MD5 ByteString + deriving ( Eq, Show ) + + +parseMD5 :: MonadFail m => [Field] -> m MD5 +parseMD5 fields = case fields of + [field] -> case decode (encodeUtf8 field) of + (bytes, "") | ByteString.length bytes == 16 -> pure (MD5 bytes) + _ -> fail "Bad .MD5: must consist of exactly 32 hexadecimal digits" + _ -> fail "Bad .MD5: must have exactly 1 field" diff --git a/gerber/lib/Gerber/Attribute/Part.hs b/gerber/lib/Gerber/Attribute/Part.hs new file mode 100644 index 0000000..cd4a4be --- /dev/null +++ b/gerber/lib/Gerber/Attribute/Part.hs @@ -0,0 +1,29 @@ +{-# language OverloadedStrings #-} + +module Gerber.Attribute.Part + ( Part(..) + , parsePart + ) where + +-- gerber +import Gerber.Attribute.Attribute ( Field ) + + +data Part + = Single + | Array + | FabricationPanel + | Coupon + | Other !Field + deriving ( Eq, Show ) + + +parsePart :: MonadFail m => [Field] -> m Part +parsePart fields = case fields of + [field] -> pure $ case field of + "Single" -> Single + "Array" -> Array + "FabricationPanel" -> FabricationPanel + "Coupon" -> Coupon + _ -> Other field + _ -> fail "Bad .Part: must have exactly 1 field" diff --git a/gerber/lib/Gerber/Attribute/ProjectId.hs b/gerber/lib/Gerber/Attribute/ProjectId.hs new file mode 100644 index 0000000..4ce81b6 --- /dev/null +++ b/gerber/lib/Gerber/Attribute/ProjectId.hs @@ -0,0 +1,43 @@ +{-# language NamedFieldPuns #-} +{-# language OverloadedStrings #-} +{-# language ViewPatterns #-} + +module Gerber.Attribute.ProjectId + ( ProjectId(..), parseProjectId + ) where + +-- base16-bytestring +import Data.ByteString.Base16 ( decode ) + +-- bytestring +import Data.ByteString.Lazy ( fromStrict ) + +-- gerber +import Gerber.Attribute.Attribute ( Field ) + +-- text +import Data.Text.Encoding ( encodeUtf8 ) + +-- uuid-types +import Data.UUID.Types ( UUID, fromByteString ) + + +data ProjectId = ProjectId + { name :: !Field + , guid :: !UUID + , revision :: !Field + } + deriving ( Eq, Show ) + + +parseProjectId :: MonadFail m => [Field] -> m ProjectId +parseProjectId fields = case fields of + [name, uuid, revision] -> + ProjectId name <$> parseUUID uuid <*> pure revision + _ -> fail "Bad .ProjectId: must have exactly 3 fields" + + +parseUUID :: MonadFail m => Field -> m UUID +parseUUID hextets = case decode (encodeUtf8 hextets) of + (fromByteString . fromStrict -> Just uuid, "") -> pure uuid + _ -> fail "Bad .ProjectId: could not parse UUID from project guid" diff --git a/gerber/lib/Gerber/Command.hs b/gerber/lib/Gerber/Command.hs index 8a8c4d5..60a7692 100644 --- a/gerber/lib/Gerber/Command.hs +++ b/gerber/lib/Gerber/Command.hs @@ -3,6 +3,7 @@ module Gerber.Command where import qualified Data.Text as StrictText import Gerber.ApertureDefinition ( ApertureDefinition ) +import Gerber.Attribute ( FileAttribute ) import Gerber.DCodeNumber ( DCodeNumber ) import Gerber.Format ( Format ) import Gerber.Movement ( Movement ) @@ -37,4 +38,5 @@ data Command | M02 | SF | MI + | TF !FileAttribute deriving ( Eq, Show ) diff --git a/gerber/lib/Gerber/Evaluate.hs b/gerber/lib/Gerber/Evaluate.hs index d3544ae..6181f38 100644 --- a/gerber/lib/Gerber/Evaluate.hs +++ b/gerber/lib/Gerber/Evaluate.hs @@ -359,6 +359,9 @@ step evaluator state = \case Command.MI -> mempty + Command.TF{} -> + mempty + cmd -> error ( show cmd ) diff --git a/gerber/lib/Gerber/Grammar.hs b/gerber/lib/Gerber/Grammar.hs index 2ede6ae..118ec18 100644 --- a/gerber/lib/Gerber/Grammar.hs +++ b/gerber/lib/Gerber/Grammar.hs @@ -6,17 +6,20 @@ module Gerber.Grammar ( parseGerber ) where import Control.Applicative ( (<|>), empty, many, optional, some ) import Control.Monad ( guard, void ) -import Data.Char ( digitToInt, isDigit ) +import Data.Char ( digitToInt, isAsciiLower, isAsciiUpper, isDigit ) import Data.Foldable ( asum ) import Data.Monoid ( (<>) ) import Data.Void ( Void ) -import Text.Megaparsec ( () ) import Text.Read ( readMaybe ) +import Data.Text ( Text ) import qualified Data.Text as StrictText +import Text.Megaparsec ( MonadParsec, () ) import qualified Text.Megaparsec as Megaparsec import qualified Text.Megaparsec.Char as Megaparsec +import Gerber.Attribute ( parseFileAttribute ) +import Gerber.Attribute.Attribute ( Attribute( Attribute ) ) import qualified Gerber.Padding as Padding import qualified Gerber.ApertureDefinition as Gerber import qualified Gerber.Command as Gerber @@ -66,9 +69,52 @@ int = read . StrictText.unpack <$> Megaparsec.takeWhile1P Nothing isDigit -string :: Megaparsec.MonadParsec e StrictText.Text m => m StrictText.Text -string = - Megaparsec.takeWhileP Nothing isStringChar +-- Name = [a-zA-Z_.$]{[a-zA-Z_.0-9]+} +-- +-- (from §3.6.6 of Gerber File Format Specification) +name :: MonadParsec e Text m => m Text +name = go "name" + where + alpha c = isAsciiUpper c || isAsciiLower c + isNameHeadChar c = alpha c || elem c ['_', '-', '$'] + isNameTailChar c = alpha c || isDigit c || elem c ['_', '-'] + go = StrictText.cons + <$> Megaparsec.satisfy isNameHeadChar + <*> Megaparsec.takeWhileP Nothing isNameTailChar + + +-- String = [a-zA-Z0-9_+-/!?<>”’(){}.\|&@# ,;$:=]+ +-- +-- (from §3.6.6 of Gerber File Format Specification) +string :: MonadParsec e Text m => m Text +string = Megaparsec.takeWhileP Nothing isStringChar "string" + + +isStringChar :: Char -> Bool +isStringChar c = + isAsciiLower c || + isAsciiUpper c || + isDigit c || + elem c + [ '_', '+', '-', '/', '!', '?', '<', '>', '"', '\'', '(', ')', '{', '}' + , '.', '\\', '|', '&', '@', '#', ' ', ',', ';', '$', ':', '=' + ] + + +-- String = [a-zA-Z0-9_+-/!?<>”’(){}.\|&@# ,;$:=]+ +-- +-- (from §3.6.6 of Gerber File Format Specification) +field :: MonadParsec e Text m => m Text +field = Megaparsec.takeWhileP Nothing isFieldChar "field" + + +-- As defined by § 5.1.1 of Gerber File Format Specification +isFieldChar :: Char -> Bool +isFieldChar c = isStringChar c && c /= ',' + + +attribute :: MonadParsec e Text m => m Attribute +attribute = Attribute <$> name <*> many (Megaparsec.char ',' *> field) newlines :: Megaparsec.MonadParsec e StrictText.Text m => m () @@ -173,7 +219,7 @@ ad = do macro = Gerber.Macro - <$> Megaparsec.takeWhile1P Nothing ( /= '*' ) + <$> name Gerber.AD @@ -396,7 +442,16 @@ ip = <* endOfBlock -command :: Megaparsec.MonadParsec e StrictText.Text m => m Gerber.Command +tf :: (MonadFail m, MonadParsec e Text m) => m Gerber.Command +tf = + Gerber.TF + <$ Megaparsec.string "TF" + <*> (attribute >>= parseFileAttribute) + <* endOfBlock + + +command :: (MonadFail m, Megaparsec.MonadParsec e StrictText.Text m) + => m Gerber.Command command = asum ( map Megaparsec.try @@ -422,6 +477,7 @@ command = , sr , sf , mi + , tf ] ) @@ -448,12 +504,12 @@ extended parser = <* newlines -commands :: Megaparsec.MonadParsec e StrictText.Text m => m [ Gerber.Command ] +commands :: (MonadFail m, MonadParsec e Text m) => m [ Gerber.Command ] commands = some command <|> deprecated -gerberFile :: Megaparsec.MonadParsec Void StrictText.Text m => m [ Gerber.Command ] +gerberFile :: (MonadFail m, MonadParsec Void Text m) => m [ Gerber.Command ] gerberFile = snoc <$> ( concat @@ -469,11 +525,6 @@ gerberFile = xs ++ [x] -isStringChar :: Char -> Bool -isStringChar c = - c `notElem` ( "\n\r%*" :: String ) - - parseGerber :: StrictText.Text -> Either (Megaparsec.ParseErrorBundle StrictText.Text Void) [Gerber.Command]