pinchot 0.6.0.0 → 0.8.0.0
raw patch · 3 files changed
+186/−95 lines, 3 files
Files
- lib/Pinchot/Examples/Postal.hs +6/−14
- lib/Pinchot/Internal.hs +178/−79
- pinchot.cabal +2/−2
lib/Pinchot/Examples/Postal.hs view
@@ -20,16 +20,12 @@ south <- terminal "South" (solo 'S') east <- terminal "East" (solo 'E') west <- terminal "West" (solo 'W')- direction <- nonTerminal "Direction"- [ ("DNorth", [north]), ("DSouth", [south]), ("DEast", [east])- , ("DWest", [west])]+ direction <- union "Direction" [north, south, east, west] street <- terminalSeq "Street" ['S', 't'] avenue <- terminalSeq "Avenue" ['A', 'v', 'e'] way <- terminalSeq "Way" ['W', 'a', 'y'] boulevard <- terminalSeq "Boulevard" ['B', 'l', 'v', 'd']- suffix <- nonTerminal "Suffix"- [ ("SStreet", [street]), ("SAvenue", [avenue]), ("SWay", [way])- , ("SBoulevard", [boulevard])]+ suffix <- union "Suffix" [street, avenue, way, boulevard] space <- terminal "Space" (solo ' ') comma <- terminal "Comma" (solo ',') @@ -42,21 +38,17 @@ -- Named "PostalWord" to avoid clash with Prelude.Word word <- record "PostalWord" [letter, letters]- preSpacedWord <- nonTerminal "PreSpacedWord"- [("PreSpacedWord", [space, word])]+ preSpacedWord <- record "PreSpacedWord" [space, word] preSpacedWords <- list "PreSpacedWords" preSpacedWord- words <- nonTerminal "Words"- [("Words", [word, preSpacedWords])]+ words <- record "Words" [word, preSpacedWords] number <- wrap "Number" digits streetName <- wrap "StreetName" words city <- wrap "City" words state <- wrap "State" word zipCode <- wrap "ZipCode" digits- directionSpace <- nonTerminal "DirectionSpace"- [("DirectionSpace", [direction, space])]- spaceSuffix <- nonTerminal "SpaceSuffix"- [("SpaceSuffix", [space, suffix])]+ directionSpace <- record "DirectionSpace" [direction, space]+ spaceSuffix <- record "SpaceSuffix" [space, suffix] optDirection <- option "MaybeDirection" directionSpace optSuffix <- option "MaybeSuffix" spaceSuffix address <- record "Address"
lib/Pinchot/Internal.hs view
@@ -29,16 +29,15 @@ import Language.Haskell.TH (ExpQ, ConQ, normalC, mkName, strictType, notStrict, newtypeD, cxt, conT, Name, dataD, appT, DecsQ, appE, Q, Stmt(NoBindS), uInfixE, bindS,- varE, varP, conE, Pat, Exp(AppE, DoE), lamE, recC, varStrictType)+ varE, varP, conE, Pat, Exp(AppE, DoE), lamE, recC, varStrictType, dyn) import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Syntax as Syntax import Text.Earley (satisfy, rule, symbol) import qualified Text.Earley ((<?>)) --- | Type synonym for the name of a production rule. --- This will be the name of the type constructor for the corresponding--- type in the AST, so this must be a valid Haskell type constructor--- name.+-- | Type synonym for the name of a production rule. This will be the+-- name of the type constructor for the corresponding type that will+-- be created, so this must be a valid Haskell type constructor name. -- -- If you are creating a 'terminal', 'option', 'list', 'list1', or -- 'wrap', the 'RuleName' will also be used for the name of the single@@ -61,6 +60,7 @@ data RuleType t = RTerminal (Intervals t) | RBranch (Branch t, Seq (Branch t))+ | RUnion (Rule t, Seq (Rule t)) | RSeqTerm (Seq t) | ROptional (Rule t) | RList (Rule t)@@ -135,7 +135,7 @@ -- defined, just as you can in a set of @let@ bindings. newtype Pinchot t a- = Pinchot { runPinchot :: (ExceptT Error (State (Names t)) a) }+ = Pinchot { runPinchot :: ExceptT Error (State (Names t)) a } deriving (Functor, Applicative, Monad, MonadFix) addRuleName@@ -153,7 +153,7 @@ throw = throwE $ InvalidName name addDataConName- :: String+ :: AlternativeName -> Pinchot t () addDataConName name = Pinchot $ do old@(Names _ dcNames _ _) <- lift get@@ -242,6 +242,9 @@ RBranch (b1, bs) -> branchName b1 <| fmap branchName bs where branchName (Branch x _) = x+ RUnion (b1, bs) -> branchName b1 <| fmap branchName bs+ where+ branchName (Rule x _ _) = unionBranchName n x RSeqTerm _ -> Seq.singleton n ROptional _ -> Seq.singleton n RList _ -> Seq.singleton n@@ -249,25 +252,47 @@ RWrap _ -> Seq.singleton n RRecord _ -> Seq.singleton n +unionBranchName+ :: RuleName+ -- ^ Name of the parent rule+ -> RuleName+ -- ^ Name of the branch rule+ -> AlternativeName+unionBranchName p b = p ++ '\'' : b+ addDataConNames :: Rule t -> Pinchot t () addDataConNames = mapM_ addDataConName . ruleConstructorNames --- | Creates a new non-terminal production rule where--- each alternative produces only one rule.+-- | Creates a new non-terminal production rule where each alternative+-- produces only one rule. The constructor name for each alternative+-- is+--+-- @RULE_NAME'PRODUCTION_NAME@+--+-- where @RULE_NAME@ is the name of the rule itself, and+-- @PRODUCTION_NAME@ is the rule name for what is being produced. For+-- an example, see 'Pinchot.Examples.PostalAstAllRules.Suffix'.+--+-- Currently there is no way to change the names of the constructors;+-- however, you can use 'nonTerminal', which is more flexible. union :: RuleName- -> Seq (AlternativeName, Rule t)+ -> Seq (Rule t)+ -- ^ List of alternatives. There must be at least one alternative;+ -- otherwise a compile-time error will occur. -> Pinchot t (Rule t)-union name = nonTerminal name . fmap (\(n, r) -> (n, Seq.singleton r))+union name sq = Pinchot $ case viewl sq of+ EmptyL -> throwE $ EmptyNonTerminal name+ x :< xs -> runPinchot $ newRule name (RUnion (x, xs)) -- | Creates a new non-terminal production rule with only one -- alternative where each field has a record name. The name of each -- record is: ----- @_f\'RULE_NAME\'INDEX\'FIELD_TYPE@+-- @_r\'RULE_NAME\'INDEX\'FIELD_TYPE@ ----- where RULE_NAME is the name of this rule, INDEX is the index number--- for this field (starting with 0), and FIELD_TYPE is the type of the+-- where @RULE_NAME@ is the name of this rule, @INDEX@ is the index number+-- for this field (starting with 0), and @FIELD_TYPE@ is the type of the -- field itself. For an example, see -- 'Pinchot.Examples.PostalAstAllRules.Address'. --@@ -338,6 +363,10 @@ as1 <- branchAncestors b1 ass <- fmap join . mapM branchAncestors $ bs return $ r <| as1 <> ass+ RUnion (b1, bs) -> do+ c1 <- getAncestors b1+ cs <- fmap join . mapM getAncestors $ bs+ return $ r <| c1 <> cs RSeqTerm _ -> return (Seq.singleton r) ROptional c -> do cs <- getAncestors c@@ -376,6 +405,7 @@ RBranch (b1, bs) -> foldr checkBranch (checkBranch b1 results) bs where checkBranch (Branch _ rls) rslts = foldr checkRule rslts rls+ RUnion (b1, bs) -> foldr checkRule (checkRule b1 results) bs RSeqTerm _ -> results ROptional r -> checkRule r results RList r -> addHelper $ checkRule r results@@ -395,6 +425,16 @@ mkField (Rule n _ _) = strictType notStrict (conT (mkName n)) fields = toList . fmap mkField $ rules +thUnionBranch+ :: RuleName+ -- ^ Parent rule name+ -> Rule t+ -- ^ Child rule+ -> ConQ+thUnionBranch parent (Rule child _ _) = normalC name fields+ where+ name = mkName (unionBranchName parent child)+ fields = [strictType notStrict (conT (mkName child))] thRule :: Syntax.Lift t@@ -410,7 +450,8 @@ ty <- makeType typeName derives nm ruleType lenses <- if doLenses then ruleToOptics typeName nm ruleType else return []- return (ty : productionInstance typeName nm ruleType : lenses)+ inst <- productionInstance typeName nm ruleType+ return (ty : inst : lenses) makeType@@ -432,6 +473,10 @@ where cons = thBranch b1 : toList (fmap thBranch bs) + RUnion (b1, bs) -> dataD (cxt []) name [] cons derives+ where+ cons = thUnionBranch nm b1 : toList (fmap (thUnionBranch nm) bs)+ RSeqTerm _ -> newtypeD (cxt []) name [] cons derives where cons = normalC name@@ -482,7 +527,7 @@ -> String -- ^ Inner type name -> String-fieldName idx par inn = "f'" ++ par ++ "'" ++ show idx ++ "'" ++ inn+fieldName idx par inn = "r'" ++ par ++ "'" ++ show idx ++ "'" ++ inn thAllRules :: Syntax.Lift t@@ -532,6 +577,10 @@ `TH.AppE` (TH.VarE local) lambPat = TH.VarP local +-- | TH helper like 'dyn' but for patterns+dynP :: String -> TH.PatQ+dynP = TH.varP . TH.mkName+ seqTermToOptics :: Syntax.Lift t => Name@@ -558,6 +607,11 @@ in Lens.prism fetch store |] +-- | Creates a prism for a terminal type. Although a newtype wraps+-- each terminal, do not make a Wrapped or an Iso, because the+-- relationship between the outer type and the type that it wraps+-- typically is not isometric. Thus, use a Prism instead, which+-- captures this relationship properly. terminalToOptics :: Syntax.Lift t => Name@@ -643,7 +697,7 @@ -> Branch t -> Seq (Branch t) -> [TH.Dec]-branchesToOptics nm b1 bsSeq = concat $ makePrism b1 : toList (fmap makePrism bs)+branchesToOptics nm b1 bsSeq = concat $ makePrism b1 : fmap makePrism bs where bs = toList bsSeq makePrism (Branch inner rulesSeq) = [ signature, binding ]@@ -718,6 +772,36 @@ $ TH.ConE ('Left) `TH.AppE` TH.VarE (TH.mkName "_z") +unionToOptics+ :: String+ -- ^ Rule name+ -> Rule t+ -- ^ First rule+ -> Seq (Rule t)+ -- ^ Remaining rules+ -> TH.DecsQ+unionToOptics parentName r1 rs+ = fmap concat . sequence $ optics r1 : fmap optics (toList rs)+ where+ optics (Rule r _ _) = sequence $ sig : prism : []+ where+ sig = TH.sigD prismName [t| Lens.Prism' $bigType $innerType |]+ prismName = TH.mkName $ "_" ++ parentName ++ "'" ++ r+ bigType = TH.conT (TH.mkName parentName)+ innerType = TH.conT (TH.mkName r)+ prism = TH.valD (TH.varP prismName)+ (TH.normalB [| Lens.prism $dataCtor $sToA |] ) []+ sToA = TH.lamE [pat] expn+ where+ pat = dynP "_x"+ expn = TH.caseE (dyn "_x")+ [ TH.match (TH.conP (TH.mkName (unionBranchName parentName r))+ [TH.varP (TH.mkName "_a")])+ (TH.normalB [| Right $(dyn "_a") |]) []+ , TH.match (dynP "_b")+ (TH.normalB [| Left $(dyn "_b") |]) []+ ]+ dataCtor = TH.conE (TH.mkName (unionBranchName parentName r)) recordsToOptics :: String@@ -767,6 +851,7 @@ ruleToOptics terminalName nm ty = case ty of RTerminal ivl -> terminalToOptics terminalName nm ivl RBranch (b1, bs) -> return $ branchesToOptics nm b1 bs+ RUnion (r1, rs) -> unionToOptics nm r1 rs RSeqTerm sq -> seqTermToOptics terminalName nm sq ROptional (Rule inner _ _) -> return [optionalToOptics inner nm] RList (Rule inner _ _) -> return [manyToOptics inner nm]@@ -884,7 +969,13 @@ (ei, _) = runState (runExceptT (runPinchot pinchot)) (Names Set.empty Set.empty 0 M.empty) -+addPrefix+ :: String+ -> String+ -> String+addPrefix pfx suf+ | null pfx = suf+ | otherwise = pfx ++ '.':suf ruleToParser :: Syntax.Lift t@@ -909,6 +1000,16 @@ addBranch tree branch = [| $tree <|> $(branchToParser prefix branch) |] + RUnion (Rule r1 _ _, rs) -> fmap (:[]) (makeRule expression)+ where+ expression = foldl adder start rs+ where+ branch r = [| $(conE (mkName+ (addPrefix prefix . unionBranchName nm $ r))) <$>+ $(varE (ruleName r)) |]+ start = branch r1+ adder soFar (Rule r _ _) = [| $soFar <|> $(branch r) |]+ RSeqTerm sq -> do let nestRule = bindS (varP helper) [| rule $(foldl addTerm start sq) |] where@@ -987,10 +1088,10 @@ | otherwise = pfx ++ "." ruleName :: String -> Name-ruleName suffix = mkName ("_r'" ++ suffix)+ruleName suffix = mkName ("_rule'" ++ suffix) helperName :: String -> Name-helperName suffix = mkName ("_h'" ++ suffix)+helperName suffix = mkName ("_helper'" ++ suffix) branchToParser :: Syntax.Lift t@@ -1089,105 +1190,103 @@ terminals :: a -> Seq (Terminal a) -- | Creates a 'Production' instance for a 'Rule'.- productionInstance :: Name -- ^ Terminal type -> String -- ^ Rule name -> RuleType t- -> TH.Dec-productionInstance term n t = TH.InstanceD [] ty ds+ -> TH.DecQ+productionInstance term n t = TH.instanceD (return []) ty ds where- ty = TH.ConT ''Production `TH.AppT` (TH.ConT (TH.mkName n))- ds = [syn, TH.FunD 'terminals clauses]+ ty = [t| Production $(TH.conT (TH.mkName n)) |]+ ds = [syn, TH.funD 'terminals clauses] where- syn = TH.TySynInstD ''Terminal- $ TH.TySynEqn [TH.ConT (TH.mkName n)] (TH.ConT term)+ syn = TH.tySynInstD ''Terminal+ $ TH.tySynEqn [ TH.conT (TH.mkName n) ] (TH.conT term) clauses = case t of- RTerminal _ -> [TH.Clause [pat] bdy []]+ RTerminal _ -> [TH.clause [pat] bdy []] where- pat = TH.ConP (TH.mkName n) [TH.VarP (TH.mkName "_x")]- bdy = TH.NormalB (TH.VarE 'Seq.singleton- `TH.AppE` TH.VarE (TH.mkName "_x"))+ pat = TH.conP (TH.mkName n) [TH.varP (TH.mkName "_x")]+ bdy = TH.normalB [| Seq.singleton $(TH.varE (TH.mkName "_x")) |]+ RBranch (b1, bs) -> branchToClause b1 : fmap branchToClause (toList bs) - RSeqTerm _ -> [TH.Clause [pat] bdy []]+ RSeqTerm _ -> [TH.clause [pat] bdy []] where- pat = TH.ConP (TH.mkName n) [TH.VarP (TH.mkName "_x")]- bdy = TH.NormalB (TH.VarE (TH.mkName "_x"))+ pat = TH.conP (TH.mkName n) [TH.varP (TH.mkName "_x")]+ bdy = TH.normalB (dyn "_x") ROptional _ -> [justClause, nothingClause] where justClause- = TH.Clause [TH.ConP (TH.mkName n)- [TH.ConP 'Just [TH.VarP (TH.mkName "_x")]]]- (TH.NormalB (TH.VarE 'terminals- `TH.AppE` (TH.VarE (TH.mkName "_x"))))+ = TH.clause [TH.conP (TH.mkName n)+ [TH.conP 'Just [TH.varP (TH.mkName "_b")]]]+ (TH.normalB [| terminals $(TH.varE (TH.mkName "_b")) |]) [] nothingClause- = TH.Clause [TH.ConP (TH.mkName n)- [TH.ConP 'Nothing []]]- (TH.NormalB (TH.VarE 'Seq.empty)) []+ = TH.clause [TH.conP (TH.mkName n)+ [TH.conP 'Nothing []]]+ (TH.normalB [| Seq.empty |]) [] - RList _ -> [TH.Clause [pat] bdy []]+ RList _ -> [TH.clause [pat] bdy []] where- pat = TH.ConP (TH.mkName n) [TH.VarP (TH.mkName "_x")] - bdy = (TH.NormalB (TH.VarE 'join- `TH.AppE` ((TH.VarE 'fmap) `TH.AppE` (TH.VarE 'terminals)- `TH.AppE` (TH.VarE (TH.mkName "_x")))))+ pat = TH.conP (TH.mkName n) [TH.varP (TH.mkName "_a")] + bdy = TH.normalB [| join+ $ fmap terminals $(TH.varE (TH.mkName "_a")) |] - RList1 _ -> [TH.Clause [pat] bdy []]+ RList1 _ -> [TH.clause [pat] bdy []] where- pat = TH.ConP (TH.mkName n)- [TH.TupP [ TH.VarP (TH.mkName "_x1")- , TH.VarP (TH.mkName "_xs")]]- bdy = TH.NormalB (TH.UInfixE lft mpnd rst)+ pat = TH.conP (TH.mkName n)+ [TH.tupP [ dynP "_x1", dynP "_xs" ]]+ bdy = TH.normalB+ [| $lft `mappend` (join (fmap terminals+ $(dyn "_xs"))) |] where- lft = TH.VarE 'terminals `TH.AppE` TH.VarE (TH.mkName "_x1")- mpnd = TH.VarE 'mappend- rst = TH.VarE 'join `TH.AppE` nested- where- nested = TH.VarE 'fmap `TH.AppE` TH.VarE 'terminals- `TH.AppE` TH.VarE (TH.mkName "_xs")+ lft = [| terminals $(dyn "_x1") |] - RWrap _ -> [TH.Clause [pat] bdy []]+ RWrap _ -> [TH.clause [pat] bdy []] where- pat = TH.ConP (TH.mkName n) [TH.VarP (TH.mkName "_x")]- bdy = TH.NormalB (TH.VarE 'terminals `TH.AppE`- TH.VarE (TH.mkName "_x"))+ pat = TH.conP (TH.mkName n) [dynP "_x"]+ bdy = TH.normalB [| terminals $(dyn "_x") |] - RRecord sq -> [TH.Clause [pat] (TH.NormalB bdy) []]+ RRecord sq -> [TH.clause [pat] (TH.normalB bdy) []] where- pat = TH.ConP (TH.mkName n) . fmap mkPat+ pat = TH.conP (TH.mkName n) . fmap mkPat . take (Seq.length sq) $ [0 :: Int ..] where- mkPat idx = TH.VarP (TH.mkName ("_x" ++ show idx))- bdy = foldr addField (TH.VarE 'Seq.empty)+ mkPat idx = dynP ("_x" ++ show idx)+ bdy = foldr addField [| Seq.empty |] . take (Seq.length sq) $ [0 :: Int ..] where- addField idx acc = TH.UInfixE this cons acc+ addField idx acc = [| $this `mappend` $acc |] where- this = TH.VarE 'terminals `TH.AppE` TH.VarE- (TH.mkName ("_x" ++ show idx))- cons = TH.VarE 'mappend+ this = [| terminals $(dyn ("_x" ++ show idx)) |] -branchToClause :: Branch t -> TH.Clause-branchToClause (Branch n rs) = TH.Clause [pat] bdy []+ RUnion (r1, rs) -> mkClause r1 : fmap mkClause (toList rs)+ where+ mkClause (Rule inner _ _) = TH.clause [pat] bdy []+ where+ pat = TH.conP (TH.mkName (unionBranchName n inner))+ [dynP "_x"]+ bdy = TH.normalB [| terminals $(dyn "_x") |]+++branchToClause :: Branch t -> TH.ClauseQ+branchToClause (Branch n rs) = TH.clause [pat] bdy [] where- pat = TH.ConP (TH.mkName n) fields+ pat = TH.conP (TH.mkName n) fields where fields = fmap mkField . take (Seq.length rs) $ [0 :: Int ..] where- mkField idx = TH.VarP (TH.mkName ("_x" ++ show idx))- bdy = TH.NormalB (TH.VarE 'join `TH.AppE` sq)+ mkField idx = TH.varP (TH.mkName ("_x" ++ show idx))+ bdy = TH.normalB [| join $sq |] where- sq = foldr addField (TH.VarE 'Seq.empty)+ sq = foldr addField (TH.varE 'Seq.empty) . take (Seq.length rs) $ [0 :: Int ..] where- addField idx acc = TH.UInfixE newTerm cons acc+ addField idx acc = [| $newTerm <| $acc |] where- newTerm = (TH.VarE 'terminals)- `TH.AppE` (TH.VarE (TH.mkName ("_x" ++ show idx)))- cons = TH.VarE '(<|)+ newTerm = [| terminals $(TH.varE+ (TH.mkName ("_x" ++ show idx))) |]
pinchot.cabal view
@@ -3,11 +3,11 @@ -- http://www.github.com/massysett/cartel -- -- Script name used to generate: genCabal.hs--- Generated on: 2015-12-16 22:57:48.137493 EST+-- Generated on: 2016-01-26 10:23:38.93759 EST -- Cartel library version: 0.14.2.8 name: pinchot-version: 0.6.0.0+version: 0.8.0.0 cabal-version: >= 1.14 license: BSD3 license-file: LICENSE