diff --git a/Data/Kicad/PcbnewExpr.hs b/Data/Kicad/PcbnewExpr.hs --- a/Data/Kicad/PcbnewExpr.hs +++ b/Data/Kicad/PcbnewExpr.hs @@ -4,6 +4,7 @@ PcbnewExpr(..) -- * Parse , parse +, parseWithFilename , fromSExpr -- * Write , pretty diff --git a/Data/Kicad/PcbnewExpr/Parse.hs b/Data/Kicad/PcbnewExpr/Parse.hs --- a/Data/Kicad/PcbnewExpr/Parse.hs +++ b/Data/Kicad/PcbnewExpr/Parse.hs @@ -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 diff --git a/Data/Kicad/PcbnewExpr/PcbnewExpr.hs b/Data/Kicad/PcbnewExpr/PcbnewExpr.hs --- a/Data/Kicad/PcbnewExpr/PcbnewExpr.hs +++ b/Data/Kicad/PcbnewExpr/PcbnewExpr.hs @@ -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) diff --git a/Data/Kicad/SExpr.hs b/Data/Kicad/SExpr.hs --- a/Data/Kicad/SExpr.hs +++ b/Data/Kicad/SExpr.hs @@ -4,14 +4,14 @@ ( -- * Types SExpr(..) -, Keyword(..) , SExpressable(..) -- * Writing , pretty , write -, writeKeyword -- * Parsing , parse +, parseWithFilename +, getPos ) where import Data.Kicad.SExpr.SExpr diff --git a/Data/Kicad/SExpr/Parse.hs b/Data/Kicad/SExpr/Parse.hs --- a/Data/Kicad/SExpr/Parse.hs +++ b/Data/Kicad/SExpr/Parse.hs @@ -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 " diff --git a/Data/Kicad/SExpr/SExpr.hs b/Data/Kicad/SExpr/SExpr.hs --- a/Data/Kicad/SExpr/SExpr.hs +++ b/Data/Kicad/SExpr/SExpr.hs @@ -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 diff --git a/Data/Kicad/SExpr/Write.hs b/Data/Kicad/SExpr/Write.hs --- a/Data/Kicad/SExpr/Write.hs +++ b/Data/Kicad/SExpr/Write.hs @@ -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) ++ ")" diff --git a/Data/Kicad/Util.hs b/Data/Kicad/Util.hs new file mode 100644 --- /dev/null +++ b/Data/Kicad/Util.hs @@ -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 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -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) diff --git a/kicad-data.cabal b/kicad-data.cabal --- a/kicad-data.cabal +++ b/kicad-data.cabal @@ -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 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 diff --git a/tests/PcbnewExpr.hs b/tests/PcbnewExpr.hs new file mode 100644 --- /dev/null +++ b/tests/PcbnewExpr.hs @@ -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 + diff --git a/tests/SExpr.hs b/tests/SExpr.hs new file mode 100644 --- /dev/null +++ b/tests/SExpr.hs @@ -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 () diff --git a/tests/Utils.hs b/tests/Utils.hs new file mode 100644 --- /dev/null +++ b/tests/Utils.hs @@ -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