kicad-data 0.4.0 → 0.5.0

raw patch · 14 files changed

+708/−370 lines, 14 filesdep +HUnitdep +charsetdetectdep +encodingdep −parsec-numbersdep ~basedep ~ieee754dep ~lens-familyPVP ok

version bump matches the API change (PVP)

Dependencies added: HUnit, charsetdetect, encoding, test-framework-hunit

Dependencies removed: parsec-numbers

Dependency ranges changed: base, ieee754, lens-family, parsec, test-framework-quickcheck2

API changes (from Hackage documentation)

Files

• Data/Kicad/PcbnewExpr.hs +1/−0
• Data/Kicad/PcbnewExpr/Parse.hs +172/−125
• Data/Kicad/PcbnewExpr/PcbnewExpr.hs +93/−75
• Data/Kicad/SExpr.hs +2/−2
• Data/Kicad/SExpr/Parse.hs +28/−67
• Data/Kicad/SExpr/SExpr.hs +10/−56
• Data/Kicad/SExpr/Write.hs +7/−31
• Data/Kicad/Util.hs +14/−0
• README.md +32/−0
• changelog.md +9/−0
• kicad-data.cabal +26/−14
• tests/PcbnewExpr.hs +218/−0
• tests/SExpr.hs +70/−0
• tests/Utils.hs +26/−0

@@ -4,6 +4,7 @@   PcbnewExpr(..) -- * Parse , parse+, parseWithFilename , fromSExpr -- * Write , pretty

@@ -1,105 +1,111 @@ module Data.Kicad.PcbnewExpr.Parse ( parse+, parseWithFilename , fromSExpr ) where import Data.Either import Data.Maybe-import Control.Applicative import Lens.Family2 (over) import Data.List (intersperse)+import Text.Read (readMaybe)+import Text.Parsec.Pos (newPos)+import Control.Applicative ((<$>), (<*>)) -import Data.Kicad.SExpr hiding (parse)-import qualified Data.Kicad.SExpr as SExpr (parse)+import Data.Kicad.SExpr hiding (parse, parseWithFilename)+import qualified Data.Kicad.SExpr as SExpr (parseWithFilename) import Data.Kicad.PcbnewExpr.PcbnewExpr import Data.Kicad.Util (headOr) -{-| Parse a 'PcbnewExpr' from a 'String'. Returns an 'String' with an error or-   a 'PcbnewExpr'. -}+{-| Parse a Pcbnew expression from a string. Returns an 'String' with an error+ - or a 'PcbnewExpr'. -} parse :: String -> Either String PcbnewExpr-parse = either Left fromSExpr . SExpr.parse+parse = parseWithFilename "" +{-| Parse a Pcbnew expression from a string giving a filename argument to be used in error strings. -}+parseWithFilename :: String -> String -> Either String PcbnewExpr+parseWithFilename filename =+    either Left fromSExpr . SExpr.parseWithFilename filename+ {-| Interpret a 'SExpr' as a 'PcbnewExpr'. -} fromSExpr :: SExpr -> Either String PcbnewExpr-fromSExpr (List (AtomKey kw:sxs)) =-    case go of-        Left err   -> Left $ "Could not interpret '" ++ writeKeyword kw ++-                        "' because:\n\t" ++ err-        Right expr -> Right expr-    where go = case kw of-            KeyModule    -> PcbnewExprModule    <$> asPcbnewModule           sxs-            KeyPad       -> PcbnewExprItem      <$> asPcbnewPad              sxs-            KeyFpText    -> PcbnewExprItem      <$> asPcbnewFpText           sxs-            KeyFpArc     -> PcbnewExprItem      <$> asPcbnewFpArc            sxs-            KeyFpPoly    -> PcbnewExprItem      <$> asPcbnewFpPoly           sxs-            KeyLayer     -> PcbnewExprAttribute <$> asPcbnewLayer            sxs-            KeyAt        -> PcbnewExprAttribute <$> asPcbnewAt               sxs-            KeyEffects   -> PcbnewExprAttribute <$> asPcbnewEffects          sxs-            KeyFont      -> PcbnewExprAttribute <$> asPcbnewFont             sxs-            KeyLayers    -> PcbnewExprAttribute <$> asPcbnewLayers           sxs-            KeyPts       -> PcbnewExprAttribute <$> asPcbnewPts              sxs-            KeyXyz       -> PcbnewExprAttribute <$> asPcbnewXyz              sxs-            KeyModel     -> PcbnewExprAttribute <$> asPcbnewModel            sxs-            KeyDrill     -> PcbnewExprAttribute <$> asPcbnewDrill            sxs-            KeySize      -> PcbnewExprAttribute <$> asXy PcbnewSize          sxs-            KeyStart     -> PcbnewExprAttribute <$> asXy PcbnewStart         sxs-            KeyEnd       -> PcbnewExprAttribute <$> asXy PcbnewEnd           sxs-            KeyCenter    -> PcbnewExprAttribute <$> asXy PcbnewCenter        sxs-            KeyRectDelta -> PcbnewExprAttribute <$> asXy PcbnewRectDelta     sxs-            KeyXy        -> PcbnewExprAttribute <$> asXy PcbnewXy            sxs-            KeyOffset    -> PcbnewExprAttribute <$> asXy PcbnewOffset        sxs-            KeyScale     -> PcbnewExprAttribute <$> asXyz PcbnewModelScale   sxs-            KeyRotate    -> PcbnewExprAttribute <$> asXyz PcbnewModelRotate  sxs-            KeyDescr     -> PcbnewExprAttribute <$> asString PcbnewDescr     sxs-            KeyTags      -> PcbnewExprAttribute <$> asString PcbnewTags      sxs-            KeyPath      -> PcbnewExprAttribute <$> asString PcbnewPath      sxs-            KeyAttr      -> PcbnewExprAttribute <$> asString PcbnewAttr      sxs-            KeyTedit     -> PcbnewExprAttribute <$> asString PcbnewTedit     sxs-            KeyAngle     -> PcbnewExprAttribute <$> asDouble PcbnewAngle     sxs-            KeyThickness -> PcbnewExprAttribute <$> asDouble PcbnewThickness sxs-            KeyWidth     -> PcbnewExprAttribute <$> asDouble PcbnewWidth     sxs-            KeyJustify   -> PcbnewExprAttribute <$> asPcbnewJustifyT         sxs-            KeyThermalGap-                -> PcbnewExprAttribute <$> asDouble PcbnewThermalGap sxs-            KeyThermalWidth-                -> PcbnewExprAttribute <$> asDouble PcbnewThermalWidth sxs-            KeySolderPasteMarginRatio-                -> PcbnewExprAttribute <$> asDouble PcbnewPasteMarginRatio  sxs-            KeySolderPasteMargin-                -> PcbnewExprAttribute <$> asDouble PcbnewPasteMargin sxs-            KeySolderMaskMargin-                -> PcbnewExprAttribute <$> asDouble PcbnewMaskMargin  sxs-            KeyClearance-                -> PcbnewExprAttribute <$> asDouble PcbnewClearance   sxs-            KeySolderPasteRatio-                -> PcbnewExprAttribute <$> asDouble PcbnewSolderPasteRatio sxs-            KeyFpLine-                -> PcbnewExprItem <$> asFp defaultPcbnewFpLine        sxs-            KeyFpCircle-                -> PcbnewExprItem <$> asFp defaultPcbnewFpCircle      sxs-            KeyAutoplaceCost180-                -> PcbnewExprAttribute <$> asInt PcbnewAutoplaceCost180 sxs-            KeyAutoplaceCost90-                -> PcbnewExprAttribute <$> asInt PcbnewAutoplaceCost90 sxs-            KeyZoneConnect-                -> PcbnewExprAttribute <$> asInt PcbnewZoneConnect sxs-            KeyRoundrectRratio-                -> PcbnewExprAttribute <$> asDouble PcbnewRoundrectRratio sxs-fromSExpr sx@(AtomStr s) = case s of+fromSExpr (List _ (Atom pos kw:sxs)) = case kw of+    "module"     -> PcbnewExprModule    <$> asPcbnewModule           sxs+    "pad"        -> PcbnewExprItem      <$> asPcbnewPad              sxs+    "fp_text"    -> PcbnewExprItem      <$> asPcbnewFpText           sxs+    "fp_arc"     -> PcbnewExprItem      <$> asPcbnewFpArc            sxs+    "fp_poly"    -> PcbnewExprItem      <$> asPcbnewFpPoly           sxs+    "layer"      -> PcbnewExprAttribute <$> asPcbnewLayer            sxs+    "at"         -> PcbnewExprAttribute <$> asPcbnewAt               sxs+    "effects"    -> PcbnewExprAttribute <$> asPcbnewEffects          sxs+    "font"       -> PcbnewExprAttribute <$> asPcbnewFont             sxs+    "layers"     -> PcbnewExprAttribute <$> asPcbnewLayers           sxs+    "pts"        -> PcbnewExprAttribute <$> asPcbnewPts              sxs+    "xyz"        -> PcbnewExprAttribute <$> asPcbnewXyz              sxs+    "model"      -> PcbnewExprAttribute <$> asPcbnewModel            sxs+    "drill"      -> PcbnewExprAttribute <$> asPcbnewDrill            sxs+    "size"       -> PcbnewExprAttribute <$> asXy PcbnewSize          sxs+    "start"      -> PcbnewExprAttribute <$> asXy PcbnewStart         sxs+    "end"        -> PcbnewExprAttribute <$> asXy PcbnewEnd           sxs+    "center"     -> PcbnewExprAttribute <$> asXy PcbnewCenter        sxs+    "rect_delta" -> PcbnewExprAttribute <$> asXy PcbnewRectDelta     sxs+    "xy"         -> PcbnewExprAttribute <$> asXy PcbnewXy            sxs+    "offset"     -> PcbnewExprAttribute <$> asXy PcbnewOffset        sxs+    "scale"      -> PcbnewExprAttribute <$> asXyz PcbnewModelScale   sxs+    "rotate"     -> PcbnewExprAttribute <$> asXyz PcbnewModelRotate  sxs+    "descr"      -> PcbnewExprAttribute <$> asString PcbnewDescr     sxs+    "tags"       -> PcbnewExprAttribute <$> asString PcbnewTags      sxs+    "path"       -> PcbnewExprAttribute <$> asString PcbnewPath      sxs+    "attr"       -> PcbnewExprAttribute <$> asString PcbnewAttr      sxs+    "tedit"      -> PcbnewExprAttribute <$> asString PcbnewTedit     sxs+    "angle"      -> PcbnewExprAttribute <$> asDouble PcbnewAngle     sxs+    "thickness"  -> PcbnewExprAttribute <$> asDouble PcbnewThickness sxs+    "width"      -> PcbnewExprAttribute <$> asDouble PcbnewWidth     sxs+    "justify"    -> PcbnewExprAttribute <$> asPcbnewJustifyT         sxs+    "thermal_gap"+        -> PcbnewExprAttribute <$> asDouble PcbnewThermalGap sxs+    "thermal_width"+        -> PcbnewExprAttribute <$> asDouble PcbnewThermalWidth sxs+    "solder_paste_margin_ratio"+        -> PcbnewExprAttribute <$> asDouble PcbnewPasteMarginRatio sxs+    "solder_paste_margin"+        -> PcbnewExprAttribute <$> asDouble PcbnewPasteMargin sxs+    "solder_mask_margin"+        -> PcbnewExprAttribute <$> asDouble PcbnewMaskMargin sxs+    "clearance"+        -> PcbnewExprAttribute <$> asDouble PcbnewClearance sxs+    "solder_paste_ratio"+        -> PcbnewExprAttribute <$> asDouble PcbnewSolderPasteRatio sxs+    "fp_line"+        -> PcbnewExprItem <$> asFp defaultPcbnewFpLine sxs+    "fp_circle"+        -> PcbnewExprItem <$> asFp defaultPcbnewFpCircle sxs+    "autoplace_cost180"+        -> PcbnewExprAttribute <$> asInt PcbnewAutoplaceCost180 sxs+    "autoplace_cost90"+        -> PcbnewExprAttribute <$> asInt PcbnewAutoplaceCost90 sxs+    "zone_connect"+        -> PcbnewExprAttribute <$> asInt PcbnewZoneConnect sxs+    "roundrect_rratio"+        -> PcbnewExprAttribute <$> asDouble PcbnewRoundrectRratio sxs+    "die_length"+        -> PcbnewExprAttribute <$> asDouble PcbnewDieLength sxs+    _   -> Left $ "Error in " ++ (show pos) ++ ": unknown expression type '" ++ kw ++ "'"+fromSExpr sx@(Atom _ s) = case s of     "italic" -> Right $ PcbnewExprAttribute PcbnewItalic     "hide"   -> Right $ PcbnewExprAttribute PcbnewHide     "locked" -> Right $ PcbnewExprAttribute PcbnewLocked     "placed" -> Right $ PcbnewExprAttribute PcbnewPlaced     _ -> expecting "'italic' or 'hide' or 'locked' " sx-fromSExpr x = expecting "List with a key or a string atom" x+fromSExpr x = expecting "List _ with a key or a string atom" x  asPcbnewModule :: [SExpr] -> Either String PcbnewModule-asPcbnewModule (AtomStr n:xs) =+asPcbnewModule (Atom _ n:xs) =     interpretRest xs defaultPcbnewModule { pcbnewModuleName = n }     where         interpretRest [] m = Right m         interpretRest (sx:sxs) m = case fromSExpr sx of-            Left err -> Left ('\t':err)+            Left err -> Left err             Right (PcbnewExprAttribute (PcbnewLayer layer)) ->                 interpretRest sxs m {pcbnewModuleLayer = layer}             Right (PcbnewExprItem item) ->@@ -114,18 +120,18 @@ asPcbnewFpText (t:s:a:xs) = interpretType     where         interpretType = case t of-            (AtomStr "reference") ->+            (Atom _ "reference") ->                 interpretString (defaultPcbnewFpText {fpTextType = FpTextReference})-            (AtomStr "value")     ->+            (Atom _ "value")     ->                 interpretString (defaultPcbnewFpText {fpTextType = FpTextValue})-            (AtomStr "user")     ->+            (Atom _ "user")     ->                 interpretString (defaultPcbnewFpText {fpTextType = FpTextUser})             _           -> expecting "'reference', 'value' or 'user'" t         interpretString fp_text = case s of-            (AtomStr string) -> interpretAt fp_text {fpTextStr = string}+            (Atom _ string) -> interpretAt fp_text {fpTextStr = string}             _           -> expecting "string" s         interpretAt fp_text = case fromSExpr a of-            Left err -> Left ('\t':err)+            Left err -> Left err             Right (PcbnewExprAttribute (PcbnewAt at)) ->                 interpretRest xs fp_text {itemAt = at}             _ -> expecting "'at' expression (e.g. '(at 1.0 1.0)')" a@@ -144,7 +150,7 @@             _ -> fp_text         interpretRest [] fp_text = Right fp_text         interpretRest (sx:sxs) fp_text = case fromSExpr sx of-            Left err -> Left ('\t':err)+            Left err -> Left err             Right (PcbnewExprAttribute (PcbnewLayer layer)) ->                 interpretRest sxs (fp_text {itemLayer = layer})             Right (PcbnewExprAttribute (PcbnewFpTextEffects effects)) ->@@ -158,20 +164,20 @@ asFp defaultFp (s:e:xs) = interpretStart defaultFp     where         interpretStart fp_shape = case fromSExpr s of-            Left err -> Left ('\t':err)+            Left err -> Left err             Right (PcbnewExprAttribute (PcbnewStart start)) ->                 interpretEnd fp_shape {itemStart = start}             Right (PcbnewExprAttribute (PcbnewCenter center)) ->                 interpretEnd fp_shape {itemStart = center}             Right _ -> expecting "start (e.g. '(start 1.0 1.0)')" s         interpretEnd fp_shape = case fromSExpr e of-            Left err -> Left ('\t':err)+            Left err -> Left err             Right (PcbnewExprAttribute (PcbnewEnd end)) ->                 interpretRest xs fp_shape {itemEnd = end}             Right _ -> expecting "end (e.g. '(end 1.0 1.0)')" e         interpretRest [] fp_shape = Right fp_shape         interpretRest (sx:sxs) fp_shape = case fromSExpr sx of-            Left err -> Left ('\t':err)+            Left err -> Left err             Right (PcbnewExprAttribute (PcbnewWidth d))                 -> interpretRest sxs fp_shape {itemWidth = d}             Right (PcbnewExprAttribute (PcbnewLayer d))@@ -183,18 +189,18 @@ asPcbnewFpArc (s:e:xs) = interpretStart defaultPcbnewFpArc     where         interpretStart fp_arc = case fromSExpr s of-            Left err -> Left ('\t':err)+            Left err -> Left err             Right (PcbnewExprAttribute (PcbnewStart start)) ->                 interpretEnd fp_arc {itemStart = start}             Right _ -> expecting "start (e.g. '(start 1.0 1.0)')" s         interpretEnd fp_arc = case fromSExpr e of-            Left err -> Left ('\t':err)+            Left err -> Left err             Right (PcbnewExprAttribute (PcbnewEnd end)) ->                 interpretRest xs fp_arc {itemEnd = end}             Right _ -> expecting "end (e.g. '(end 1.0 1.0)')" e         interpretRest [] fp_arc = Right fp_arc         interpretRest (sx:sxs) fp_arc = case fromSExpr sx of-            Left err -> Left ('\t':err)+            Left err -> Left err             Right (PcbnewExprAttribute (PcbnewWidth d))                 -> interpretRest sxs fp_arc {itemWidth = d}             Right (PcbnewExprAttribute (PcbnewLayer d))@@ -209,7 +215,7 @@     where         interpretRest [] fp_poly = Right fp_poly         interpretRest (sx:sxs) fp_poly = case fromSExpr sx of-            Left err -> Left ('\t':err)+            Left err -> Left err             Right (PcbnewExprAttribute (PcbnewPts   d))                 -> interpretRest sxs fp_poly {fpPolyPts = d}             Right (PcbnewExprAttribute (PcbnewWidth d))@@ -222,18 +228,18 @@ asPcbnewPad (n:t:s:xs) = interpretNumber     where         interpretNumber = case n of-            (AtomStr num) -> interpretType defaultPcbnewPad {padNumber = num}+            (Atom _ num) -> interpretType defaultPcbnewPad {padNumber = num}             _ -> expecting "string designating pad number" n         interpretType :: PcbnewItem -> Either String PcbnewItem         interpretType pad = case t of-            (AtomStr str) -> case strToPadType str of+            (Atom _ str) -> case strToPadType str of                     Just d  -> interpretShape pad {padType = d}                     Nothing ->                         expecting "pad type (e.g. 'smd')" t             _ -> expecting "pad type string (e.g. 'smd')" t         interpretShape :: PcbnewItem -> Either String PcbnewItem         interpretShape pad = case s of-            (AtomStr str) -> case strToPadShape str of+            (Atom _ str) -> case strToPadShape str of                     Just d  -> interpretRest xs pad {padShape = d}                     Nothing ->                         expecting "pad shape (e.g. 'circle')" s@@ -241,7 +247,7 @@         interpretRest :: [SExpr] -> PcbnewItem -> Either String PcbnewItem         interpretRest [] pad = Right pad         interpretRest (sx:sxs) pad = case fromSExpr sx of-            Left err -> Left ('\t':err)+            Left err -> Left err             Right (PcbnewExprAttribute (PcbnewAt d))                 -> interpretRest sxs pad {itemAt = d}             Right (PcbnewExprAttribute (PcbnewLayers d))@@ -268,6 +274,8 @@                 -> pushToAttrs sxs a pad             Right (PcbnewExprAttribute a@(PcbnewRoundrectRratio _))                 -> pushToAttrs sxs a pad+            Right (PcbnewExprAttribute a@(PcbnewDieLength _))+                -> pushToAttrs sxs a pad             _ -> expecting "at, size, drill, layers , margins etc. or nothing" sx         pushToAttrs sxs a pad = interpretRest sxs (over padAttributes (++[a]) pad) asPcbnewPad xs = expecting' "number, type and shape" xs@@ -277,31 +285,49 @@ asPcbnewLayer x    = expecting' "only one layer name" x  onePcbnewLayer :: SExpr -> Either String PcbnewAttribute-onePcbnewLayer (AtomStr n) = case strToLayer n of+onePcbnewLayer (Atom _ n) = case strToLayer n of     Just l  -> Right $ PcbnewLayer l     Nothing -> Left ("-> Unknown layer name: " ++ n) onePcbnewLayer x = expecting "layer name" x  asPcbnewAt :: [SExpr] -> Either String PcbnewAttribute-asPcbnewAt (AtomDbl x:[AtomDbl y]) =-    Right $ PcbnewAt $ defaultPcbnewAtT {pcbnewAtPoint = (x,y)}-asPcbnewAt (AtomDbl x:AtomDbl y:[AtomDbl o]) =-    Right $ PcbnewAt $ PcbnewAtT (x,y) o-asPcbnewAt l@[List _] = asXyz PcbnewModelAt l+asPcbnewAt sx@(Atom _ x:[Atom _ y]) = case readXy x y of+    Just xy -> Right $ PcbnewAt $ defaultPcbnewAtT {pcbnewAtPoint = xy}+    Nothing -> expecting' "x y coordinates" sx+asPcbnewAt sx@(Atom _ x:Atom _ y:[Atom _ o]) = case readXyz x y o of+    Just (x', y', o') -> Right $ PcbnewAt $ PcbnewAtT (x',y') o'+    Nothing -> expecting' "x y coordinates and orientation" sx+asPcbnewAt l@[List _ _] = asXyz PcbnewModelAt l asPcbnewAt x =-    expecting' "two or three floats or an 'xyz' expression" x+    expecting' "x y coordinates and orientation" x +readXy :: String -> String -> Maybe (Double, Double)+readXy x y = do+   x' <- readMaybeDouble x+   y' <- readMaybeDouble y+   return (x', y') ++readXyz :: String -> String -> String -> Maybe (Double, Double, Double)+readXyz x y z = do+   x' <- readMaybeDouble x+   y' <- readMaybeDouble y+   z' <- readMaybeDouble z+   return (x', y', z')++ asPcbnewEffects :: [SExpr] -> Either String PcbnewAttribute asPcbnewEffects xs = interpretRest xs []    where       interpretRest [] effects = Right (PcbnewFpTextEffects effects)       interpretRest (sx:sxs) effects = case fromSExpr sx of-         Left err -> Left ('\t':err)+         Left err -> Left err          Right (PcbnewExprAttribute justify@(PcbnewJustify _))             -> interpretRest sxs (justify:effects)          Right (PcbnewExprAttribute font@(PcbnewFont _ _ _))             -> interpretRest sxs (font:effects)+         Right (PcbnewExprAttribute PcbnewHide)+            -> interpretRest sxs (PcbnewHide:effects)          _ -> expecting "font or justify expression" sx  @@ -310,7 +336,7 @@     where         interpretRest [] font = Right font         interpretRest (sx:sxs) font = case fromSExpr sx of-            Left err -> Left ('\t':err)+            Left err -> Left err             Right (PcbnewExprAttribute (PcbnewSize size)) ->                 interpretRest sxs font {pcbnewFontSize = size}             Right (PcbnewExprAttribute (PcbnewThickness t)) ->@@ -320,19 +346,21 @@             Right _ -> expecting "size, thickness or 'italic'" sx  asXy :: ((Double, Double) -> a) -> [SExpr] -> Either String a-asXy constructor [AtomDbl x, AtomDbl y] = Right $ constructor (x,y)+asXy constructor sx@[Atom _ x, Atom _ y] = case readXy x y of+   Just xy -> Right $ constructor xy+   Nothing -> expecting' "two floats (e.g. 1.0 1.0)" sx asXy _ x = expecting' "two floats (e.g. 1.0 1.0)" x  asPcbnewPts :: [SExpr] -> Either String PcbnewAttribute asPcbnewPts = fmap PcbnewPts . foldr interpretXys (Right [])     where interpretXys sx z = case fromSExpr sx of-                        Left err -> Left ('\t':err)+                        Left err -> Left err                         Right (PcbnewExprAttribute (PcbnewXy xy))                             -> Right (xy:) <*> z                         Right _ -> expecting "'xy' (e.g. '(xy 1.0 1.0)')" sx  asString :: (String -> PcbnewAttribute) -> [SExpr] -> Either String PcbnewAttribute-asString pcbnew [AtomStr s] =  Right $ pcbnew s+asString pcbnew [Atom _ s] =  Right $ pcbnew s asString _ x = expecting' "string" x  asPcbnewLayers :: [SExpr] -> Either String PcbnewAttribute@@ -343,11 +371,15 @@                     ++ unlines (map ("\t\t"++) (lefts layers))  asDouble :: (Double -> PcbnewAttribute) -> [SExpr] -> Either String PcbnewAttribute-asDouble constructor [AtomDbl d] = Right $ constructor d+asDouble constructor [sx@(Atom _ d)] = case readMaybeDouble d of+   Just d' -> Right $ constructor d'+   Nothing -> expecting "one float (e.g. '1.0')" sx asDouble _ x = expecting' "one float (e.g. '1.0')" x  asInt :: (Int -> PcbnewAttribute) -> [SExpr] -> Either String PcbnewAttribute-asInt constructor [AtomDbl d] = Right $ constructor $ round d+asInt constructor [sx@(Atom _ i)] = case readMaybe i of+   Just i' -> Right $ constructor i'+   Nothing -> expecting "one int (e.g. '1')" sx asInt _ x = expecting' "one int (e.g. '1')" x  asPcbnewDrill :: [SExpr] -> Either String PcbnewAttribute@@ -355,39 +387,41 @@     where         interpretRest [] drill = Right $ PcbnewDrill drill         interpretRest (sx:sxs) drill = case sx of-            AtomDbl d  -> if isNothing (pcbnewDrillSize drill)-                          then interpretRest sxs drill-                                { pcbnewDrillSize = Just (d,d) }-                          else interpretRest sxs drill-                               { pcbnewDrillSize =-                                    fmap (\(x,_) -> (x,d)) (pcbnewDrillSize drill)-                               }-            AtomStr "oval"  -> interpretRest sxs drill {pcbnewDrillOval = True}-            (List _) -> case fromSExpr sx of-                Left err -> Left ('\t':err)+            Atom _ "oval"  -> interpretRest sxs drill {pcbnewDrillOval = True}+            (List _ _) -> case fromSExpr sx of+                Left err -> Left err                 Right (PcbnewExprAttribute (PcbnewOffset xy))                     -> interpretRest sxs drill {pcbnewDrillOffset = Just xy}                 Right _ -> expecting "offset or nothing" sx-            _ -> expecting "float, 'oval' or offset" sx+            Atom _ d  -> case readMaybeDouble d of+                Just d' -> if isNothing (pcbnewDrillSize drill)+                           then interpretRest sxs drill+                                { pcbnewDrillSize = Just (d',d') }+                           else interpretRest sxs drill+                                { pcbnewDrillSize =+                                     fmap (\(x,_) -> (x,d')) (pcbnewDrillSize drill)+                                }+                Nothing -> expecting "float, 'oval' or offset" sx  asPcbnewXyz :: [SExpr] -> Either String PcbnewAttribute-asPcbnewXyz (AtomDbl x:AtomDbl y:[AtomDbl z]) =-    Right $ PcbnewXyz (x,y,z)+asPcbnewXyz sx@(Atom _ x:Atom _ y:[Atom _ z]) = case readXyz x y z of+    Just xyz -> Right $ PcbnewXyz xyz+    Nothing -> expecting' "three floats" sx asPcbnewXyz x = expecting' "three floats" x  asXyz :: (PcbnewAttribute -> a) -> [SExpr] -> Either String a-asXyz constructor [l@(List _)] = case fromSExpr l of-    Left err -> Left ('\t':err)+asXyz constructor [l@(List _ _)] = case fromSExpr l of+    Left err -> Left err     Right (PcbnewExprAttribute xyz) -> Right $ constructor xyz     Right _ -> expecting "xyz (e.g. '(xyz 1 1 1)')" l asXyz _ x = expecting' "xyz (e.g. '(xyz 1 1 1)')" x  asPcbnewModel :: [SExpr] -> Either String PcbnewAttribute-asPcbnewModel (AtomStr p:xs) = interpretRest xs defaultPcbnewModel {pcbnewModelPath = p}+asPcbnewModel (Atom _ p:xs) = interpretRest xs defaultPcbnewModel {pcbnewModelPath = p}     where         interpretRest [] model = Right model         interpretRest (sx:sxs) model = case fromSExpr sx of-            Left err -> Left ('\t':err)+            Left err -> Left err             Right (PcbnewExprAttribute (PcbnewModelAt (PcbnewXyz xyz))) ->                 interpretRest sxs model {pcbnewModelAt = xyz}             Right (PcbnewExprAttribute (PcbnewModelScale (PcbnewXyz xyz))) ->@@ -411,7 +445,7 @@    where js = fmap oneJustifyT sx  oneJustifyT :: SExpr -> Either String PcbnewJustifyT-oneJustifyT sx@(AtomStr s) = case strToJustify s of+oneJustifyT sx@(Atom _ s) = case strToJustify s of    Just j -> Right j    Nothing -> expecting justifyOneOf sx oneJustifyT x = expecting justifyOneOf x@@ -419,7 +453,7 @@  expecting :: String -> SExpr -> Either String a expecting x y =-    Left $ "-> Expecting " ++ x ++ " but got " +++    Left $ "Error in " ++ pos ++ ": expecting " ++ x ++ " but got " ++         nothing_or (strip_brackets (write y)) ++ " instead"     where         nothing_or y' = case y' of@@ -428,6 +462,19 @@         strip_brackets y' = case head y' of                 '(' -> tail . init $ y'                 _   -> y'+        pos = show (getPos y) + expecting' :: String -> [SExpr] -> Either String a-expecting' x y = expecting x $ List y+expecting' x y = expecting x $ List (newPos "" 0 0) y+++{- Like readMaybe but allows for '.1' and '-.1' style doubles -}+readMaybeDouble :: String -> Maybe Double+readMaybeDouble str@(c1:c2:rest) = case c1 of+   '.' -> readMaybe ('0':str)+   '-' -> case c2 of+      '.' -> readMaybe ('-':'0':rest)+      _   -> readMaybe str+   _  -> readMaybe str+readMaybeDouble str = readMaybe str

@@ -1,5 +1,6 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module Data.Kicad.PcbnewExpr.PcbnewExpr ( -- * Types@@ -59,6 +60,7 @@ import Data.Tuple (swap) import Data.Maybe import Data.Foldable (foldMap)+import Text.Parsec.Pos (newPos, SourcePos)  import Data.Kicad.SExpr.SExpr import Data.Kicad.Util@@ -86,10 +88,14 @@                                  }     deriving (Show, Eq) ++pos :: SourcePos+pos = newPos "" 0 0+ instance SExpressable PcbnewModule where     toSExpr (PcbnewModule name l attrs items) =-        List $ [ AtomKey KeyModule-               , AtomStr name+        List pos $ [ Atom pos "module"+               , Atom pos name                , toSExpr (PcbnewLayer l)                ] ++ map toSExpr attrs                ++ map toSExpr items@@ -185,32 +191,32 @@  instance SExpressable PcbnewItem where     toSExpr (PcbnewFpText t s a l h si th i j) =-        List $ [ AtomKey KeyFpText-               , AtomStr $ fpTextTypeToStr t-               , AtomStr s+        List pos $ [ Atom pos "fp_text"+               , Atom pos $ fpTextTypeToStr t+               , Atom pos s                , toSExpr (PcbnewAt a)                , toSExpr (PcbnewLayer l)                ]-               ++ [AtomStr "hide" | h]+               ++ [Atom pos "hide" | h]                ++ [toSExpr $ PcbnewFpTextEffects $                       [PcbnewFont si th i]                       ++ if j == [] then [] else [PcbnewJustify j]]     toSExpr (PcbnewFpLine s e l w) =-        List [ AtomKey KeyFpLine+        List pos [ Atom pos "fp_line"              , toSExpr (PcbnewStart s)              , toSExpr (PcbnewEnd   e)              , toSExpr (PcbnewLayer l)              , toSExpr (PcbnewWidth w)              ]     toSExpr (PcbnewFpCircle s e l w) =-        List [ AtomKey KeyFpCircle+        List pos [ Atom pos "fp_circle"              , toSExpr (PcbnewCenter s)              , toSExpr (PcbnewEnd    e)              , toSExpr (PcbnewLayer  l)              , toSExpr (PcbnewWidth  w)              ]     toSExpr (PcbnewFpArc s e a l w) =-        List [ AtomKey KeyFpArc+        List pos [ Atom pos "fp_arc"              , toSExpr (PcbnewStart s)              , toSExpr (PcbnewEnd   e)              , toSExpr (PcbnewAngle a)@@ -218,16 +224,16 @@              , toSExpr (PcbnewWidth w)              ]     toSExpr (PcbnewFpPoly ps l w) =-        List [ AtomKey KeyFpPoly+        List pos [ Atom pos "fp_poly"              , toSExpr (PcbnewPts ps)              , toSExpr (PcbnewLayer l)              , toSExpr (PcbnewWidth w)              ]     toSExpr (PcbnewPad n t s a si l attrs) =-        List $ [ AtomKey KeyPad-               , AtomStr n-               , AtomStr $ fpPadTypeToStr t-               , AtomStr $ fpPadShapeToStr s+        List pos $ [ Atom pos "pad"+               , Atom pos n+               , Atom pos $ fpPadTypeToStr t+               , Atom pos $ fpPadShapeToStr s                , toSExpr $ PcbnewAt a                , toSExpr $ PcbnewSize si                , toSExpr $ PcbnewLayers l@@ -399,6 +405,7 @@                      | PcbnewThermalWidth      Double                      | PcbnewThermalGap        Double                      | PcbnewJustify           [PcbnewJustifyT]+                     | PcbnewDieLength         Double     deriving (Show, Eq)  @@ -406,84 +413,93 @@ type PcbnewXyzT = (Double, Double, Double)  instance SExpressable PcbnewAttribute where-    toSExpr (PcbnewLayer l) = List [ AtomKey KeyLayer-                                  , AtomStr $ layerToStr l-                                  ]+    toSExpr (PcbnewLayer l) = List pos [ Atom pos "layer"+                                   , Atom pos $ layerToStr l+                                   ]     toSExpr (PcbnewAt (PcbnewAtT (x,y) o)) =-        List $ [ AtomKey KeyAt-               , AtomDbl x-               , AtomDbl y-               ] ++ [AtomDbl o | o /= 0]+        List pos $ [ Atom pos "at"+               , atomDbl x+               , atomDbl y+               ] ++ [atomDbl o | o /= 0]     toSExpr (PcbnewLayers ls) =-        List (AtomKey KeyLayers : map (AtomStr . layerToStr) ls)+        List pos (Atom pos "layers" : map (Atom pos . layerToStr) ls)     toSExpr (PcbnewFont s t i) =-        List $ [ AtomKey KeyFont, toSExpr (PcbnewSize s)+        List pos $ [ Atom pos "font", toSExpr (PcbnewSize s)                , toSExpr (PcbnewThickness t)-               ] ++ [AtomStr "italic" | i]+               ] ++ [Atom pos "italic" | i]     toSExpr (PcbnewPts xys) =-        List $ AtomKey KeyPts : map (toSExpr . PcbnewXy) xys+        List pos $ Atom pos "pts" : map (toSExpr . PcbnewXy) xys     toSExpr (PcbnewModel p a s r) =-        List [AtomKey KeyModel-             , AtomStr p+        List pos [ Atom pos "model"+             , Atom pos p              , toSExpr (PcbnewModelAt     (PcbnewXyz a))              , toSExpr (PcbnewModelScale  (PcbnewXyz s))              , toSExpr (PcbnewModelRotate (PcbnewXyz r))              ]     toSExpr (PcbnewDrill (PcbnewDrillT s o off)) =-        List $ [AtomKey KeyDrill]-             ++ [AtomStr "oval" | o]+        List pos $ [Atom pos "drill"]+             ++ [Atom pos "oval" | o]              ++ (if o && isJust s-                then [AtomDbl (fst (fromJust s)), AtomDbl (snd (fromJust s))]-                else [AtomDbl (fst (fromJust s)) | isJust s])+                then [atomDbl (fst (fromJust s)), atomDbl (snd (fromJust s))]+                else [atomDbl (fst (fromJust s)) | isJust s])              ++ [toSExpr (PcbnewOffset (fromJust off)) | isJust off]     toSExpr (PcbnewXyz (x,y,z)) =-        List [AtomKey KeyXyz, AtomDbl x, AtomDbl y, AtomDbl z]-    toSExpr (PcbnewFpTextEffects l)  = List $ [AtomKey KeyEffects] ++ fmap toSExpr l-    toSExpr (PcbnewFpTextType t)     = AtomStr $ fpTextTypeToStr t-    toSExpr (PcbnewModelAt     xyz)  = List [AtomKey KeyAt    , toSExpr xyz]-    toSExpr (PcbnewModelScale  xyz)  = List [AtomKey KeyScale , toSExpr xyz]-    toSExpr (PcbnewModelRotate xyz)  = List [AtomKey KeyRotate, toSExpr xyz]-    toSExpr (PcbnewClearance   d) = toSxD KeyClearance              d-    toSExpr (PcbnewSolderPasteRatio d) = toSxD KeySolderPasteRatio  d-    toSExpr (PcbnewMaskMargin  d) = toSxD KeySolderMaskMargin       d-    toSExpr (PcbnewPasteMargin d) = toSxD KeySolderPasteMargin      d-    toSExpr (PcbnewPasteMarginRatio d) = toSxD KeySolderPasteMarginRatio d-    toSExpr (PcbnewRoundrectRratio  d) = toSxD KeyRoundrectRratio d-    toSExpr (PcbnewThickness   d) = toSxD KeyThickness      d-    toSExpr (PcbnewWidth       d) = toSxD KeyWidth          d-    toSExpr (PcbnewAngle       d) = toSxD KeyAngle          d-    toSExpr (PcbnewThermalWidth d) = toSxD KeyThermalWidth  d-    toSExpr (PcbnewThermalGap   d) = toSxD KeyThermalGap    d-    toSExpr (PcbnewSize      xy)  = toSxDD KeySize      xy-    toSExpr (PcbnewStart     xy)  = toSxDD KeyStart     xy-    toSExpr (PcbnewCenter    xy)  = toSxDD KeyCenter    xy-    toSExpr (PcbnewRectDelta xy)  = toSxDD KeyRectDelta xy-    toSExpr (PcbnewEnd       xy)  = toSxDD KeyEnd       xy-    toSExpr (PcbnewXy        xy)  = toSxDD KeyXy        xy-    toSExpr (PcbnewOffset    xy)  = toSxDD KeyOffset    xy-    toSExpr (PcbnewTedit s)       = toSxStr KeyTedit s-    toSExpr (PcbnewDescr s)       = toSxStr KeyDescr s-    toSExpr (PcbnewTags  s)       = toSxStr KeyTags  s-    toSExpr (PcbnewPath  s)       = toSxStr KeyPath  s-    toSExpr (PcbnewAttr  s)       = toSxStr KeyAttr  s-    toSExpr PcbnewItalic = AtomStr "italic"-    toSExpr PcbnewHide   = AtomStr "hide"-    toSExpr PcbnewPlaced = AtomStr "placed"-    toSExpr PcbnewLocked = AtomStr "locked"-    toSExpr (PcbnewAutoplaceCost90  i) = toSxD KeyAutoplaceCost90  (fromIntegral i)-    toSExpr (PcbnewAutoplaceCost180 i) = toSxD KeyAutoplaceCost180 (fromIntegral i)-    toSExpr (PcbnewZoneConnect      i) = toSxD KeyZoneConnect      (fromIntegral i)-    toSExpr (PcbnewJustify         js) = List $ AtomKey KeyJustify:map (AtomStr . justifyToString) js+        List pos [Atom pos "xyz", atomDbl x, atomDbl y, atomDbl z]+    toSExpr (PcbnewFpTextEffects l)  = List pos $ [Atom pos "effects"] ++ fmap toSExpr l+    toSExpr (PcbnewFpTextType t)     = Atom pos $ fpTextTypeToStr t+    toSExpr (PcbnewModelAt     xyz)  = List pos [Atom pos "at"    , toSExpr xyz]+    toSExpr (PcbnewModelScale  xyz)  = List pos [Atom pos "scale" , toSExpr xyz]+    toSExpr (PcbnewModelRotate xyz)  = List pos [Atom pos "rotate", toSExpr xyz]+    toSExpr (PcbnewClearance   d)      = toSxD "clearance"                 d+    toSExpr (PcbnewSolderPasteRatio d) = toSxD "solder_paste_ratio"        d+    toSExpr (PcbnewMaskMargin  d)      = toSxD "solder_mask_margin"        d+    toSExpr (PcbnewPasteMargin d)      = toSxD "solder_paste_margin"       d+    toSExpr (PcbnewPasteMarginRatio d) = toSxD "solder_paste_margin_ratio" d+    toSExpr (PcbnewRoundrectRratio  d) = toSxD "roundrect_rratio"          d+    toSExpr (PcbnewThickness   d)      = toSxD "thickness"                 d+    toSExpr (PcbnewWidth       d)      = toSxD "width"                     d+    toSExpr (PcbnewAngle       d)      = toSxD "angle"                     d+    toSExpr (PcbnewThermalWidth d)     = toSxD "thermal_width"             d+    toSExpr (PcbnewThermalGap   d)     = toSxD "thermal_gap"               d+    toSExpr (PcbnewDieLength   d)      = toSxD "die_length"                d+    toSExpr (PcbnewSize      xy)       = toSxDD "size"       xy+    toSExpr (PcbnewStart     xy)       = toSxDD "start"      xy+    toSExpr (PcbnewCenter    xy)       = toSxDD "center"     xy+    toSExpr (PcbnewRectDelta xy)       = toSxDD "rect_delta" xy+    toSExpr (PcbnewEnd       xy)       = toSxDD "end"        xy+    toSExpr (PcbnewXy        xy)       = toSxDD "xy"         xy+    toSExpr (PcbnewOffset    xy)       = toSxDD "offset"     xy+    toSExpr (PcbnewTedit s)            = toSxStr "tedit" s+    toSExpr (PcbnewDescr s)            = toSxStr "descr" s+    toSExpr (PcbnewTags  s)            = toSxStr "tags"  s+    toSExpr (PcbnewPath  s)            = toSxStr "path"  s+    toSExpr (PcbnewAttr  s)            = toSxStr "attr"  s+    toSExpr PcbnewItalic               = Atom pos "italic"+    toSExpr PcbnewHide                 = Atom pos "hide"+    toSExpr PcbnewPlaced               = Atom pos "placed"+    toSExpr PcbnewLocked               = Atom pos "locked"+    toSExpr (PcbnewAutoplaceCost90  i) =+        List pos [Atom pos "autoplace_cost90"  , Atom pos (show i)]+    toSExpr (PcbnewAutoplaceCost180 i) =+        List pos [Atom pos "autoplace_cost180" , Atom pos (show i)]+    toSExpr (PcbnewZoneConnect      i) =+        List pos [Atom pos "zone_connect"      , Atom pos (show i)]+    toSExpr (PcbnewJustify         js) =+        List pos $ (Atom pos "justify"):map (Atom pos . justifyToString) js -toSxD :: Keyword -> Double -> SExpr-toSxD  kw d = List [AtomKey kw, AtomDbl d] -toSxDD :: Keyword -> V2Double -> SExpr-toSxDD kw (x,y) = List [AtomKey kw, AtomDbl x, AtomDbl y]+atomDbl :: Double -> SExpr+atomDbl = Atom pos . show -toSxStr :: Keyword -> String -> SExpr-toSxStr kw s = List [AtomKey kw, AtomStr s]+toSxD :: String -> Double -> SExpr+toSxD kw d = List pos [Atom pos kw, atomDbl d] +toSxDD :: String -> V2Double -> SExpr+toSxDD kw (x,y) = List pos [Atom pos kw, atomDbl x, atomDbl y]++toSxStr :: String -> String -> SExpr+toSxStr kw s = List pos [Atom pos kw, Atom pos s]+ instance AEq PcbnewAttribute where     (PcbnewAt                x) ~== (PcbnewAt                y) = x ~== y     (PcbnewSize              x) ~== (PcbnewSize              y) = x ~== y@@ -531,7 +547,8 @@                   | BCu       | BPaste    | BMask     | DwgsUser  | CmtsUser                   | FAdhes    | AllSilk   | FandBCu   | AllCu     | AllMask                   | AllPaste  | EdgeCuts  | FCrtYd    | BCrtYd    | FFab-                  | BFab      | Margin    | Eco1User  | Eco2User  | BAdhes+                  | BFab      | AllFab    | Margin    | Eco1User  | Eco2User+                  | BAdhes                   | Inner1Cu  | Inner2Cu  | Inner3Cu  | Inner4Cu  | Inner5Cu                   | Inner6Cu  | Inner7Cu  | Inner8Cu  | Inner9Cu  | Inner10Cu                   | Inner11Cu | Inner12Cu | Inner13Cu | Inner14Cu | Inner15Cu@@ -564,6 +581,7 @@     , ("B.CrtYd"   , BCrtYd)     , ("F.Fab"     , FFab)     , ("B.Fab"     , BFab)+    , ("*.Fab"     , AllFab)     , ("Edge.Cuts" , EdgeCuts)     , ("Margin"    , Margin)     , ("Eco1.User" , Eco1User)

@@ -4,14 +4,14 @@ ( -- * Types   SExpr(..)-, Keyword(..) , SExpressable(..) -- * Writing , pretty , write-, writeKeyword -- * Parsing , parse+, parseWithFilename+, getPos ) where import Data.Kicad.SExpr.SExpr

@@ -2,24 +2,28 @@ {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} module Data.Kicad.SExpr.Parse ( parse+, parseWithFilename ) where import Text.ParserCombinators.Parsec hiding (spaces, parse) import qualified Text.ParserCombinators.Parsec as Parsec (parse)-import Text.ParserCombinators.Parsec.Number import Text.Parsec.Char (endOfLine)-import Control.Monad+import Text.Parsec (getPosition)  import Data.Kicad.SExpr.SExpr-import Data.Kicad.SExpr.Write (writeKeyword)  {-| Parse a 'String' as a 'SExpr' or return an error. -} parse :: String -> Either String SExpr-parse input = case Parsec.parse parseListOrComment "SExpr" input of-    Left err -> Left $ "Parse Error: " ++ show err-    Right val -> Right val+parse = parseWithFilename "" +{-| Parse a 'String' as a 'SExpr' giving a filename to use in the source code location -}+parseWithFilename :: String -> String -> Either String SExpr+parseWithFilename filename input =+    case Parsec.parse parseListOrComment filename input of+        Left err -> Left $ "Parse Error: " ++ show err+        Right val -> Right val + parseListOrComment :: Parser SExpr parseListOrComment = do     spaces@@ -39,77 +43,34 @@  parseList :: Parser SExpr parseList = do+    pos <- getPosition     char '('     spaces-    first <- parseKeyword-    spaces-    rest <- let parseRest = try parseAtom `sepEndBy` spaces in case first of-        AtomKey KeyFpText -> do t <- parseString-                                  <?> "string designating type e.g. 'user'"-                                spaces1-                                s <- parseString-                                spaces-                                r <- parseRest-                                return (t:s:r)-        AtomKey KeyModule -> do t <- parseString-                                spaces-                                r <- parseRest-                                return (t:r)-        AtomKey KeyTedit  -> do s <- parseString-                                spaces-                                return [s]-        AtomKey KeyDescr  -> do s <- parseString-                                spaces-                                return [s]-        AtomKey KeyTags   -> do s <- parseString-                                spaces-                                return [s]-        AtomKey KeyPad    -> do n <- parseString-                                spaces1-                                t <- parseString-                                  <?> "string designating type e.g. 'smd'"-                                spaces1-                                s <- parseString-                                spaces-                                r <- parseRest-                                return (n:t:s:r)-        _                 -> parseRest-    spaces+    list <- try parseExpr `sepEndBy` spaces     char ')'     spaces-    return $ List (first:rest)+    return $ List pos list -parseAtom :: Parser SExpr-parseAtom =  try parseDouble-         <|> try parseString++parseExpr :: Parser SExpr+parseExpr =  try parseString          <|> try parseListOrComment          <?> "a double, string or s-expression" -parseOneKeyword :: Keyword -> Parser SExpr-parseOneKeyword kw = try $ string (writeKeyword kw) >> return (AtomKey kw) -parseKeyword :: Parser SExpr-parseKeyword = choice (map parseOneKeyword [minBound..maxBound]) <?> "keyword"- parseString :: Parser SExpr-parseString = liftM AtomStr (parseQuotedString <|> parseUnquotedString <?> "string")-        where-            parseQuotedString  = do-                char '"'-                x <- many (noneOf "\\\"" <|> (char '\\' >> anyChar))-                char '"'-                return x-            parseUnquotedString = many1 (noneOf "\" ()\r\n")+parseString =+    do pos <- getPosition+       str <- parseQuotedString <|> parseUnquotedString <?> "string"+       return $ Atom pos str+            where+                parseQuotedString  = do+                    char '"'+                    x <- many (noneOf "\\\"" <|> (char '\\' >> anyChar))+                    char '"'+                    return x+                parseUnquotedString = many1 (noneOf " ()\r\n") -parseDouble :: Parser SExpr-parseDouble = do-    negate_or_id <- sign-    -- the Bool in floating3 is requireDigit which affects whether many (False,-    -- 0 or more) or many1 (True, 1 or more) is used-    x <- floating3 True-    lookAhead (char ')' <|> spaceChar)-    return $ AtomDbl $ negate_or_id x -spaces1 = skipMany1 spaceChar spaces = skipMany spaceChar-spaceChar = endOfLine <|> space+spaceChar = oneOf "\r\n\t "

@@ -1,66 +1,20 @@ module Data.Kicad.SExpr.SExpr ( SExpr(..)-, Keyword(..) , SExpressable(..)+, getPos ) where+import Text.Parsec (SourcePos) -data SExpr = AtomKey Keyword-           | AtomStr String-           | AtomDbl Double-           | List [SExpr]+data SExpr = Atom SourcePos String+           | List SourcePos [SExpr]     deriving (Show, Eq) -{- The keywords _must_ be "Key" ++ camel-case version of the ones in the- - kicad_mod files as the parser and writer use the derived 'Show' instance.- - The parser will also try them in the order they appear below so KeyAttr has- - to appear before KeyAt for instance. -}-data Keyword = KeyZoneConnect-             | KeyXyz-             | KeyXy-             | KeyWidth-             | KeyThickness-             | KeyThermalWidth-             | KeyThermalGap-             | KeyTedit-             | KeyTags-             | KeyStart-             | KeySolderPasteMarginRatio-             | KeySolderPasteMargin-             | KeySolderMaskMargin-             | KeySize-             | KeyScale-             | KeyRoundrectRratio-             | KeyRotate-             | KeyRectDelta-             | KeyPts-             | KeyPath-             | KeyPad-             | KeyOffset-             | KeyModule-             | KeyModel-             | KeyLayers-             | KeyLayer-             | KeyJustify-             | KeyFpText-             | KeyFpPoly-             | KeyFpLine-             | KeyFpCircle-             | KeyFpArc-             | KeyFont-             | KeyEnd-             | KeyEffects-             | KeyDrill-             | KeyDescr-             | KeyClearance-             | KeySolderPasteRatio-             | KeyCenter-             | KeyAutoplaceCost90-             | KeyAutoplaceCost180-             | KeyAttr-             | KeyAt-             | KeyAngle-    deriving (Show, Eq, Enum, Bounded)- class SExpressable a where     toSExpr :: a -> SExpr++{-| Get s-expression source code position (filename, line-number and+ - column-number) -}+getPos :: SExpr -> SourcePos+getPos (Atom pos _) = pos+getPos (List pos _) = pos

@@ -1,45 +1,21 @@ module Data.Kicad.SExpr.Write ( pretty , write-, writeKeyword ) where-import Data.Char (toLower, isLower, isNumber)-import Data.List (intercalate) import Text.PrettyPrint.Compact  import Data.Kicad.SExpr.SExpr -{-| Pretty-print a 'SExpr' as a readable 'Doc'. -}+{-| Pretty-print an s-expression as a readable "document". -} pretty :: SExpr -> Doc-pretty (List xs) = text "(" <> align (sep $ map pretty xs) <> text ")"+pretty (List _ xs) = text "(" <> align (sep $ map pretty xs) <> text ")" pretty atm = text $ write atm  -{-| Serialize an SExpr as a compact s-expression 'String'. -}+{-| Serialize an s-expression into a compact string. -} write :: SExpr -> String-write (AtomKey kw)  = writeKeyword kw-write (AtomStr atm) |  (atm == "")-                    || head atm `elem` '.':'-':['0'..'9']-                    || foldr-                        (\c z -> z || c `elem` ')':'(':'\\':'\"':['\0'..' '])-                            False atm = show atm -- escaped string with quotes-                    | otherwise       = atm--- this should just be printf "%g" but that doesn't work as it should-write (AtomDbl atm) = strip_zeros $ break (== '.') $ show atm-    where strip_zeros (s1,s2) = s1 ++ dot_if_needed (reverse-                                           $ dropWhile (=='0') $ reverse s2)-          dot_if_needed s     = if s == "." then "" else s-write (List    sxs) = "(" ++ unwords (map write sxs) ++ ")"--{-| Write a 'Keyword' as a 'String'. Removes \"Key\" from the 'Show'-   instance and converts the rest to underscore (e.g KeyFpTextType becomes-   "fp_text_type"). -}-writeKeyword :: Keyword -> String-writeKeyword = intercalate "_" . splitCapWords . drop 3 . show-    where-        splitCapWords "" = []-        splitCapWords (x:xs) =-            let (word, rest) = span (\c -> isLower c || isNumber c) xs-            in (toLower x : word) : splitCapWords rest-+write (Atom _ str) | (str == "") || needs_quotes = show str -- escaped string with quotes+                   | otherwise                   = str      -- bare string without quotes+    where needs_quotes = foldr (\c z -> z || c `elem` '#':')':'(':'\\':'\"':['\0'..' ']) False str+write (List _ sxs) = "(" ++ unwords (map write sxs) ++ ")"

@@ -0,0 +1,14 @@+module Data.Kicad.Util where++import Data.Maybe++maybeHead :: [a] -> Maybe a+maybeHead [] = Nothing+maybeHead (x:_) = Just x++headOr :: a -> [a] -> a+headOr d xs = fromMaybe d (maybeHead xs)++maybeLast :: [a] -> Maybe a+maybeLast [] = Nothing+maybeLast xs = Just $ last xs

@@ -0,0 +1,32 @@+# Haskell KiCad Data+[![Build Status](https://travis-ci.org/monostable/haskell-kicad-data.svg?branch=master)](https://travis-ci.org/kasbah/haskell-kicad-data)++Parse and write [KiCad](http://kicad-pcb.org) data (currently .kicad_mod files only).++This library is tested with QuickCheck to ensure it can parse whatever it outputs. +The parser is also fairly regularily checked against over 38,000 kicad_mod files currently part of [monostable/kicad_footprints](https://github.com/monostable/kicad_footprints). The resulting output of these parsed files is then checked with KiCad scripting to make sure they are still valid.++# Usage++    $ cabal repl++```+*Data.Kicad.PcbnewExpr> let pad = parse "(pad 1 smd rect (size 1 1) (at 1 1) (layers F.Cu))"+*Data.Kicad.PcbnewExpr> pad+Right (PcbnewExprItem (PcbnewPad {padNumber = "1", padType = SMD, padShape =+Rect, itemAt = PcbnewAtT {pcbnewAtPoint = (1.0,1.0), pcbnewAtOrientation =+0.0}, itemSize = (1.0,1.0), padLayers = [FCu], padAttributes_ = []}))+*Data.Kicad.PcbnewExpr> fmap write pad+Right "(pad \"1\" smd rect (at 1 1) (size 1 1) (layers F.Cu))"+```++See [docs on Hackage](https://hackage.haskell.org/package/kicad-data).+++# Projects Using This++- [ppelleti/footprint-to-script](https://github.com/ppelleti/footprint-to-script) - Converts a KiCad footprint to a [KicadModTree](https://github.com/pointhi/kicad-footprint-generator) Python script.++# License++This project is MIT licensed but [one dependency](https://hackage.haskell.org/package/pretty-compact) is licensed under GPLv3 thus the GPLv3 applies to the project as a whole.

@@ -0,0 +1,9 @@++---++Version 0.5.0++- Add support for *.Fab layers+- Add support for die_length pad attribute+- Fix issue with comment character output+- Simplify s-expression parser (now supports all KiCad s-expression formats)

@@ -1,17 +1,21 @@ name:          kicad-data-version:       0.4.0+version:       0.5.0 synopsis:      Parser and writer for KiCad files. license:       MIT license-file:  LICENSE author:        Kaspar Emanuel-maintainer:    kaspar.emanuel@gmail.com+maintainer:    kaspar@monostable.co.uk homepage:      http://github.com/kasbah/haskell-kicad-data bug-reports:   http://github.com/kasbah/haskell-kicad-data/issues-copyright:     2014+copyright:     2018 category:      Data build-type:    Simple--- extra-source-files:+extra-source-files: README.md cabal-version: >=1.10+description:+            Parse and write <http://kicad-pcb.org/ KiCad> data+            (currently @.kicad_mod@ files only).+Extra-Source-Files: changelog.md  source-repository head   type: git@@ -28,14 +32,14 @@     , Data.Kicad.SExpr.SExpr     , Data.Kicad.SExpr.Parse     , Data.Kicad.SExpr.Write-  -- other-modules:+  other-modules:+      Data.Kicad.Util   -- other-extensions:   build-depends:-      base >=4.4 && <4.9-    , parsec >=3.1 && <3.2-    , parsec-numbers >= 0.1.0  && <0.2.0-    , lens-family >= 1.1 && <1.2-    , ieee754 >= 0.7.4 && <0.8+      base >=4.4 && <4.11+    , parsec >=3.1.6 && <3.2+    , lens-family >= 1.1 && <1.3+    , ieee754 >= 0.7.4 && <0.9     , pretty-compact >= 1.0 && < 2   -- hs-source-dirs:   default-language:    Haskell2010@@ -47,15 +51,23 @@   hs-source-dirs: tests   default-language: Haskell2010   main-is: Test.hs+  other-modules:+      PcbnewExpr+      SExpr+      Utils    build-depends:-      base >=4.4 && <4.9+      base >=4.4 && <4.11     , parsec >=3.1 && <3.2-    , parsec-numbers >= 0.1.0  && <0.2.0-    , lens-family >= 1.1 && <1.2-    , ieee754 >= 0.7.4 && <0.8+    , lens-family >= 1.1 && <1.3+    , ieee754 >= 0.7.4 && <0.9     , QuickCheck >= 2+    , HUnit >= 1.5 && < 1.7     , test-framework >= 0.8 && < 1+    , test-framework-quickcheck2 >= 0.3 && < 0.4+    , test-framework-hunit >= 0.3 && < 0.4     , test-framework-quickcheck2 >= 0.3 && < 1     , pretty-compact >= 1.0 && < 2+    , charsetdetect >= 1.1 && < 1.2+    , encoding >= 0.8.2 && < 0.9     , kicad-data

@@ -0,0 +1,218 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module PcbnewExpr+( tests+)+where+import Test.Framework (Test)+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck+import Control.Monad++import Utils+import Data.Kicad.PcbnewExpr+import Data.Kicad.PcbnewExpr.PcbnewExpr++tests :: [Test]+tests = [ testProperty "parse fp_line correctly" parseFpLineCorrectly+        , testProperty "parse fp_arc correctly" parseFpArcCorrectly+        , testProperty "parse fp_poly correctly" parseFpPolyCorrectly+        , testProperty "parse and write any PcbnewExpr" parseAndWriteAnyPcbnewExpr+        , testProperty "parse and pretty any PcbnewExpr" parseAndPrettyAnyPcbnewExpr+        ]++parseFpLineCorrectly :: (Double, Double, Double, Double, Double)+                     -> PcbnewLayerT+                     -> Bool+parseFpLineCorrectly (d1, d2, d3, d4, d5) l =+    tracedPropAEq (parse fp_line) fpLine+    where+        fp_line =+            "(fp_line (start " ++ show d1 ++ " "+             ++ show d2 ++ ") (end " ++ show d3 ++ " "+             ++ show d4 ++ ") (layer "+             ++ layerToStr l+             ++ ") (width " ++ show d5 ++ "))"+        fpLine  = Right $ PcbnewExprItem+                        $ PcbnewFpLine (d1, d2) (d3, d4) l d5++parseFpArcCorrectly :: (Double, Double, Double, Double, Double) -> Double+                     -> PcbnewLayerT+                     -> Bool+parseFpArcCorrectly (d1, d2, d3, d4, d5) d6 l =+    tracedPropAEq (parse fp_arc) fpArc+    where+        fp_arc =+            "(fp_arc (start " ++ show d1 ++ " "+            ++ show d2 ++ ") (end " ++ show d3 ++ " "+            ++ show d4 ++ ") (angle " ++ show d5+            ++ ") (layer " ++ layerToStr l ++ ") (width "+            ++ show d6 ++ "))"+        fpArc = Right $ PcbnewExprItem+                      $ PcbnewFpArc (d1, d2) (d3, d4) d5 l d6++parseFpPolyCorrectly :: [(Double, Double)] -> Double+                     -> PcbnewLayerT+                     -> Bool+parseFpPolyCorrectly ds w l =+    tracedPropAEq (parse fp_poly) fpPoly+    where+        fp_poly =+            "(fp_poly (pts "+            ++ unwords+                (map+                  (\(d1,d2) -> "(xy " ++ show d1 ++ " " ++ show d2 ++ ")")+                    ds)+            ++ ") (layer " ++ layerToStr l ++ ") (width "+            ++ show w ++ "))"+        fpPoly = Right $ PcbnewExprItem $ PcbnewFpPoly ds l w++parseAndWriteAnyPcbnewExpr :: PcbnewExpr -> Bool+parseAndWriteAnyPcbnewExpr a = tracedPropAEq t1 t2+    where t1 = parse $ write a+          t2 = Right a++parseAndPrettyAnyPcbnewExpr :: PcbnewExpr -> Bool+parseAndPrettyAnyPcbnewExpr a = tracedPropAEq t1 t2+    where t1 = parse $ show $ pretty a+          t2 = Right a++instance Arbitrary PcbnewExpr where+    arbitrary = oneof [ do a <- arbitrary+                           return $ PcbnewExprModule a+                      , do a <- arbitrary+                           return $ PcbnewExprItem a+                      , do a <- arbitrary+                           return $ PcbnewExprAttribute a+                      ]++instance Arbitrary PcbnewModule where+    arbitrary = do n <- genSafeString+                   l <- arbitrary+                   attrs <- listOf genModuleAttr+                   items <- arbitrary+                   return $ PcbnewModule n l attrs items+        where+            genModuleAttr :: Gen PcbnewAttribute+            genModuleAttr = suchThat arbitrary not_layer+            not_layer (PcbnewLayer _) = False+            not_layer _ = True++instance Arbitrary PcbnewItem where+    arbitrary = oneof [ do t  <- arbitrary+                           s  <- genSafeString+                           a  <- arbitrary+                           l  <- arbitrary+                           h  <- arbitrary+                           si <- arbitrary+                           th <- arbitrary+                           i  <- arbitrary+                           j  <- arbitrary+                           return $ PcbnewFpText t s a l h si th i j+                      , do s <- arbitrary+                           e <- arbitrary+                           l <- arbitrary+                           w <- arbitrary+                           fp <- elements [PcbnewFpLine, PcbnewFpCircle]+                           return $ fp s e l w+                      , do s <- arbitrary+                           e <- arbitrary+                           a <- arbitrary+                           l <- arbitrary+                           w <- arbitrary+                           return $ PcbnewFpArc s e a l w+                      , do ps <- arbitrary+                           l  <- arbitrary+                           w  <- arbitrary+                           return $ PcbnewFpPoly ps l w+                      , do n  <- genSafeString+                           t  <- arbitrary+                           s  <- arbitrary+                           a  <- arbitrary+                           si <- arbitrary+                           l  <- arbitrary+                           attrs <- listOf genPadAttrs+                           return $ PcbnewPad n t s a si l attrs+                      ]++genPadAttrs :: Gen PcbnewAttribute+genPadAttrs = oneof [ liftM PcbnewRectDelta        arbitrary+                    , liftM PcbnewMaskMargin       arbitrary+                    , liftM PcbnewPasteMarginRatio arbitrary+                    , liftM PcbnewPasteMargin      arbitrary+                    , liftM PcbnewClearance        arbitrary+                    , liftM PcbnewZoneConnect      arbitrary+                    , liftM PcbnewThermalWidth     arbitrary+                    , liftM PcbnewThermalGap       arbitrary+                    , do a <- arbitrary+                         b <- arbitrary+                         return $ PcbnewDrill $ PcbnewDrillT a True b+                    , do a <- suchThatMaybe arbitrary (uncurry (==))+                         b <- arbitrary+                         return $ PcbnewDrill $ PcbnewDrillT a False b+                    ]++instance Arbitrary PcbnewAttribute where+    arbitrary = oneof [ genPadAttrs+                      , oneof [ liftM PcbnewLayer     arbitrary+                              , liftM PcbnewAt        arbitrary+                              , liftM PcbnewSize      arbitrary+                              , liftM PcbnewThickness arbitrary+                              , liftM PcbnewTedit     genSafeString+                              , liftM PcbnewStart     arbitrary+                              , liftM PcbnewEnd       arbitrary+                              , liftM PcbnewCenter    arbitrary+                              , liftM PcbnewWidth     arbitrary+                              , liftM PcbnewDescr     genSafeString+                              , liftM PcbnewTags      genSafeString+                              , liftM PcbnewAttr      genSafeString+                              , liftM PcbnewLayers    arbitrary+                              , liftM PcbnewAngle     arbitrary+                              , liftM PcbnewXy        arbitrary+                              , liftM PcbnewPts       arbitrary+                              , liftM PcbnewXyz       arbitrary+                              , liftM PcbnewZoneConnect  arbitrary+                              , liftM PcbnewThermalGap   arbitrary+                              , liftM PcbnewThermalWidth arbitrary+                              , liftM PcbnewModelScale   arbitrary+                              , liftM PcbnewModelRotate  arbitrary+                              , liftM PcbnewClearance    arbitrary+                              , liftM PcbnewMaskMargin   arbitrary+                              , liftM PcbnewPasteMargin  arbitrary+                              , liftM PcbnewPasteMarginRatio  arbitrary+                              , liftM PcbnewAutoplaceCost90   arbitrary+                              , liftM PcbnewAutoplaceCost180  arbitrary+                              , liftM PcbnewJustify arbitrary+                              , do s <- arbitrary+                                   t <- arbitrary+                                   i <- arbitrary+                                   return $ PcbnewFont s t i+                              , do p <- genSafeString+                                   a <- arbitrary+                                   s <- arbitrary+                                   r <- arbitrary+                                   return $ PcbnewModel p a s r+                             ]+                    ]+++instance Arbitrary PcbnewJustifyT where+    arbitrary = arbitraryBoundedEnum+++instance Arbitrary PcbnewLayerT where+    arbitrary = arbitraryBoundedEnum++instance Arbitrary PcbnewFpTextTypeT where+    arbitrary = arbitraryBoundedEnum++instance Arbitrary PcbnewPadShapeT where+    arbitrary = arbitraryBoundedEnum++instance Arbitrary PcbnewPadTypeT where+    arbitrary = arbitraryBoundedEnum++instance Arbitrary PcbnewAtT where+    arbitrary = do p <- arbitrary+                   o <- arbitrary+                   return $ PcbnewAtT p o+

@@ -0,0 +1,70 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module SExpr+( tests+)+where+import Test.Framework (Test)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.Framework.Providers.HUnit  (testCase)+import Test.HUnit (assertFailure)+import Test.QuickCheck+import Control.Monad (liftM)+import Data.Either (rights)+import Text.Parsec.Pos (newPos)++import Utils++import Data.Kicad.SExpr++tests :: [Test]+tests = [ testProperty "deterministic 1" deterministic1+        , testCase "allows quote marks in unquoted strings" allowQuoteMarks1+        , testCase "allows quote marks in unquoted strings 2" allowQuoteMarks2+        ]+++instance Arbitrary SExpr where+    arbitrary = sized arbitrarySExp+++pos = newPos "" 0 0+-- so we don't create infinitely large s-expressions we keep reducing the size+-- as we go deeper and return atoms when the size is 0+arbitrarySExp :: Int -> Gen SExpr+arbitrarySExp n | n > 0 =+    oneof [ arbitraryAtom+          , liftM (List pos) $ resize (n `div` 2) arbitrary+          ]+arbitrarySExp _ = arbitraryAtom+++arbitraryAtom :: Gen SExpr+arbitraryAtom = liftM (Atom pos) genSafeString+++deterministic1 :: SExpr -> Bool+deterministic1 sx = tracedPropEq t1 t2+        where sx' = List pos [sx]+              t1 = write sx'+              t2 = either id write $ parse t1+++allowQuoteMarks1 :: IO ()+allowQuoteMarks1 =+    let sx = parse "(x\")" in+    if sx /= Right (List (newPos "" 1 1) [Atom (newPos "" 1 2) "x\""])+    then assertFailure ("could not parse quote mark, got: " ++ show sx)+    else return ()+++allowQuoteMarks2 :: IO ()+allowQuoteMarks2 =+    let f = "foo"+        sx = parseWithFilename f "(xxxx\"yyyy yyyy\"xxxx)"+        expected = Right $ List (newPos f 1 1)+            [ Atom (newPos f 1 2)"xxxx\"yyyy"+            , Atom (newPos f 1 12)"yyyy\"xxxx"+            ] :: Either String SExpr+    in if sx /= expected+       then assertFailure ("could not parse quote mark, got: " ++ show sx ++ "\n\texpecting: " ++ (show expected))+       else return ()

@@ -0,0 +1,26 @@+module Utils where+import Data.AEq+import Debug.Trace+import Test.QuickCheck++genSafeString :: Gen String+genSafeString = listOf genSafeChar+    where genSafeChar :: Gen Char+          genSafeChar = elements [' '..'\126']++tracedPropAEq :: (Show a, AEq a) => a -> a -> Bool+tracedPropAEq = tracedProp (~==) "APPROX. EQUAL"++tracedPropEq :: (Show a, Eq a) => a -> a -> Bool+tracedPropEq = tracedProp (==) "EQUAL"++tracedProp :: Show a => (a -> a -> Bool) -> String -> a -> a -> Bool+tracedProp fn s t1 t2 = fn t1 t2 ||+                            trace (    "====================================="+                                     ++ "=====================================\n"+                                     ++ show t1 ++ "\n"+                                     ++ " - DOES NOT " ++ s ++ " -\n"+                                     ++ show t2 ++ "\n"+                                     ++ "====================================="+                                     ++ "====================================="+                                   ) False