diff --git a/Data/Kicad/PcbnewExpr.hs b/Data/Kicad/PcbnewExpr.hs new file mode 100644 --- /dev/null +++ b/Data/Kicad/PcbnewExpr.hs @@ -0,0 +1,15 @@ +module Data.Kicad.PcbnewExpr +( +-- * Types + PcbnewExpr(..) +-- * Parse +, parse +, fromSExpr +-- * Write +, pretty +, write +) +where +import Data.Kicad.PcbnewExpr.PcbnewExpr +import Data.Kicad.PcbnewExpr.Parse +import Data.Kicad.PcbnewExpr.Write diff --git a/Data/Kicad/PcbnewExpr/Parse.hs b/Data/Kicad/PcbnewExpr/Parse.hs new file mode 100644 --- /dev/null +++ b/Data/Kicad/PcbnewExpr/Parse.hs @@ -0,0 +1,389 @@ +module Data.Kicad.PcbnewExpr.Parse +( parse +, fromSExpr +) +where +import Data.Either +import Data.Maybe +import Control.Applicative +import Lens.Family2 (over) + +import Data.Kicad.SExpr hiding (parse) +import qualified Data.Kicad.SExpr as SExpr (parse) +import Data.Kicad.PcbnewExpr.PcbnewExpr + +{-| Parse a 'PcbnewExpr' from a 'String'. Returns an 'String' with an error or + a 'PcbnewExpr'. -} +parse :: String -> Either String PcbnewExpr +parse = either Left fromSExpr . SExpr.parse + +{-| Interpret a 'SExpr' as a 'PcbnewExpr'. -} +fromSExpr :: SExpr -> Either String PcbnewExpr +fromSExpr (List (AtomKey kw:sxs)) = + case go of + Left err -> Left $ "Could not fromSExpr '" ++ 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 + 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 + 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 + 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 +fromSExpr sx@(AtomStr s) = case s of + "italic" -> Right $ PcbnewExprAttribute PcbnewItalic + "hide" -> Right $ PcbnewExprAttribute PcbnewHide + "locked" -> Right $ PcbnewExprAttribute PcbnewLocked + _ -> expecting "'italic' or 'hide' or 'locked' " sx +fromSExpr x = expecting "List with a key or a string atom" x + +asPcbnewModule :: [SExpr] -> Either String PcbnewModule +asPcbnewModule (AtomStr 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) + Right (PcbnewExprAttribute (PcbnewLayer layer)) -> + interpretRest sxs m {pcbnewModuleLayer = layer} + Right (PcbnewExprItem item) -> + interpretRest sxs (over moduleItems (++[item]) m) + Right (PcbnewExprAttribute attr) -> + interpretRest sxs (over moduleAttrs (++[attr]) m) + Right _ -> expecting "layer, items or attributes" sx +asPcbnewModule (x:_) = expecting "module name" x +asPcbnewModule x = expecting' "module name" x + +asPcbnewFpText :: [SExpr] -> Either String PcbnewItem +asPcbnewFpText (t:s:a:xs) = interpretType + where + interpretType = case t of + (AtomStr "reference") -> + interpretString (defaultPcbnewFpText {fpTextType = FpTextReference}) + (AtomStr "value") -> + interpretString (defaultPcbnewFpText {fpTextType = FpTextValue}) + (AtomStr "user") -> + interpretString (defaultPcbnewFpText {fpTextType = FpTextUser}) + _ -> expecting "'reference', 'value' or 'user'" t + interpretString fp_text = case s of + (AtomStr string) -> interpretAt fp_text {fpTextStr = string} + _ -> expecting "string" s + interpretAt fp_text = case fromSExpr a of + Left err -> Left ('\t':err) + Right (PcbnewExprAttribute (PcbnewAt at)) -> + interpretRest xs fp_text {itemAt = at} + _ -> expecting "'at' expression (e.g. '(at 1.0 1.0)')" a + interpretRest [] fp_text = Right fp_text + interpretRest (sx:sxs) fp_text = case fromSExpr sx of + Left err -> Left ('\t':err) + Right (PcbnewExprAttribute (PcbnewLayer layer)) -> + interpretRest sxs (fp_text {itemLayer = layer}) + Right (PcbnewExprAttribute (PcbnewFpTextEffects + (PcbnewFont size thickness italic))) -> + interpretRest sxs (fp_text { itemSize = size + , fpTextThickness = thickness + , fpTextItalic = italic + } + ) + Right (PcbnewExprAttribute PcbnewHide) -> + interpretRest sxs (fp_text {fpTextHide = True}) + _ -> expecting "layer or effects expression or 'hide'" sx +asPcbnewFpText x = expecting' "a text-type, text, 'at' and layer" x + +asFp :: PcbnewItem -> [SExpr] -> Either String PcbnewItem +asFp defaultFp (s:e:xs) = interpretStart defaultFp + where + interpretStart fp_shape = case fromSExpr s of + Left err -> Left ('\t':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) + 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) + Right (PcbnewExprAttribute (PcbnewWidth d)) + -> interpretRest sxs fp_shape {itemWidth = d} + Right (PcbnewExprAttribute (PcbnewLayer d)) + -> interpretRest sxs fp_shape {itemLayer = d} + Right _ -> expecting "width or layer" sx +asFp _ x = expecting' "fp_line (or fp_circle) start (center), end and attributes" x + +asPcbnewFpArc :: [SExpr] -> Either String PcbnewItem +asPcbnewFpArc (s:e:xs) = interpretStart defaultPcbnewFpArc + where + interpretStart fp_arc = case fromSExpr s of + Left err -> Left ('\t':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) + 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) + Right (PcbnewExprAttribute (PcbnewWidth d)) + -> interpretRest sxs fp_arc {itemWidth = d} + Right (PcbnewExprAttribute (PcbnewLayer d)) + -> interpretRest sxs fp_arc {itemLayer = d} + Right (PcbnewExprAttribute (PcbnewAngle d)) + -> interpretRest sxs fp_arc {fpArcAngle = d} + Right _ -> expecting "width, layer or angle" sx +asPcbnewFpArc x = expecting' "fp_arc start, end and attributes" x + +asPcbnewFpPoly :: [SExpr] -> Either String PcbnewItem +asPcbnewFpPoly xs = interpretRest xs defaultPcbnewFpPoly + where + interpretRest [] fp_poly = Right fp_poly + interpretRest (sx:sxs) fp_poly = case fromSExpr sx of + Left err -> Left ('\t':err) + Right (PcbnewExprAttribute (PcbnewPts d)) + -> interpretRest sxs fp_poly {fpPolyPts = d} + Right (PcbnewExprAttribute (PcbnewWidth d)) + -> interpretRest sxs fp_poly {itemWidth = d} + Right (PcbnewExprAttribute (PcbnewLayer d)) + -> interpretRest sxs fp_poly {itemLayer = d} + Right _ -> expecting "width, layer or 'pts'" sx + +asPcbnewPad :: [SExpr] -> Either String PcbnewItem +asPcbnewPad (n:t:s:xs) = interpretNumber + where + interpretNumber = case n of + (AtomStr 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 + 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 + Just d -> interpretRest xs pad {padShape = d} + Nothing -> + expecting "pad shape (e.g. 'circle')" s + _ -> expecting "pad shape string (e.g. 'circle')" s + interpretRest :: [SExpr] -> PcbnewItem -> Either String PcbnewItem + interpretRest [] pad = Right pad + interpretRest (sx:sxs) pad = case fromSExpr sx of + Left err -> Left ('\t':err) + Right (PcbnewExprAttribute (PcbnewAt d)) + -> interpretRest sxs pad {itemAt = d} + Right (PcbnewExprAttribute (PcbnewLayers d)) + -> interpretRest sxs pad {padLayers = d} + Right (PcbnewExprAttribute (PcbnewSize d)) + -> interpretRest sxs pad {itemSize = d} + Right (PcbnewExprAttribute a@(PcbnewDrill _)) + -> pushToAttrs sxs a pad + Right (PcbnewExprAttribute a@(PcbnewRectDelta _)) + -> pushToAttrs sxs a pad + Right (PcbnewExprAttribute a@(PcbnewMaskMargin _)) + -> pushToAttrs sxs a pad + Right (PcbnewExprAttribute a@(PcbnewPasteMarginRatio _)) + -> pushToAttrs sxs a pad + Right (PcbnewExprAttribute a@(PcbnewPasteMargin _)) + -> pushToAttrs sxs a pad + Right (PcbnewExprAttribute a@(PcbnewClearance _)) + -> pushToAttrs sxs a pad + Right (PcbnewExprAttribute a@(PcbnewZoneConnect _)) + -> pushToAttrs sxs a pad + Right (PcbnewExprAttribute a@(PcbnewThermalWidth _)) + -> pushToAttrs sxs a pad + Right (PcbnewExprAttribute a@(PcbnewThermalGap _)) + -> 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 + +asPcbnewLayer :: [SExpr] -> Either String PcbnewAttribute +asPcbnewLayer [sx] = onePcbnewLayer sx +asPcbnewLayer x = expecting' "only one layer name" x + +onePcbnewLayer :: SExpr -> Either String PcbnewAttribute +onePcbnewLayer (AtomStr 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 x = + expecting' "two or three floats or an 'xyz' expression" x + +asPcbnewEffects :: [SExpr] -> Either String PcbnewAttribute +asPcbnewEffects [e@(List _)] = + case fromSExpr e of + Left err -> Left ('\t':err) + Right (PcbnewExprAttribute font@(PcbnewFont {})) + -> Right $ PcbnewFpTextEffects font + _ -> expecting "font-expression" e +asPcbnewEffects x = expecting' "one effects-expression (e.g. font)" x + +asPcbnewFont :: [SExpr] -> Either String PcbnewAttribute +asPcbnewFont xs = interpretRest xs defaultPcbnewFont + where + interpretRest [] font = Right font + interpretRest (sx:sxs) font = case fromSExpr sx of + Left err -> Left ('\t':err) + Right (PcbnewExprAttribute (PcbnewSize size)) -> + interpretRest sxs font {pcbnewFontSize = size} + Right (PcbnewExprAttribute (PcbnewThickness t)) -> + interpretRest sxs font {pcbnewFontThickness = t} + Right (PcbnewExprAttribute PcbnewItalic) -> + interpretRest sxs font {pcbnewFontItalic = True} + 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 _ 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) + 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 _ x = expecting' "string" x + +asPcbnewLayers :: [SExpr] -> Either String PcbnewAttribute +asPcbnewLayers [] = Right $ PcbnewLayers [] +asPcbnewLayers xs = let layers = map onePcbnewLayer xs in case lefts layers of + [] -> Right $ PcbnewLayers $ map (\(PcbnewLayer l) -> l) $ rights layers + _ -> Left $ "Could not fromSExpr layers:\n" + ++ unlines (map ("\t\t"++) (lefts layers)) + +asDouble :: (Double -> PcbnewAttribute) -> [SExpr] -> Either String PcbnewAttribute +asDouble constructor [AtomDbl d] = Right $ constructor d +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 _ x = expecting' "one int (e.g. '1')" x + +asPcbnewDrill :: [SExpr] -> Either String PcbnewAttribute +asPcbnewDrill xs = interpretRest xs defaultPcbnewDrillT + 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) + Right (PcbnewExprAttribute (PcbnewOffset xy)) + -> interpretRest sxs drill {pcbnewDrillOffset = Just xy} + Right _ -> expecting "offset or nothing" sx + _ -> expecting "float, 'oval' or offset" sx + +asPcbnewXyz :: [SExpr] -> Either String PcbnewAttribute +asPcbnewXyz (AtomDbl x:AtomDbl y:[AtomDbl z]) = + Right $ PcbnewXyz (x,y,z) +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) + 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} + where + interpretRest [] model = Right model + interpretRest (sx:sxs) model = case fromSExpr sx of + Left err -> Left ('\t':err) + Right (PcbnewExprAttribute (PcbnewModelAt (PcbnewXyz xyz))) -> + interpretRest sxs model {pcbnewModelAt = xyz} + Right (PcbnewExprAttribute (PcbnewModelScale (PcbnewXyz xyz))) -> + interpretRest sxs model {pcbnewModelScale = xyz} + Right (PcbnewExprAttribute (PcbnewModelRotate (PcbnewXyz xyz))) -> + interpretRest sxs model {pcbnewModelRotate = xyz} + Right _ -> expecting "only at, scale and rotate" sx +asPcbnewModel x = expecting' "model path, at, scale and rotate" x + +expecting :: String -> SExpr -> Either String a +expecting x y = + Left $ "-> Expecting " ++ x ++ " but got " ++ + nothing_or (strip_brackets (write y)) ++ " instead" + where + nothing_or y' = case y' of + "" -> "nothing" + _ -> "'" ++ y' ++ "'" + strip_brackets y' = case head y' of + '(' -> tail . init $ y' + _ -> y' + +expecting' :: String -> [SExpr] -> Either String a +expecting' x y = expecting x $ List y diff --git a/Data/Kicad/PcbnewExpr/PcbnewExpr.hs b/Data/Kicad/PcbnewExpr/PcbnewExpr.hs new file mode 100644 --- /dev/null +++ b/Data/Kicad/PcbnewExpr/PcbnewExpr.hs @@ -0,0 +1,612 @@ +module Data.Kicad.PcbnewExpr.PcbnewExpr +( +-- * Types + PcbnewExpr(..) +, PcbnewModule(..) +, PcbnewItem(..) +, PcbnewAttribute(..) +-- * Attribute types +, PcbnewDrillT(..) +, PcbnewAtT(..) +, PcbnewLayerT(..) +, PcbnewPadShapeT(..) +, PcbnewPadTypeT(..) +, PcbnewFpTextTypeT(..) +, PcbnewXyzT +-- * Lenses and other getters/setters +, moduleItems +, moduleAttrs +, itemLayers +, padAttributes +, atX +, atY +, itemsOn +-- * String conversion +, strToLayer +, layerToStr +, strToPadType +, fpPadTypeToStr +, strToPadShape +, fpPadShapeToStr +, strToFpTextType +, fpTextTypeToStr +-- * Default (empty) instances +, defaultPcbnewModule +, defaultPcbnewFpText +, defaultPcbnewFpLine +, defaultPcbnewFpCircle +, defaultPcbnewFpArc +, defaultPcbnewFpPoly +, defaultPcbnewPad +, defaultPcbnewDrillT +, defaultPcbnewFont +, defaultPcbnewModel +, defaultPcbnewAtT +) +where +import Lens.Family2 +import Data.AEq +import Data.Tuple (swap) +import Data.Maybe +import Data.Foldable (foldMap) + +import Data.Kicad.SExpr.SExpr + +data PcbnewExpr = PcbnewExprModule PcbnewModule + | PcbnewExprItem PcbnewItem + | PcbnewExprAttribute PcbnewAttribute + deriving (Show, Eq) + +instance AEq PcbnewExpr where + PcbnewExprModule x ~== PcbnewExprModule y = x ~== y + PcbnewExprItem x ~== PcbnewExprItem y = x ~== y + PcbnewExprAttribute x ~== PcbnewExprAttribute y = x ~== y + _ ~== _ = False + +instance SExpressable PcbnewExpr where + toSExpr (PcbnewExprModule x) = toSExpr x + toSExpr (PcbnewExprItem x) = toSExpr x + toSExpr (PcbnewExprAttribute x) = toSExpr x + +data PcbnewModule = PcbnewModule { pcbnewModuleName :: String + , pcbnewModuleLayer :: PcbnewLayerT + , pcbnewModuleAttrs :: [PcbnewAttribute] + , pcbnewModuleItems :: [PcbnewItem] + } + deriving (Show, Eq) + +instance SExpressable PcbnewModule where + toSExpr (PcbnewModule name l attrs items) = + List $ [ AtomKey KeyModule + , AtomStr name + , toSExpr (PcbnewLayer l) + ] ++ map toSExpr attrs + ++ map toSExpr items + +defaultPcbnewModule :: PcbnewModule +defaultPcbnewModule = PcbnewModule "" FCu [] [] + +moduleItems :: Functor f => LensLike' f PcbnewModule [PcbnewItem] +moduleItems f (PcbnewModule n l a i) = PcbnewModule n l a `fmap` f i + +moduleAttrs :: Functor f => LensLike' f PcbnewModule [PcbnewAttribute] +moduleAttrs f (PcbnewModule n l a i) = (\a' -> PcbnewModule n l a' i) `fmap` f a + +instance AEq PcbnewModule where + PcbnewModule n1 l1 as1 is1 ~== PcbnewModule n2 l2 as2 is2 = + n1 == n2 + && l1 == l2 + && as1 ~== as2 + && is1 ~== is2 + +data PcbnewItem = PcbnewFpText { fpTextType :: PcbnewFpTextTypeT + , fpTextStr :: String + , itemAt :: PcbnewAtT + , itemLayer :: PcbnewLayerT + , fpTextHide :: Bool + , itemSize :: (Double, Double) + , fpTextThickness :: Double + , fpTextItalic :: Bool + } + | PcbnewFpLine { itemStart :: (Double, Double) + , itemEnd :: (Double, Double) + , itemLayer :: PcbnewLayerT + , itemWidth :: Double + } + | PcbnewFpCircle { itemStart :: (Double, Double) + , itemEnd :: (Double, Double) + , itemLayer :: PcbnewLayerT + , itemWidth :: Double + } + | PcbnewFpArc { itemStart :: (Double, Double) + , itemEnd :: (Double, Double) + , fpArcAngle :: Double + , itemLayer :: PcbnewLayerT + , itemWidth :: Double + } + | PcbnewFpPoly { fpPolyPts :: [(Double, Double)] + , itemLayer :: PcbnewLayerT + , itemWidth :: Double + } + | PcbnewPad { padNumber :: String + , padType :: PcbnewPadTypeT + , padShape :: PcbnewPadShapeT + , itemAt :: PcbnewAtT + , itemSize :: (Double, Double) + , padLayers :: [PcbnewLayerT] + , padAttributes_ :: [PcbnewAttribute] + } + deriving (Show, Eq) + +instance SExpressable PcbnewItem where + toSExpr (PcbnewFpText t s a l h si th i) = + List $ [ AtomKey KeyFpText + , AtomStr $ fpTextTypeToStr t + , AtomStr s + , toSExpr (PcbnewAt a) + , toSExpr (PcbnewLayer l) + ] ++ [AtomStr "hide" | h] ++ + [toSExpr $ PcbnewFpTextEffects $ PcbnewFont si th i] + toSExpr (PcbnewFpLine s e l w) = + List [ AtomKey KeyFpLine + , toSExpr (PcbnewStart s) + , toSExpr (PcbnewEnd e) + , toSExpr (PcbnewLayer l) + , toSExpr (PcbnewWidth w) + ] + toSExpr (PcbnewFpCircle s e l w) = + List [ AtomKey KeyFpCircle + , toSExpr (PcbnewStart s) + , toSExpr (PcbnewEnd e) + , toSExpr (PcbnewLayer l) + , toSExpr (PcbnewWidth w) + ] + toSExpr (PcbnewFpArc s e a l w) = + List [ AtomKey KeyFpArc + , toSExpr (PcbnewStart s) + , toSExpr (PcbnewEnd e) + , toSExpr (PcbnewAngle a) + , toSExpr (PcbnewLayer l) + , toSExpr (PcbnewWidth w) + ] + toSExpr (PcbnewFpPoly ps l w) = + List [ AtomKey KeyFpPoly + , 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 + , toSExpr $ PcbnewAt a + , toSExpr $ PcbnewSize si + , toSExpr $ PcbnewLayers l + ] ++ map toSExpr attrs + +itemLayers :: Functor f => LensLike' f PcbnewItem [PcbnewLayerT] +itemLayers f item@(PcbnewPad { }) = + (\ls -> item {padLayers = ls}) `fmap` f (padLayers item) +itemLayers f item = update `fmap` f [itemLayer item] + where update [] = item + update ls = item {itemLayer = head ls} + +padAttributes :: Functor f => LensLike' f PcbnewItem [PcbnewAttribute] +padAttributes f i = (\as -> i {padAttributes_ = as}) `fmap` f (padAttributes_ i) + +instance AEq PcbnewItem where + (PcbnewFpText t1 s1 a1 l1 h1 si1 th1 i1) ~== (PcbnewFpText t2 s2 a2 l2 h2 si2 th2 i2) = + t1 == t2 + && s1 == s2 + && a1 ~== a2 + && l1 == l2 + && h1 == h2 + && si1 ~== si2 + && th1 ~== th2 + && i1 == i2 + (PcbnewFpLine s1 e1 l1 w1) ~== (PcbnewFpLine s2 e2 l2 w2) = + s1 ~== s2 + && e1 ~== e2 + && l1 == l2 + && w1 ~== w2 + (PcbnewFpCircle s1 e1 l1 w1) ~== (PcbnewFpCircle s2 e2 l2 w2) = + s1 ~== s2 + && e1 ~== e2 + && l1 == l2 + && w1 ~== w2 + (PcbnewFpArc s1 e1 a1 l1 w1) ~== (PcbnewFpArc s2 e2 a2 l2 w2) = + s1 ~== s2 + && e1 ~== e2 + && a1 ~== a2 + && l1 == l2 + && w1 ~== w2 + (PcbnewFpPoly ps1 l1 w1) ~== (PcbnewFpPoly ps2 l2 w2) = + ps1 ~== ps2 + && l1 == l2 + && w1 ~== w2 + (PcbnewPad n1 t1 s1 a1 si1 l1 attrs1) + ~== (PcbnewPad n2 t2 s2 a2 si2 l2 attrs2) = + n1 == n2 + && t1 == t2 + && s1 == s2 + && a1 ~== a2 + && si1 ~== si2 + && l1 == l2 + && attrs1 ~== attrs2 + x ~== y = x == y + +defaultPcbnewFpText :: PcbnewItem +defaultPcbnewFpText = PcbnewFpText { fpTextType = FpTextUser + , fpTextStr = "" + , itemAt = defaultPcbnewAtT + , itemLayer = FSilkS + , fpTextHide = False + , itemSize = (1.0, 1.0) + , fpTextThickness = 1.0 + , fpTextItalic = False + } + +defaultPcbnewFpLine :: PcbnewItem +defaultPcbnewFpLine = PcbnewFpLine { itemStart = (0,0) + , itemEnd = (0,0) + , itemLayer = FSilkS + , itemWidth = 0.15 + } + +defaultPcbnewFpCircle :: PcbnewItem +defaultPcbnewFpCircle = PcbnewFpCircle { itemStart = (0,0) + , itemEnd = (0,0) + , itemLayer = FSilkS + , itemWidth = 0.15 + } +defaultPcbnewFpArc :: PcbnewItem +defaultPcbnewFpArc = PcbnewFpArc { itemStart = (0,0) + , itemEnd = (0,0) + , fpArcAngle = 0 + , itemLayer = FSilkS + , itemWidth = 0.15 + } + +defaultPcbnewFpPoly :: PcbnewItem +defaultPcbnewFpPoly = PcbnewFpPoly { fpPolyPts = [] + , itemLayer = FSilkS + , itemWidth = 0.15 + } + +defaultPcbnewPad :: PcbnewItem +defaultPcbnewPad = PcbnewPad { padNumber = "" + , padType = ThruHole + , padShape = Circle + , itemAt = defaultPcbnewAtT + , itemSize = (0,0) + , padLayers = [] + , padAttributes_ = [] + } + +data PcbnewDrillT = PcbnewDrillT { pcbnewDrillSize :: Maybe (Double, Double) + , pcbnewDrillOval :: Bool + , pcbnewDrillOffset :: Maybe (Double, Double) + } + deriving (Show, Eq) + +defaultPcbnewDrillT :: PcbnewDrillT +defaultPcbnewDrillT = PcbnewDrillT Nothing False Nothing + +instance AEq PcbnewDrillT where + PcbnewDrillT s1 o1 off1 ~== PcbnewDrillT s2 o2 off2 + = s1 ~== s2 && o1 == o2 && off1 ~== off2 + +data PcbnewAttribute = PcbnewLayer PcbnewLayerT + | PcbnewAt PcbnewAtT + | PcbnewFpTextType PcbnewFpTextTypeT + | PcbnewSize (Double, Double) + | PcbnewThickness Double + | PcbnewTedit String + | PcbnewItalic + | PcbnewHide + | PcbnewLocked + | PcbnewStart (Double, Double) + | PcbnewEnd (Double, Double) + | PcbnewWidth Double + | PcbnewDescr String + | PcbnewTags String + | PcbnewAttr String + | PcbnewLayers [PcbnewLayerT] + | PcbnewDrill PcbnewDrillT + | PcbnewRectDelta (Double, Double) + | PcbnewFpTextEffects PcbnewAttribute + | PcbnewFont { pcbnewFontSize :: (Double, Double) + , pcbnewFontThickness :: Double + , pcbnewFontItalic :: Bool + } + | PcbnewAngle Double + | PcbnewXy (Double, Double) + | PcbnewPts [(Double, Double)] + | PcbnewModel { pcbnewModelPath :: String + , pcbnewModelAt :: PcbnewXyzT + , pcbnewModelScale :: PcbnewXyzT + , pcbnewModelRotate :: PcbnewXyzT + } + | PcbnewModelAt PcbnewAttribute + | PcbnewModelScale PcbnewAttribute + | PcbnewModelRotate PcbnewAttribute + | PcbnewXyz PcbnewXyzT + | PcbnewCenter (Double, Double) + | PcbnewClearance Double + | PcbnewMaskMargin Double + | PcbnewPasteMargin Double + | PcbnewPasteMarginRatio Double + | PcbnewOffset (Double, Double) + | PcbnewAutoplaceCost90 Int + | PcbnewAutoplaceCost180 Int + | PcbnewZoneConnect Int + | PcbnewThermalWidth Double + | PcbnewThermalGap Double + deriving (Show, Eq) + +type PcbnewXyzT = (Double, Double, Double) + +instance SExpressable PcbnewAttribute where + toSExpr (PcbnewLayer l) = List [ AtomKey KeyLayer + , AtomStr $ layerToStr l + ] + toSExpr (PcbnewAt (PcbnewAtT (x,y) o)) = + List $ [ AtomKey KeyAt + , AtomDbl x + , AtomDbl y + ] ++ [AtomDbl o | o /= 0] + toSExpr (PcbnewLayers ls) = + List (AtomKey KeyLayers : map (AtomStr . layerToStr) ls) + toSExpr (PcbnewFont s t i) = + List $ [ AtomKey KeyFont, toSExpr (PcbnewSize s) + , toSExpr (PcbnewThickness t) + ] ++ [AtomStr "italic" | i] + toSExpr (PcbnewPts xys) = + List $ AtomKey KeyPts : map (toSExpr . PcbnewXy) xys + toSExpr (PcbnewModel p a s r) = + List [AtomKey KeyModel + , AtomStr 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] + ++ (if o && 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 a) = List [AtomKey KeyEffects, toSExpr a] + 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 (PcbnewMaskMargin d) = toSxD KeySolderMaskMargin d + toSExpr (PcbnewPasteMargin d) = toSxD KeySolderPasteMargin d + toSExpr (PcbnewPasteMarginRatio d) = toSxD KeySolderPasteMarginRatio 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 (PcbnewAttr s) = toSxStr KeyAttr s + toSExpr PcbnewItalic = AtomStr "italic" + toSExpr PcbnewHide = AtomStr "hide" + 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) + +toSxD :: Keyword -> Double -> SExpr +toSxD kw d = List [AtomKey kw, AtomDbl d] + +toSxDD :: Keyword -> (Double, Double) -> SExpr +toSxDD kw (x,y) = List [AtomKey kw, AtomDbl x, AtomDbl y] + +toSxStr :: Keyword -> String -> SExpr +toSxStr kw s = List [AtomKey kw, AtomStr s] + +instance AEq PcbnewAttribute where + (PcbnewAt x) ~== (PcbnewAt y) = x ~== y + (PcbnewSize x) ~== (PcbnewSize y) = x ~== y + (PcbnewCenter x) ~== (PcbnewCenter y) = x ~== y + (PcbnewThickness x) ~== (PcbnewThickness y) = x ~== y + (PcbnewStart x) ~== (PcbnewStart y) = x ~== y + (PcbnewEnd x) ~== (PcbnewEnd y) = x ~== y + (PcbnewWidth x) ~== (PcbnewWidth y) = x ~== y + (PcbnewDrill x) ~== (PcbnewDrill y) = x ~== y + (PcbnewRectDelta x) ~== (PcbnewRectDelta y) = x ~== y + (PcbnewAngle x) ~== (PcbnewAngle y) = x ~== y + (PcbnewXy x) ~== (PcbnewXy y) = x ~== y + (PcbnewPts x) ~== (PcbnewPts y) = x ~== y + (PcbnewXyz x) ~== (PcbnewXyz y) = x ~== y + (PcbnewOffset x) ~== (PcbnewOffset y) = x ~== y + (PcbnewClearance x) ~== (PcbnewClearance y) = x ~== y + (PcbnewMaskMargin x) ~== (PcbnewMaskMargin y) = x ~== y + (PcbnewPasteMargin x) ~== (PcbnewPasteMargin y) = x ~== y + (PcbnewPasteMarginRatio x) ~== (PcbnewPasteMarginRatio y) = x ~== y + (PcbnewThermalWidth x) ~== (PcbnewThermalWidth y) = x ~== y + (PcbnewThermalGap x) ~== (PcbnewThermalGap y) = x ~== y + (PcbnewModelAt x) ~== (PcbnewModelAt y) = x ~== y + (PcbnewModelScale x) ~== (PcbnewModelScale y) = x ~== y + (PcbnewModelRotate x) ~== (PcbnewModelRotate y) = x ~== y + (PcbnewModel p1 a1 s1 r1) ~== (PcbnewModel p2 a2 s2 r2) = + p1 == p2 && a1 ~== a2 && s1 ~== s2 && r1 ~== r2 + (PcbnewFont s1 t1 i1) ~== (PcbnewFont s2 t2 i2) = + s1 ~== s2 && t1 ~== t2 && i1 == i2 + x ~== y = x == y + +defaultPcbnewFont :: PcbnewAttribute +defaultPcbnewFont = PcbnewFont { pcbnewFontSize = (1.0, 1.0) + , pcbnewFontThickness = 1.0 + , pcbnewFontItalic = False + } + +defaultPcbnewModel :: PcbnewAttribute +defaultPcbnewModel = PcbnewModel { pcbnewModelPath = "" + , pcbnewModelAt = (0,0,0) + , pcbnewModelScale = (0,0,0) + , pcbnewModelRotate = (0,0,0) + } + +data PcbnewLayerT = FSilkS | FCu | FPaste | FMask | BSilkS + | BCu | BPaste | BMask | DwgsUser | CmtsUser + | FAdhes | AllSilk | FandBCu | AllCu | AllMask + | EdgeCuts | FCrtYd | BCrtYd + | Inner1Cu | Inner2Cu | Inner3Cu | Inner4Cu | Inner5Cu + | Inner6Cu | Inner7Cu | Inner8Cu | Inner9Cu | Inner10Cu + | Inner11Cu | Inner12Cu | Inner13Cu | Inner14Cu | Inner15Cu + | Inner16Cu | Inner17Cu | Inner18Cu | Inner19Cu | Inner20Cu + | Inner21Cu | Inner22Cu | Inner23Cu | Inner24Cu | Inner25Cu + | Inner26Cu | Inner27Cu | Inner28Cu | Inner29Cu | Inner30Cu + | Inner31Cu | Inner32Cu + deriving (Show, Eq, Enum, Bounded) + +strToLayerMap :: [(String, PcbnewLayerT)] +strToLayerMap = + [ ("F.SilkS" , FSilkS ) + , ("F.Cu" , FCu ) + , ("F.Paste" , FPaste ) + , ("F.Mask" , FMask ) + , ("B.SilkS" , BSilkS ) + , ("B.Cu" , BCu ) + , ("B.Paste" , BPaste ) + , ("B.Mask" , BMask ) + , ("Dwgs.User" , DwgsUser) + , ("Cmts.User" , CmtsUser) + , ("F.Adhes" , FAdhes) + , ("F&B.Cu" , FandBCu) + , ("*.Cu" , AllCu ) + , ("*.Mask" , AllMask) + , ("*.SilkS" , AllSilk) + , ("F.CrtYd" , FCrtYd) + , ("B.CrtYd" , BCrtYd) + , ("Edge.Cuts" , EdgeCuts) + , ("Inner1.Cu" , Inner1Cu) + , ("Inner2.Cu" , Inner2Cu) + , ("Inner3.Cu" , Inner3Cu) + , ("Inner4.Cu" , Inner4Cu) + , ("Inner5.Cu" , Inner5Cu) + , ("Inner6.Cu" , Inner6Cu) + , ("Inner7.Cu" , Inner7Cu) + , ("Inner8.Cu" , Inner8Cu) + , ("Inner9.Cu" , Inner9Cu) + , ("Inner10.Cu", Inner10Cu) + , ("Inner11.Cu", Inner11Cu) + , ("Inner12.Cu", Inner12Cu) + , ("Inner13.Cu", Inner13Cu) + , ("Inner14.Cu", Inner14Cu) + , ("Inner15.Cu", Inner15Cu) + , ("Inner16.Cu", Inner16Cu) + , ("Inner17.Cu", Inner17Cu) + , ("Inner18.Cu", Inner18Cu) + , ("Inner19.Cu", Inner19Cu) + , ("Inner20.Cu", Inner20Cu) + , ("Inner21.Cu", Inner21Cu) + , ("Inner22.Cu", Inner22Cu) + , ("Inner23.Cu", Inner23Cu) + , ("Inner24.Cu", Inner24Cu) + , ("Inner25.Cu", Inner25Cu) + , ("Inner26.Cu", Inner26Cu) + , ("Inner27.Cu", Inner27Cu) + , ("Inner28.Cu", Inner28Cu) + , ("Inner29.Cu", Inner29Cu) + , ("Inner30.Cu", Inner30Cu) + , ("Inner31.Cu", Inner31Cu) + , ("Inner32.Cu", Inner32Cu) + ] + +strToLayer :: String -> Maybe PcbnewLayerT +strToLayer s = lookup s strToLayerMap + +layerToStr :: PcbnewLayerT -> String +layerToStr l = fromMaybe "" $ lookup l $ map swap strToLayerMap + +itemsOn :: [PcbnewLayerT] -> [PcbnewItem] -> [PcbnewItem] +itemsOn = foldMap itemsOn' + where itemsOn' :: PcbnewLayerT -> [PcbnewItem] -> [PcbnewItem] + itemsOn' layer = filter ((layer `elem`) . view itemLayers) + +data PcbnewPadTypeT = ThruHole | SMD | Connect | NPThruHole + deriving (Show, Eq, Enum, Bounded) + +strToPadTypeMap :: [(String, PcbnewPadTypeT)] +strToPadTypeMap = + [ ("smd" , SMD) + , ("thru_hole" , ThruHole) + , ("connect" , Connect) + , ("np_thru_hole" , NPThruHole) + ] + +strToPadType :: String -> Maybe PcbnewPadTypeT +strToPadType s = lookup s strToPadTypeMap + +fpPadTypeToStr :: PcbnewPadTypeT -> String +fpPadTypeToStr t = fromMaybe "" $ lookup t $ map swap strToPadTypeMap + +data PcbnewPadShapeT = Circle | Oval | Rect | Trapezoid + deriving (Show, Eq, Enum, Bounded) + +strToPadShapeMap :: [(String, PcbnewPadShapeT)] +strToPadShapeMap = [ ("circle" , Circle) + , ("oval" , Oval) + , ("rect" , Rect) + , ("trapezoid", Trapezoid) + ] + +strToPadShape :: String -> Maybe PcbnewPadShapeT +strToPadShape s = lookup s strToPadShapeMap + +fpPadShapeToStr :: PcbnewPadShapeT -> String +fpPadShapeToStr t = fromMaybe "" $ lookup t $ map swap strToPadShapeMap + +data PcbnewAtT = PcbnewAtT { pcbnewAtPoint :: (Double, Double) + , pcbnewAtOrientation :: Double + } + deriving (Show, Eq) + +instance AEq PcbnewAtT where + (PcbnewAtT p1 o1) ~== (PcbnewAtT p2 o2) = p1 ~== p2 && o1 ~== o2 + +defaultPcbnewAtT :: PcbnewAtT +defaultPcbnewAtT = PcbnewAtT { pcbnewAtPoint = (0,0) + , pcbnewAtOrientation = 0 + } + +atX :: Functor f => LensLike' f PcbnewAtT Double +atX f (PcbnewAtT (x,y) o) = (\x' -> PcbnewAtT (x',y) o) `fmap` f x + +atY :: Functor f => LensLike' f PcbnewAtT Double +atY f (PcbnewAtT (x,y) o) = (\y' -> PcbnewAtT (x,y') o) `fmap` f y + +data PcbnewFpTextTypeT = FpTextReference | FpTextValue | FpTextUser + deriving (Show, Eq, Enum, Bounded) + + +strToFpTextTypeMap :: [(String, PcbnewFpTextTypeT)] +strToFpTextTypeMap = + [ ("reference", FpTextReference) + , ("value" , FpTextValue) + , ("user" , FpTextUser) + ] + +strToFpTextType :: String -> Maybe PcbnewFpTextTypeT +strToFpTextType s = lookup s strToFpTextTypeMap + +fpTextTypeToStr :: PcbnewFpTextTypeT -> String +fpTextTypeToStr t = fromMaybe "" $ lookup t $ map swap strToFpTextTypeMap diff --git a/Data/Kicad/PcbnewExpr/Write.hs b/Data/Kicad/PcbnewExpr/Write.hs new file mode 100644 --- /dev/null +++ b/Data/Kicad/PcbnewExpr/Write.hs @@ -0,0 +1,19 @@ +module Data.Kicad.PcbnewExpr.Write +( + pretty +, write +) +where +import Text.PrettyPrint.Compact + +import Data.Kicad.PcbnewExpr.PcbnewExpr +import qualified Data.Kicad.SExpr as SExpr + +{-| Pretty-print a 'PcbnewExpr' as a readable s-expression 'Doc'.-} +pretty :: PcbnewExpr -> Doc +pretty = SExpr.pretty . SExpr.toSExpr + +{-| Serialize a 'PcbnewExpr' as a compact s-expression 'String'. -} +write :: PcbnewExpr -> String +write = SExpr.write . SExpr.toSExpr + diff --git a/Data/Kicad/SExpr.hs b/Data/Kicad/SExpr.hs new file mode 100644 --- /dev/null +++ b/Data/Kicad/SExpr.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +module Data.Kicad.SExpr +( +-- * Types + SExpr(..) +, Keyword(..) +, SExpressable(..) +-- * Writing +, pretty +, write +, writeKeyword +-- * Parsing +, parse +) +where +import Data.Kicad.SExpr.SExpr +import Data.Kicad.SExpr.Write +import Data.Kicad.SExpr.Parse diff --git a/Data/Kicad/SExpr/Parse.hs b/Data/Kicad/SExpr/Parse.hs new file mode 100644 --- /dev/null +++ b/Data/Kicad/SExpr/Parse.hs @@ -0,0 +1,93 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} +module Data.Kicad.SExpr.Parse +( parse +) +where +import Text.ParserCombinators.Parsec hiding (spaces, parse) +import qualified Text.ParserCombinators.Parsec as Parsec (parse) +import Text.ParserCombinators.Parsec.Number +import Control.Monad + +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 parseList "SExpr" input of + Left err -> Left $ "Parse Error: " ++ show err + Right val -> Right val + +parseList :: Parser SExpr +parseList = do + 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 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 + char ')' + spaces + return $ List (first:rest) + +parseAtom :: Parser SExpr +parseAtom = try parseDouble + <|> try parseString + <|> try parseList + "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") + +parseDouble :: Parser SExpr +parseDouble = do + negate_or_id <- sign + -- the Bool in floating3 is requireDigit which affects whether many (False) + -- or many1 (True) is used + x <- floating3 True + lookAhead (char ')' <|> spaceChar) + return $ AtomDbl $ negate_or_id x + +spaces1 = skipMany1 spaceChar +spaces = skipMany spaceChar +spaceChar = newline <|> space diff --git a/Data/Kicad/SExpr/SExpr.hs b/Data/Kicad/SExpr/SExpr.hs new file mode 100644 --- /dev/null +++ b/Data/Kicad/SExpr/SExpr.hs @@ -0,0 +1,62 @@ +module Data.Kicad.SExpr.SExpr +( SExpr(..) +, Keyword(..) +, SExpressable(..) +) +where + +data SExpr = AtomKey Keyword + | AtomStr String + | AtomDbl Double + | List [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 + | KeyRotate + | KeyRectDelta + | KeyPts + | KeyPad + | KeyOffset + | KeyModule + | KeyModel + | KeyLayers + | KeyLayer + | KeyFpText + | KeyFpPoly + | KeyFpLine + | KeyFpCircle + | KeyFpArc + | KeyFont + | KeyEnd + | KeyEffects + | KeyDrill + | KeyDescr + | KeyClearance + | KeyCenter + | KeyAutoplaceCost90 + | KeyAutoplaceCost180 + | KeyAttr + | KeyAt + | KeyAngle + deriving (Show, Eq, Enum, Bounded) + +class SExpressable a where + toSExpr :: a -> SExpr diff --git a/Data/Kicad/SExpr/Write.hs b/Data/Kicad/SExpr/Write.hs new file mode 100644 --- /dev/null +++ b/Data/Kicad/SExpr/Write.hs @@ -0,0 +1,45 @@ +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 :: SExpr -> Doc +pretty (List xs) = text "(" <> align (sep $ map pretty xs) <> text ")" +pretty atm = text $ write atm + + +{-| Serialize an SExpr as a compact s-expression '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 + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2014 Kaspar Emanuel + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/kicad-data.cabal b/kicad-data.cabal new file mode 100644 --- /dev/null +++ b/kicad-data.cabal @@ -0,0 +1,61 @@ +name: kicad-data +version: 0.1.0.0 +synopsis: Parser and writer for KiCad files. +license: MIT +license-file: LICENSE +author: Kaspar Emanuel +maintainer: kaspar.emanuel@gmail.com +homepage: http://github.com/kasbah/haskell-kicad-data +bug-reports: http://github.com/kasbah/haskell-kicad-data/issues +copyright: 2014 +category: Data +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +source-repository head + type: git + location: git@github.com:kasbah/haskell-kicad-data + +library + ghc-options: -Wall + exposed-modules: + Data.Kicad.PcbnewExpr + , Data.Kicad.PcbnewExpr.PcbnewExpr + , Data.Kicad.PcbnewExpr.Parse + , Data.Kicad.PcbnewExpr.Write + , Data.Kicad.SExpr + , Data.Kicad.SExpr.SExpr + , Data.Kicad.SExpr.Parse + , Data.Kicad.SExpr.Write + -- other-modules: + -- other-extensions: + build-depends: + base >=4.6 && <4.8 + , 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 + , pretty-compact >= 1.0 && < 2 + -- hs-source-dirs: + default-language: Haskell2010 + +test-suite kicad-data-quickcheck + type: exitcode-stdio-1.0 + x-uses-tf: true + ghc-options: -Wall -fno-warn-unused-do-bind + hs-source-dirs: tests + default-language: Haskell2010 + main-is: Test.hs + + build-depends: + base >= 4 && < 5 + , 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 + , QuickCheck >= 2 + , test-framework >= 0.8 && < 1 + , test-framework-quickcheck2 >= 0.3 && < 1 + , pretty-compact >= 1.0 && < 2 + , kicad-data diff --git a/tests/Test.hs b/tests/Test.hs new file mode 100644 --- /dev/null +++ b/tests/Test.hs @@ -0,0 +1,9 @@ +import Test.Framework (defaultMain, testGroup) + +import qualified SExpr +import qualified PcbnewExpr + +main :: IO () +main = defaultMain [ testGroup "SExpr" SExpr.tests + , testGroup "PcbnewExpr" PcbnewExpr.tests + ]