diff --git a/exe/parakeet.hs b/exe/parakeet.hs new file mode 100644 --- /dev/null +++ b/exe/parakeet.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedLists #-} + +-- | Like @parrot@ but uses +-- 'Pinchot.Examples.EarleyProduct.addressParser'. +-- +-- Reads the string given as the first argument. Parses it and +-- then, for each parse result, uses 'terminals' to print the +-- terminals. Each result output should be the same as the input. +module Main where + +import Data.Foldable (toList) +import Pinchot +import Pinchot.Examples.Postal +import Pinchot.Examples.EarleyProduct +import Pinchot.Examples.PostalAstAllRules +import System.Environment (getArgs) + +import Text.Earley (parser, fullParses) + +main :: IO () +main = do + a1:[] <- getArgs + let (ls, _) = fullParses (parser addressParser) a1 + printSeq = putStrLn . toList . t'Address + mapM_ printSeq ls diff --git a/exe/parrot.hs b/exe/parrot.hs --- a/exe/parrot.hs +++ b/exe/parrot.hs @@ -1,15 +1,15 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE TemplateHaskell #-} --- | Reads the string given as the first argument. Parses it and --- then, for each parse result, uses 'terminals' to print the +-- Reads the string given as the first argument. Parses it and +-- then, for each parse result, uses 't'Address' to print the -- terminals. Each result output should be the same as the input. module Main where -import Data.Foldable (toList) import Pinchot +import Data.Foldable (toList) import Pinchot.Examples.Postal +import Pinchot.Examples.EarleyProduct import System.Environment (getArgs) import Text.Earley (parser, fullParses) @@ -19,6 +19,6 @@ main :: IO () main = do a1:[] <- getArgs - let (ls, _) = fullParses (parser $(earleyGrammar "" postal)) a1 - printSeq = putStrLn . toList . terminals + let (ls, _) = fullParses (parser $(earleyGrammar "" postal)) a1 + printSeq = putStrLn . toList . t'Address mapM_ printSeq ls diff --git a/lib/Pinchot.hs b/lib/Pinchot.hs --- a/lib/Pinchot.hs +++ b/lib/Pinchot.hs @@ -63,13 +63,19 @@ , () -- * Transforming a Pinchot value to code + -- ** Creating data types , MakeOptics , makeOptics , noOptics , allRulesToTypes , ruleTreeToTypes + , allRulesRecord + + -- ** Creating Earley grammars + , Qualifier , earleyGrammar , allEarleyGrammars + , earleyProduct ) where import Pinchot.Internal diff --git a/lib/Pinchot/Examples.hs b/lib/Pinchot/Examples.hs --- a/lib/Pinchot/Examples.hs +++ b/lib/Pinchot/Examples.hs @@ -17,6 +17,10 @@ -- "Pinchot.Examples.AllEarleyGrammars" shows you how to use -- 'allEarleyGrammars'. -- +-- "Pinchot.Examples.AllRulesRecord" and +-- "Pinchot.Examples.EarleyProduct" show you how to use +-- 'allRulesRecord' and 'earleyProduct'. +-- -- Three executables are included in the @pinchot@ package. To get -- them, compile @pinchot@ with the @executables@ Cabal flag. -- diff --git a/lib/Pinchot/Examples/AllEarleyGrammars.hs b/lib/Pinchot/Examples/AllEarleyGrammars.hs --- a/lib/Pinchot/Examples/AllEarleyGrammars.hs +++ b/lib/Pinchot/Examples/AllEarleyGrammars.hs @@ -5,8 +5,8 @@ module Pinchot.Examples.AllEarleyGrammars where -import Pinchot -import Pinchot.Examples.Postal -import Pinchot.Examples.PostalAstAllRules +import qualified Pinchot +import qualified Pinchot.Examples.Postal as Postal +import qualified Pinchot.Examples.PostalAstAllRules as PostalAstAllRules -allEarleyGrammars "" postal +Pinchot.allEarleyGrammars "PostalAstAllRules" ''Char Postal.postal diff --git a/lib/Pinchot/Examples/AllRulesRecord.hs b/lib/Pinchot/Examples/AllRulesRecord.hs new file mode 100644 --- /dev/null +++ b/lib/Pinchot/Examples/AllRulesRecord.hs @@ -0,0 +1,12 @@ +-- | Provides an example of the use of 'Pinchot.allRulesRecord'. +-- You will want to look at the source code to see how to write the +-- Template Haskell splice. + +{-# LANGUAGE TemplateHaskell #-} +module Pinchot.Examples.AllRulesRecord where + +import qualified Pinchot +import qualified Pinchot.Examples.Postal as Postal +import qualified Pinchot.Examples.PostalAstAllRules as AllRules + +Pinchot.allRulesRecord "AllRules" ''Char Postal.postal diff --git a/lib/Pinchot/Examples/EarleyProduct.hs b/lib/Pinchot/Examples/EarleyProduct.hs new file mode 100644 --- /dev/null +++ b/lib/Pinchot/Examples/EarleyProduct.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Provides an example of the use of 'Pinchot.earleyProduct'. You +-- will want to look at the source code, as looking at only the +-- Haddocks will show you only the result of all the Template +-- Haskell splices. +module Pinchot.Examples.EarleyProduct where + +import qualified Pinchot + +-- You will need to import your Pinchot grammar +import qualified Pinchot.Examples.Postal as Postal + +-- And import the types that result from applying +-- 'Pinchot.allRulesToTypes' to the Pinchot grammar +import qualified Pinchot.Examples.PostalAstAllRules as AllRules + +-- And, import the product type that results from applying +-- 'Pinchot.allRulesRecord' to your grammar +import qualified Pinchot.Examples.AllRulesRecord as Record + +import qualified Text.Earley as Earley + +-- | 'Pinchot.earleyProduct' gives you a big product type that has +-- every rule that is in your Pinchot grammar. +allProductions :: Earley.Grammar r (Record.Productions r) +allProductions = $(Pinchot.earleyProduct "AllRules" "Record" Postal.postal) + +-- | To get the exact production you're interested in, just use +-- 'fmap'. Then you can use this value for 'Earley.parser'. +addressParser :: Earley.Grammar r (Earley.Prod r String Char AllRules.Address) +addressParser = fmap Record.a'Address allProductions diff --git a/lib/Pinchot/Internal.hs b/lib/Pinchot/Internal.hs --- a/lib/Pinchot/Internal.hs +++ b/lib/Pinchot/Internal.hs @@ -28,12 +28,12 @@ import Data.Typeable (Typeable) import Language.Haskell.TH (ExpQ, ConQ, normalC, mkName, strictType, notStrict, newtypeD, - cxt, conT, Name, dataD, appT, DecsQ, appE, Q, uInfixE, bindS, - varE, varP, conE, Pat, Exp, lamE, recC, varStrictType, dyn) + cxt, conT, Name, dataD, appT, DecsQ, appE, Q, uInfixE, + varE, varP, conE, Pat, Exp, 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 (()) +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 that will @@ -138,6 +138,16 @@ = Pinchot { runPinchot :: ExceptT Error (State (Names t)) a } deriving (Functor, Applicative, Monad, MonadFix) +-- | Runs a 'Pinchot' with a starting empty state. Fails in the Q +-- monad if the grammar is bad. +goPinchot :: Pinchot t a -> Q (Names t, a) +goPinchot (Pinchot pinc) = case fst pair of + Left err -> fail $ "pinchot: bad grammar: " ++ show err + Right g -> return (snd pair, g) + where + pair = runState (runExceptT pinc) + (Names Set.empty Set.empty 0 M.empty) + addRuleName :: RuleName -> Pinchot t () @@ -457,8 +467,8 @@ ty <- makeType typeName derives nm ruleType lenses <- if doLenses then ruleToOptics typeName nm ruleType else return [] - inst <- productionDecl nm ruleType - return (ty : inst : lenses) + inst <- productionDecl nm typeName ruleType + return (ty : inst ++ lenses) makeType @@ -951,12 +961,9 @@ -- ^ The return value from the 'Pinchot' is ignored. -> DecsQ -allRulesToTypes doOptics typeName derives pinchot = case ei of - Left err -> fail $ "pinchot: bad grammar: " ++ show err - Right _ -> thAllRules doOptics typeName derives (allRules st') - where - (ei, st') = runState (runExceptT (runPinchot pinchot)) - (Names Set.empty Set.empty 0 M.empty) +allRulesToTypes doOptics typeName derives pinchot = do + st' <- fmap fst $ goPinchot pinchot + thAllRules doOptics typeName derives (allRules st') -- | Creates data types only for the 'Rule' returned from the 'Pinchot', and -- for its ancestors. @@ -980,15 +987,13 @@ -- ^ A data type is created for the 'Rule' that the 'Pinchot' -- returns, and for the ancestors of the 'Rule'. -> DecsQ -ruleTreeToTypes doOptics typeName derives pinchot = case ei of - Left err -> fail $ "pinchot: bad grammar: " ++ show err - Right r -> fmap join . sequence . toList +ruleTreeToTypes doOptics typeName derives pinchot = do + r <- fmap snd $ goPinchot pinchot + fmap join . sequence . toList . fmap (thRule doOptics typeName derives) . runCalc . getAncestors $ r where - runCalc stateCalc = fst $ runState stateCalc (Set.empty) - (ei, _) = runState (runExceptT (runPinchot pinchot)) - (Names Set.empty Set.empty 0 M.empty) + runCalc stateCalc = fst $ runState stateCalc Set.empty addPrefix :: String @@ -1003,7 +1008,7 @@ => String -- ^ Module prefix -> Rule t - -> [TH.StmtQ] + -> [(Name, ExpQ)] ruleToParser prefix (Rule nm mayDescription rt) = case rt of RTerminal ivls -> [makeRule expression] @@ -1029,7 +1034,7 @@ RSeqTerm sq -> [nestRule, topRule] where - nestRule = bindS (varP helper) [| rule $(foldl addTerm start sq) |] + nestRule = (helper, [| rule $(foldl addTerm start sq) |]) where start = [|pure Seq.empty|] addTerm acc x = [| liftA2 (<|) (symbol x) $acc |] @@ -1043,7 +1048,7 @@ RList (Rule innerNm _ _) -> [nestRule, makeRule (wrapper helper)] where - nestRule = bindS (varP helper) ([|rule|] `appE` parseSeq) + nestRule = (helper, ([|rule|] `appE` parseSeq)) where parseSeq = uInfixE [|pure Seq.empty|] [|(<|>)|] pSeq where @@ -1051,7 +1056,7 @@ RList1 (Rule innerNm _ _) -> [nestRule, makeRule topExpn] where - nestRule = bindS (varP helper) [|rule $(parseSeq)|] + nestRule = (helper, [|rule $(parseSeq)|]) where parseSeq = [| pure Seq.empty <|> $pSeq |] where @@ -1077,8 +1082,8 @@ where - makeRule expression = varP (ruleName nm) `bindS` - [|rule ($expression Text.Earley. $(textToExp desc))|] + makeRule expression = (ruleName nm, + [|rule ($expression Text.Earley. $(textToExp desc))|]) desc = maybe nm id mayDescription textToExp txt = [| $(Syntax.lift txt) |] constructor = constructorName prefix nm @@ -1119,9 +1124,23 @@ f soFar (Rule rule2 _ _) = [| $soFar <*> $(varE (ruleName rule2)) |] where constructor = constructorName prefix name + +-- # lazyPattern and bigTuple - because TH has no support for +-- mdo notation -- | Creates a lazy pattern for all the given names. Adds an empty --- pattern onto the front. +-- pattern onto the front. This is the counterpart of 'bigTuple'. +-- All of the given names are bound. In addition, a single, +-- wildcard pattern is bound to the front. +-- +-- For example, @lazyPattern (map mkName ["x", "y", "z"])@ gives a +-- pattern that looks like +-- +-- @~(_, (x, (y, (z, ()))))@ +-- +-- The idea is that the named patterns are needed so that the +-- recursive @do@ notation works, and that the wildcard pattern is +-- the return value, which is not needed here. lazyPattern :: Foldable c => c Name @@ -1131,15 +1150,21 @@ gen name rest = [p| ($(varP name), $rest) |] finish pat = [p| ~(_, $pat) |] +-- | Creates a big tuple. It is nested in the second element, such +-- as (1, (2, (3, (4, ())))). Thus, the big tuple is terminated +-- with a unit value. It resembles a list where each tuple is a +-- cons cell and the terminator is unit. bigTuple :: Foldable c - => Name - -> c Name + => ExpQ + -- ^ This expression will be the first one in the tuple. + -> c ExpQ + -- ^ Remaining expressions in the tuple. -> ExpQ bigTuple top = finish . foldr f [| () |] where - f n rest = [| ( $(varE n), $rest) |] - finish tup = [| ($(varE top), $tup) |] + f n rest = [| ( $(n), $rest) |] + finish tup = [| ($(top), $tup) |] -- | Creates an Earley grammar for a given 'Rule'. For examples of how -- to use this, see the source code for @@ -1149,35 +1174,16 @@ earleyGrammar :: Syntax.Lift t - => String - -- ^ Module prefix. You have to make sure that the data types you - -- created with 'ruleTreeToTypes' or with 'allRulesToTypes' are in - -- scope, either because they were spliced into the same module that - -- 'earleyParser' is spliced into, or because they are @import@ed - -- into scope. The spliced Template Haskell code has to know where - -- to look for these data types. If you did an unqualified @import@ - -- or if the types are in the same module as is the splice of - -- 'earleyParser', just pass the empty string here. If you did a - -- qualified import, pass the appropriate namespace here. - -- - -- For example, if you used @import qualified MyAst@, pass - -- @\"MyAst\"@ here. If you used @import qualified - -- Data.MyLibrary.MyAst as MyLibrary.MyAst@, pass - -- @\"MyLibrary.MyAst\"@ here. - -- - -- For an example where the types are in the same module, see - -- "Pinchot.Examples.PostalAstRuleTree" or - -- "Pinchot.Examples.PostalAstAllRules". - -- - -- For an example using a qualified import, see - -- "Pinchot.Examples.QualifiedImport". + => Qualifier + -- ^ Qualifier for data types crated with 'ruleTreeToTypes' or + -- 'allRulesToTypes' -> Pinchot t (Rule t) -- ^ Creates an Earley parser for the 'Rule' that the 'Pinchot' -- returns. -> Q Exp - -- ^ When spliced, this expression has type + -- ^ When spliced, this expression has type -- @'Text.Earley.Grammar' r ('Text.Earley.Prod' r 'String' t a)@ -- -- where @@ -1187,12 +1193,38 @@ -- @t@ is the type of the token (usually 'Char') -- -- @a@ is the type defined by the 'Rule'. -earleyGrammar prefix pinc = case ei of - Left err -> fail $ "pinchot: bad grammar: " ++ show err - Right r -> earleyGrammarFromRule prefix r +earleyGrammar prefix pinc = do + r <- fmap snd $ goPinchot pinc + earleyGrammarFromRule prefix r + +-- | Builds a recursive @do@ expression (because TH has no support +-- for @mdo@ notation). +recursiveDo + :: [(Name, ExpQ)] + -- ^ Binding statements + -> ExpQ + -- ^ Final return value from @do@ block. The type of this 'ExpQ' + -- must be in the same monad as the @do@ block; it must not be a + -- pure value. + -> ExpQ + -- ^ Returns an expression whose value is the final return value + -- from the @do@ block. +recursiveDo binds final = [| fmap fst $ mfix $(fn) |] where - (ei, _) = runState (runExceptT (runPinchot pinc)) - (Names Set.empty Set.empty 0 M.empty) + fn = [| \ $(lazyPattern (fmap fst binds)) -> $doBlock |] + doBlock = TH.doE (bindStmts ++ returnStmts) + bindStmts = map mkBind binds + where + mkBind (name, exp) + = TH.bindS (TH.varP name) exp + returnStmts = [bindRtnVal, returner] + where + rtnValName = TH.mkName "_returner" + bindRtnVal = TH.bindS (TH.varP rtnValName) final + returner + = TH.noBindS + [| return $(bigTuple (TH.varE rtnValName) + (fmap (TH.varE . fst) binds)) |] earleyGrammarFromRule :: Syntax.Lift t @@ -1200,45 +1232,29 @@ -- ^ Module prefix -> Rule t -> Q Exp -earleyGrammarFromRule prefix r@(Rule top _ _) = [| fmap fst (mfix $lamb) |] +earleyGrammarFromRule prefix r@(Rule top _ _) = recursiveDo binds final where - neededRules = ruleAndAncestors r - otherNames = rulesDemandedBeforeDefined neededRules - expression = - let stmts = concatMap (ruleToParser prefix) - . toList $ neededRules - result = bigTuple (ruleName top) otherNames - in TH.doE (stmts ++ [TH.noBindS ([|return|] `appE` result)]) - lamb = lamE [lazyPattern otherNames] expression + binds = concatMap (ruleToParser prefix) . toList . ruleAndAncestors $ r + final = [| return $(TH.varE $ ruleName top) |] -- | Creates an Earley grammar for each 'Rule' created in a --- 'Pinchot'. +-- 'Pinchot'. For a 'Pinchot' with a large number of 'Rule's, this +-- can create a large number of declarations that can take a long +-- time to compile--sometimes several minutes. For lower +-- compilation times, try 'earleyProduct'. allEarleyGrammars :: Syntax.Lift t - => String - -- ^ Module prefix. You have to make sure that the data types you - -- created with 'ruleTreeToTypes' or with 'allRulesToTypes' are in - -- scope, either because they were spliced into the same module that - -- 'earleyParser' is spliced into, or because they are @import@ed - -- into scope. The spliced Template Haskell code has to know where - -- to look for these data types. If you did an unqualified @import@ - -- or if the types are in the same module as is the splice of - -- 'earleyParser', just pass the empty string here. If you did a - -- qualified import, pass the appropriate namespace here. - -- - -- For example, if you used @import qualified MyAst@, pass - -- @\"MyAst\"@ here. If you used @import qualified - -- Data.MyLibrary.MyAst as MyLibrary.MyAst@, pass - -- @\"MyLibrary.MyAst\"@ here. - -- - -- This argument is similar to that for 'earleyGrammar' so - -- the examples there might be useful. - -- - -- For an example using this function, please see - -- "Pinchot.Examples.AllEarleyGrammars". + => Qualifier + -- ^ Qualifier for data types created with 'ruleTreeToTypes' or + -- 'allRulesToTypes' + -> Name + -- ^ Name for the terminal type; often this is 'Char'. Typically + -- you will use the Template Haskell quoting mechanism--for + -- example, @\'\'Char@. + -> Pinchot t a -- ^ Creates an Earley grammar for each 'Rule' created in the -- 'Pinchot'. The return value of the 'Pinchot' computation is @@ -1262,16 +1278,25 @@ -- -- where TYPE_NAME is the name of the type defined in the -- corresponding 'Rule'. -allEarleyGrammars prefix pinc = case ei of - Left err -> fail $ "pinchot: bad grammar: " ++ show err - Right _ -> sequence . fmap makeDecl . fmap snd . M.toList . allRules $ st +allEarleyGrammars prefix termName pinc = do + st <- fmap fst $ goPinchot pinc + sequence . concat . fmap makeDecl . fmap snd . M.toList + . allRules $ st where - (ei, st) = runState (runExceptT (runPinchot pinc)) - (Names Set.empty Set.empty 0 M.empty) - makeDecl rule@(Rule nm _ _) = TH.valD pat body [] + makeDecl rule@(Rule nm _ _) = [signature, TH.valD pat body []] where - pat = TH.varP (TH.mkName $ "g'" ++ nm) + signature = TH.sigD name types + r = TH.mkName "r" + types = TH.forallT [TH.PlainTV r] (return []) + $ [t| Text.Earley.Grammar $(TH.varT r) + (Text.Earley.Prod $(TH.varT r) String $(TH.conT termName) + $(TH.conT qualRuleName)) |] + name = TH.mkName $ "g'" ++ nm + pat = TH.varP name body = TH.normalB (earleyGrammarFromRule prefix rule) + qualRuleName + | null prefix = TH.mkName nm + | otherwise = TH.mkName (prefix ++ "." ++ nm) prodDeclName :: String -> TH.Name @@ -1287,10 +1312,17 @@ productionDecl :: String -- ^ Rule name + -> Name + -- ^ Name of terminal type -> RuleType t - -> TH.DecQ -productionDecl n t = TH.funD (prodDeclName n) clauses + -> TH.DecsQ +productionDecl n termType t + = sequence [signature, TH.funD (prodDeclName n) clauses] where + signature = TH.sigD (prodDeclName n) types + where + types = TH.appT (TH.appT TH.arrowT (TH.conT (TH.mkName n))) + (TH.appT (TH.conT ''Seq) (TH.conT termType)) clauses = case t of RTerminal _ -> [TH.clause [pat] bdy []] where @@ -1376,3 +1408,128 @@ where newTerm = [| $(prodFn inner) $(TH.varE (TH.mkName ("_x'" ++ show idx))) |] + +-- | Many functions take an argument that holds the name qualifier +-- for the module that contains the data types created by applying +-- 'ruleTreeToTypes' or 'allRulesToTypes' to the 'Pinchot.' +-- +-- You have to make sure that the data types you created with +-- 'ruleTreeToTypes', 'allRulesToTypes', or 'allRulesRecord' are in +-- scope. The spliced Template Haskell code has to know where to +-- look for these data types. If you did an unqualified @import@ or +-- if the types are in the same module as is the splice of +-- 'earleyParser', just pass the empty string here. If you did a +-- qualified import, use the appropriate qualifier here. +-- +-- For example, if you used @import qualified MyAst@, pass +-- @\"MyAst\"@ here. If you used @import qualified +-- Data.MyLibrary.MyAst as MyLibrary.MyAst@, pass +-- @\"MyLibrary.MyAst\"@ here. +-- +-- I recommend that you always create a new module and that all you +-- do in that module is apply 'ruleTreeToTypes' or +-- 'allRulesToTypes', and that you then perform an @import +-- qualified@ to bring those names into scope in the module in which +-- you use a function that takes a 'Qualifier' argument. This +-- avoids unlikely, but possible, issues that could otherwise arise +-- due to naming conflicts. +type Qualifier = String + + +-- | Creates a record data type that holds a value of type +-- +-- @'Text.Earley.Prod' r 'String' t a@ +-- +-- for every rule created in the 'Pinchot'. @r@ is left +-- universally quantified, @t@ is the token type (typically 'Char') +-- and @a@ is the type of the rule. +-- +-- This always creates a single product type whose name is +-- @Productions@; currently the name cannot be configured. +-- +-- For an example of the use of 'allRulesRecord', please see +-- "Pinchot.Examples.AllRulesRecord". +allRulesRecord + :: Qualifier + -- ^ Qualifier for data types created with 'ruleTreeToTypes' or + -- 'allRulesToTypes' + -> Name + -- ^ Name of terminal type. Typically you will get this through + -- the Template Haskell quoting mechanism, such as @''Char@. + -> Pinchot t a + -- ^ A record is created that holds a value for each 'Rule' + -- created in the 'Pinchot'; the return value of the 'Pinchot' is + -- ignored. + -> DecsQ + -- ^ When spliced, this will create a single declaration that is a + -- record with the name @Productions@. It will have one type variable, + -- @r@. Each record in the declaration will have a name like so: + -- + -- @a'NAME@ + -- + -- where @NAME@ is the name of the type. Don't count on these + -- records being in any particular order. +allRulesRecord prefix termName pinc + = sequence [TH.dataD (return []) (TH.mkName nameStr) tys [con] []] + where + nameStr = "Productions" + tys = [TH.PlainTV (TH.mkName "r")] + con = do + names <- fmap fst $ goPinchot pinc + TH.recC (TH.mkName nameStr) + (fmap (mkRecord . snd) . M.assocs . allRules $ names) + mkRecord (Rule ruleNm _ _) = TH.varStrictType recName st + where + recName = TH.mkName ("a'" ++ ruleNm) + st = TH.strictType TH.notStrict ty + where + ty = (TH.conT ''Text.Earley.Prod) + `TH.appT` (TH.varT (TH.mkName "r")) + `TH.appT` (TH.conT ''String) + `TH.appT` (TH.conT termName) + `TH.appT` (TH.conT (TH.mkName nameWithPrefix)) + nameWithPrefix = case prefix of + [] -> ruleNm + _ -> prefix ++ '.' : ruleNm + +-- | Creates a 'Text.Earley.Grammar' that contains a +-- 'Text.Earley.Prod' for every 'Rule' created in the 'Pinchot'. +earleyProduct + :: Syntax.Lift t + + => Qualifier + -- ^ Qualifier for data types created with 'ruleTreeToTypes' or + -- 'allRulesToTypes' + + -> Qualifier + -- ^ Module prefix for the type created with 'allRulesRecord' + + -> Pinchot t a + -- ^ Creates an Earley grammar that contains a 'Text.Earley.Prod' + -- for each 'Rule' in the 'Pinchot'. The return value from the + -- 'Pinchot' is ignored. + + -> ExpQ + -- ^ When spliced, 'earleyProduct' creates an expression whose + -- type is @'Text.Earley.Grammar' r (Productions r)@, where + -- @Productions@ is + -- the type created by 'allRulesRecord'. +earleyProduct pfxRule pfxRec pinc = do + names <- fmap fst $ goPinchot pinc + let binds = concatMap (ruleToParser pfxRule) + . fmap snd . M.assocs . allRules $ names + final = [| return + $(TH.recConE (TH.mkName rulesRecName) (recs names)) |] + recursiveDo binds final + where + rulesRecName + | null pfxRec = "Productions" + | otherwise = pfxRec ++ ".Productions" + recs = fmap mkRec . fmap snd . M.assocs . allRules + where + mkRec (Rule n _ _) = return (TH.mkName recName, recVal) + where + recName + | null pfxRec = "a'" ++ n + | otherwise = pfxRec ++ ".a'" ++ n + recVal = TH.VarE . ruleName $ n 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: 2016-02-27 17:45:07.736409 EST +-- Generated on: 2016-03-04 16:15:31.455268 EST -- Cartel library version: 0.14.2.8 name: pinchot -version: 0.12.0.0 +version: 0.14.0.0 cabal-version: >= 1.14 license: BSD3 license-file: LICENSE @@ -36,6 +36,8 @@ Pinchot Pinchot.Examples Pinchot.Examples.AllEarleyGrammars + Pinchot.Examples.AllRulesRecord + Pinchot.Examples.EarleyProduct Pinchot.Examples.Postal Pinchot.Examples.PostalAstAllRules Pinchot.Examples.PostalAstNoLenses @@ -68,6 +70,8 @@ Pinchot Pinchot.Examples Pinchot.Examples.AllEarleyGrammars + Pinchot.Examples.AllRulesRecord + Pinchot.Examples.EarleyProduct Pinchot.Examples.Postal Pinchot.Examples.PostalAstAllRules Pinchot.Examples.PostalAstNoLenses @@ -100,6 +104,8 @@ Pinchot Pinchot.Examples Pinchot.Examples.AllEarleyGrammars + Pinchot.Examples.AllRulesRecord + Pinchot.Examples.EarleyProduct Pinchot.Examples.Postal Pinchot.Examples.PostalAstAllRules Pinchot.Examples.PostalAstNoLenses @@ -133,6 +139,42 @@ Pinchot Pinchot.Examples Pinchot.Examples.AllEarleyGrammars + Pinchot.Examples.AllRulesRecord + Pinchot.Examples.EarleyProduct + Pinchot.Examples.Postal + Pinchot.Examples.PostalAstAllRules + Pinchot.Examples.PostalAstNoLenses + Pinchot.Examples.PostalAstRuleTree + Pinchot.Examples.QualifiedImport + Pinchot.Internal + Pinchot.Intervals + hs-source-dirs: + exe + build-depends: + base >= 4.8.0.0 && < 5 + , containers >= 0.5.6.2 + , transformers >= 0.4.2.0 + , template-haskell >= 2.10 + , Earley >= 0.10.1.0 + , lens >= 4.13 + other-extensions: + TemplateHaskell + default-language: Haskell2010 + hs-source-dirs: + lib + else + buildable: False + +Executable parakeet + main-is: parakeet.hs + if flag(executables) + buildable: True + other-modules: + Pinchot + Pinchot.Examples + Pinchot.Examples.AllEarleyGrammars + Pinchot.Examples.AllRulesRecord + Pinchot.Examples.EarleyProduct Pinchot.Examples.Postal Pinchot.Examples.PostalAstAllRules Pinchot.Examples.PostalAstNoLenses