pinchot 0.12.0.0 → 0.14.0.0

raw patch · 9 files changed

+388/−109 lines, 9 filesnew-component:exe:parakeetPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• exe/parakeet.hs +26/−0
• exe/parrot.hs +7/−7
• lib/Pinchot.hs +6/−0
• lib/Pinchot/Examples.hs +4/−0
• lib/Pinchot/Examples/AllEarleyGrammars.hs +4/−4
• lib/Pinchot/Examples/AllRulesRecord.hs +12/−0
• lib/Pinchot/Examples/EarleyProduct.hs +32/−0
• lib/Pinchot/Internal.hs +253/−96
• pinchot.cabal +44/−2

@@ -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

@@ -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

@@ -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

@@ -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. --

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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