diff --git a/lib/Pinchot/Examples/Postal.hs b/lib/Pinchot/Examples/Postal.hs --- a/lib/Pinchot/Examples/Postal.hs +++ b/lib/Pinchot/Examples/Postal.hs @@ -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" diff --git a/lib/Pinchot/Internal.hs b/lib/Pinchot/Internal.hs --- a/lib/Pinchot/Internal.hs +++ b/lib/Pinchot/Internal.hs @@ -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))) |] diff --git a/pinchot.cabal b/pinchot.cabal --- a/pinchot.cabal +++ b/pinchot.cabal @@ -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