pinchot 0.14.0.0 → 0.16.0.0

raw patch · 33 files changed

+2150/−2016 lines, 33 filesdep +ListLikedep −pretty-showdep ~Earleynew-component:exe:newmanPVP ok

version bump matches the API change (PVP)

Dependencies added: ListLike

Dependencies removed: pretty-show

Dependency ranges changed: Earley

API changes (from Hackage documentation)

Files

• exe/newman.hs +9/−0
• exe/parakeet.hs +0/−26
• exe/parrot.hs +0/−24
• exe/postal-parser.hs +0/−24
• exe/print-postal-grammar.hs +0/−14
• lib/Pinchot.hs +61/−24
• lib/Pinchot/Earley.hs +248/−0
• lib/Pinchot/Examples.hs +23/−39
• lib/Pinchot/Examples/AllEarleyGrammars.hs +0/−12
• lib/Pinchot/Examples/AllRulesRecord.hs +10/−8
• lib/Pinchot/Examples/Earley.hs +21/−0
• lib/Pinchot/Examples/EarleyProduct.hs +0/−32
• lib/Pinchot/Examples/Newman.hs +130/−0
• lib/Pinchot/Examples/Postal.hs +97/−50
• lib/Pinchot/Examples/PostalAstAllRules.hs +0/−27
• lib/Pinchot/Examples/PostalAstNoLenses.hs +0/−24
• lib/Pinchot/Examples/PostalAstRuleTree.hs +0/−28
• lib/Pinchot/Examples/QualifiedImport.hs +0/−19
• lib/Pinchot/Examples/RulesToOptics.hs +15/−0
• lib/Pinchot/Examples/SyntaxTrees.hs +29/−0
• lib/Pinchot/Examples/Terminalize.hs +16/−0
• lib/Pinchot/Internal.hs +0/−1535
• lib/Pinchot/Intervals.hs +9/−4
• lib/Pinchot/Locator.hs +59/−0
• lib/Pinchot/NonEmpty.hs +61/−0
• lib/Pinchot/RecursiveDo.hs +76/−0
• lib/Pinchot/Rules.hs +223/−0
• lib/Pinchot/SyntaxTree.hs +113/−0
• lib/Pinchot/SyntaxTree/Optics.hs +246/−0
• lib/Pinchot/SyntaxTree/Wrappers.hs +161/−0
• lib/Pinchot/Terminalize.hs +323/−0
• lib/Pinchot/Types.hs +180/−0
• pinchot.cabal +40/−126

@@ -0,0 +1,9 @@+module Main where++import Pinchot.Examples.Newman+import System.Environment (getArgs)++main :: IO ()+main = do+  a1:[] <- getArgs+  address a1

@@ -1,26 +0,0 @@-{-# 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,24 +0,0 @@-{-# LANGUAGE OverloadedLists #-}-{-# LANGUAGE TemplateHaskell #-}---- 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 Pinchot-import Data.Foldable (toList)-import Pinchot.Examples.Postal-import Pinchot.Examples.EarleyProduct-import System.Environment (getArgs)--import Text.Earley (parser, fullParses)--ruleTreeToTypes noOptics ''Char [] postal--main :: IO ()-main = do-  a1:[] <- getArgs-  let (ls, _) = fullParses (parser $(earleyGrammar "" postal)) a1 -      printSeq = putStrLn . toList . t'Address-  mapM_ printSeq ls

@@ -1,24 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE OverloadedLists #-}---- | Creates a Template Haskell parser.  Parses strings in the postal--- language and pretty-prints the result.-module Main where--import Pinchot-import Pinchot.Examples.Postal-import System.Environment (getArgs)-import Text.Show.Pretty (ppShow)--import Text.Earley (Prod, Grammar, parser, fullParses)--ruleTreeToTypes makeOptics ''Char [''Show] postal--postalGrammar :: Grammar r (Prod r String Char Address)-postalGrammar = $(earleyGrammar "" postal)--main :: IO ()-main = do-  a1:[] <- getArgs-  putStrLn . ppShow $ fullParses (parser postalGrammar) a1

@@ -1,14 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# OPTIONS_GHC -Wall #-}---- | Creates a Template Haskell AST for a parser--- and pretty-prints it to standard output.-module Main where--import Language.Haskell.TH-import Pinchot-import Pinchot.Examples.Postal---main :: IO ()-main = runQ [| $(earleyGrammar "" postal) |] >>= putStrLn . pprint

@@ -1,13 +1,17 @@ {- |  Pinchot provides a simple language that you use to write a Haskell-program that describes a context-free grammar.  When run, this program-creates a value that stores your context-free grammar.  You can then+values that describes a context-free grammar.  You can then use Template Haskell to take this value and generate a series of data types that correspond to your context-free grammar.  You can also use Template Haskell to create an Earley parser that will parse all-strings in the context-free language.+strings in the context-free language.  Other handy utilities generate+functions that will return all the terminal characters from a parsed+production rule.  It is also possible to easily determine the location+(line, column, and position) of any parsed production or character. +Everything you typically need should be in this module.+ For examples, please consult "Pinchot.Examples".  You should also look at the BNF Converter.@@ -43,40 +47,73 @@   , solo   , pariah -  -- * Simple production rules-  , Pinchot+  -- * Non-empty+  , NonEmpty(..)+  , front+  , rest+  , flatten+  , seqToNonEmpty+  , prependSeq+  , appendSeq+  , append+  , singleton+  +  -- * Production rules   , RuleName-  , AlternativeName   , Rule+  , BranchName   , terminal-  , terminalSeq   , nonTerminal   , union+  , terminals+  , wrap   , record+  , opt+  , star+  , plus -  -- * Rules that modify other rules-  , list-  , list1-  , option-  , wrap+  -- ** Errors   , label   , (<?>) -  -- * Transforming a Pinchot value to code-  -- ** Creating data types-  , MakeOptics-  , makeOptics-  , noOptics-  , allRulesToTypes-  , ruleTreeToTypes+  -- * Qualifiers+  , Qualifier++  -- * Creating data types corresponding to grammars+  , syntaxTrees   , allRulesRecord -  -- ** Creating Earley grammars-  , Qualifier-  , earleyGrammar-  , allEarleyGrammars+  -- ** Wrappers and optics+  , wrappedInstances+  , rulesToOptics++  -- * Creating Earley grammars+  , earleyGrammarFromRule   , earleyProduct++  -- * Terminalizers+  , terminalizeRuleExp+  , terminalizers++  -- * Locations+  , Loc(..)+  , line+  , col+  , pos+  , locations+  , noLocations++  -- * Running parsers with locations+  , locatedFullParses   ) where -import Pinchot.Internal+import Pinchot.Earley+import Pinchot.Locator import Pinchot.Intervals+import Pinchot.NonEmpty+import Pinchot.Rules+import Pinchot.SyntaxTree+import Pinchot.SyntaxTree.Optics+import Pinchot.SyntaxTree.Wrappers+import Pinchot.Terminalize+import Pinchot.Types

@@ -0,0 +1,248 @@+{-# OPTIONS_HADDOCK not-home #-}+{-# LANGUAGE TemplateHaskell #-}+-- | Creating Earley parsers.++module Pinchot.Earley where++import Pinchot.NonEmpty+import Pinchot.RecursiveDo+import Pinchot.Rules+import Pinchot.Types+import Pinchot.Intervals++import Control.Applicative ((<|>), liftA2)+import Data.Foldable (toList)+import Data.Sequence ((<|), viewl, ViewL(EmptyL, (:<)), Seq)+import qualified Data.Sequence as Seq+import qualified Language.Haskell.TH as T+import qualified Language.Haskell.TH.Syntax as Syntax+import qualified Text.Earley++-- | Creates a list of pairs.  Each list represents a statement in+-- @do@ notation.  The first element of the pair is the name of the+-- variable to which to bind the result of the expression, which is+-- the second element of the pair.+ruleToParser+  :: Syntax.Lift t+  => String+  -- ^ Module prefix+  -> Rule t+  -> [(T.Name, T.ExpQ)]+ruleToParser prefix (Rule nm mayDescription rt) = case rt of++  Terminal ivls -> [makeRule expression]+    where+      expression =+        [| let f (c, a)+                | inIntervals ivls c = Just+                    ($(T.conE (quald prefix nm)) (c, a))+                | otherwise = Nothing+           in Text.Earley.terminal f |]++  NonTerminal b1 bs -> [makeRule expression]+    where+      expression = foldl addBranch (branchToParser prefix b1) bs+        where+          addBranch tree branch =+            [| $tree <|> $(branchToParser prefix branch) |]++  Wrap (Rule innerNm _ _) -> [makeRule expression]+    where+      expression = [|fmap $constructor $(T.varE (localRuleName innerNm)) |]++  Record sq -> [makeRule expression]+    where+      expression = case viewl sq of+        EmptyL -> [| pure $constructor |]+        Rule r1 _ _ :< restFields -> foldl addField fstField restFields+          where+            fstField = [| $constructor <$> $(T.varE (localRuleName r1)) |]+            addField soFar (Rule r _ _)+              = [| $soFar <*> $(T.varE (localRuleName r)) |]+    +  Opt (Rule innerNm _ _) -> [makeRule expression]+    where+      expression = [| fmap $constructor (pure Nothing <|> $(just)) |]+        where+          just = [| fmap Just $(T.varE (localRuleName innerNm)) |]++  Star (Rule innerNm _ _) -> [nestRule, makeRule (wrapper helper)]+    where+      nestRule = (helper, ([|Text.Earley.rule|] `T.appE` parseSeq))+        where+          parseSeq = T.uInfixE [|pure Seq.empty|] [|(<|>)|] pSeq+            where+              pSeq = [|liftA2 (<|)+                $(T.varE (localRuleName innerNm)) $(T.varE helper) |]++  Plus (Rule innerNm _ _) -> [nestRule, makeRule topExpn]+    where+      nestRule = (helper, [|Text.Earley.rule $(parseSeq)|])+        where+          parseSeq = [| pure Seq.empty <|> $pSeq |]+            where+              pSeq = [| (<|) <$> $(T.varE (localRuleName innerNm))+                             <*> $(T.varE helper) |]+      topExpn = [| $constructor <$>+        ( NonEmpty <$> $(T.varE (localRuleName innerNm))+                   <*> $(T.varE helper)) |]+++  where+    makeRule expression = (localRuleName nm,+      [|Text.Earley.rule ($expression Text.Earley.<?> $(textToExp desc))|])+    desc = maybe nm id mayDescription+    textToExp txt = [| $(Syntax.lift txt) |]+    constructor = T.conE (quald prefix nm)+    wrapper wrapRule = [|fmap $constructor $(T.varE wrapRule) |]+    helper = helperName nm++localRuleName :: String -> T.Name+localRuleName suffix = T.mkName ("_rule'" ++ suffix)++helperName :: String -> T.Name+helperName suffix = T.mkName ("_helper'" ++ suffix)++branchToParser+  :: Syntax.Lift t+  => String+  -- ^ Module prefix+  -> Branch t+  -> T.ExpQ+branchToParser prefix (Branch name rules) = case viewl rules of+  EmptyL -> [| pure $constructor |]+  (Rule rule1 _ _) :< xs -> foldl f z xs+    where+      z = [| $constructor <$> $(T.varE (localRuleName rule1)) |]+      f soFar (Rule rule2 _ _) = [| $soFar <*> $(T.varE (localRuleName rule2)) |]+  where+    constructor = T.conE (quald prefix name)++-- | Creates an expression that has type+--+-- 'Text.Earley.Grammar' r (Prod r String (c, a) (p c a))+--+-- where @r@ is left universally quantified; @c@ is the terminal+-- type (often 'Char'), @a@ is arbitrary metadata about each token+-- (often 'Loc') and @p@ is the data type corresponding to+-- the given 'Rule'.+--+-- Example:  'Pinchot.Examples.Earley.addressGrammar'.+earleyGrammarFromRule+  :: Syntax.Lift t+  => Qualifier+  -- ^ Module prefix holding the data types created with+  -- 'Pinchot.syntaxTrees'+  -> Rule t+  -- ^ Create a grammar for this 'Rule'+  -> T.Q T.Exp+earleyGrammarFromRule prefix r@(Rule top _ _) = recursiveDo binds final+  where+    binds = concatMap (ruleToParser prefix) . toList . family $ r+    final = [| return $(T.varE $ localRuleName top) |]++-- | Creates a record data type that holds a value of type+--+-- @'Text.Earley.Prod' r 'String' (t, a) (p t a)@+--+-- where+--+-- * @r@ is left universally quantified+--+-- * @t@ is the token type (often 'Char')+--+-- * @a@ is any additional information about each token (often+-- 'Pinchot.Loc')+--+-- * @p@ is the type of the particular production+--+-- This always creates a single product type whose name is+-- @Productions@; currently the name cannot be configured.+--+-- Example: "Pinchot.Examples.SyntaxTrees".+allRulesRecord+  :: Qualifier+  -- ^ Qualifier for data types corresponding to those created from+  -- the 'Rule's+  -> T.Name+  -- ^ Name of terminal type.  Typically you will get this through+  -- the Template Haskell quoting mechanism, such as @''Char@.+  -> Seq (Rule t)+  -- ^ A record is created that holds a value for each 'Rule'+  -- in the 'Seq', as well as for every ancestor of these 'Rule's.+  -> T.DecsQ+  -- ^ When spliced, this will create a single declaration that is a+  -- record with the name @Productions@.+  --+  -- @a'NAME@+  --+  -- where @NAME@ is the name of the type.  Don't count on these+  -- records being in any particular order.+allRulesRecord prefix termName ruleSeq+  = sequence [T.dataD (return []) (T.mkName nameStr) tys [con] []]+  where+    nameStr = "Productions"+    tys = [T.PlainTV (T.mkName "r"), T.PlainTV (T.mkName "t"),+      T.PlainTV (T.mkName "a")]+    con = T.recC (T.mkName nameStr)+        (fmap mkRecord . toList . families $ ruleSeq)+    mkRecord (Rule ruleNm _ _) = T.varStrictType recName st+      where+        recName = T.mkName ("a'" ++ ruleNm)+        st = T.strictType T.notStrict ty+          where+            ty = [t| Text.Earley.Prod $(T.varT (T.mkName "r"))+                      String+                      ( $(T.varT (T.mkName "t")), $(T.varT (T.mkName "a")))+                      ( $(T.conT (T.mkName nameWithPrefix))+                            $(T.varT (T.mkName "t"))+                            $(T.varT (T.mkName "a"))) |]+            nameWithPrefix = case prefix of+              [] -> ruleNm+              _ -> prefix ++ '.' : ruleNm++-- | Creates a 'Text.Earley.Grammar' that contains a+-- 'Text.Earley.Prod' for every given 'Rule' and its ancestors.+-- Example: 'Pinchot.Examples.Earley.addressAllProductions'.+earleyProduct+  :: Syntax.Lift t++  => Qualifier+  -- ^ Qualifier for data types corresponding to those created from+  -- the 'Rule's++  -> Qualifier+  -- ^ Qualifier for the type created with 'allRulesRecord'++  -> Seq (Rule t)+  -- ^ Creates an Earley grammar that contains a 'Text.Earley.Prod'+  -- for each 'Rule' in this 'Seq', as well as all the ancestors of+  -- these 'Rule's.++  -> T.ExpQ+  -- ^ When spliced, 'earleyProduct' creates an expression whose+  -- type is @'Text.Earley.Grammar' r (Productions r t a)@, where+  -- @Productions@ is+  -- the type created by 'allRulesRecord'; @r@ is left universally+  -- quantified; @t@ is the token type (often 'Char'), and @a@ is+  -- any additional information about each token (often+  -- 'Pinchot.Loc').+earleyProduct pfxRule pfxRec ruleSeq = do+  let binds = concatMap (ruleToParser pfxRule)+        . toList . families $ ruleSeq+      final = [| return+        $(T.recConE (T.mkName rulesRecName)+                    (fmap mkRec . toList . families $ ruleSeq)) |]+        +  recursiveDo binds final+  where+    rulesRecName+      | null pfxRec = "Productions"+      | otherwise = pfxRec ++ ".Productions"+    mkRec (Rule n _ _) = return (T.mkName recName, recVal)+      where+        recName+          | null pfxRec = "a'" ++ n+          | otherwise = pfxRec ++ ".a'" ++ n+        recVal = T.VarE . localRuleName $ n+

@@ -1,44 +1,28 @@-{-# OPTIONS_GHC -fno-warn-unused-imports #-}-{-# LANGUAGE TypeFamilies #-}---- | Examples for the use of Pinchot.--- You wil want to look at the source code for the modules; examining--- just the Haddocks shows you the code that the Template Haskell--- ultimately generates.------ In "Pinchot.Examples.Postal" is an example grammar for US postal--- addresses.------ "Pinchot.Examples.PostalAstAllRules" shows you how to use--- 'allRulesToTypes' and 'earleyGrammar', while--- "Pinchot.Examples.PostalAstRuleTree" shows you how to use--- 'ruleTreeToTypes' and 'earleyGrammar'.------ "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.+-- | Examples for Pinchot are in this hierarchy.  Start out with+-- "Pinchot.Examples.Postal", which contains a sample grammar.+-- Next, "Pinchot.Examples.SyntaxTrees" shows you how to convert+-- your grammar to data types, and "Pinchot.Examples.AllRulesRecord"+-- shows how to make a product type holding an Earley+-- 'Text.Earley.Prod' for every 'Rule' in your grammar.  Then,+-- "Pinchot.Earley" shows how to generate the Earley+-- 'Text.Earley.Grammar' you need to actually parse strings. ----- The @print-postal-grammar@ executable will pretty print the Haskell--- source that results from applying 'earleyGrammar' to the 'postal'--- grammar.+-- "Pinchot.Examples.Terminalize" shows you how to generate data+-- types that will reduce any 'Rule' to the sequence of terminal+-- tokens from which it came.  This can be useful not only for+-- reconstructing the source text, but also for determining where in+-- the source text a production was found. ----- The @postal-parser@ executable takes as its first and sole argument--- a string.  It parses the string using the 'postal' grammar and--- pretty prints the resultin parses to standard output.+-- "Pinchot.Examples.RulesToOptics" shows how to generate lenses and+-- isos, which are valuable for navigating and manipulating large trees. ----- The @parrot@ executable takes as its first and sole argument a--- string.  It parses the string using the 'postal' grammar.  For--- every result that is returned (there might be zero, or one, or more--- than one) the result is reduced to terminal symbols using the--- 'terminals' function and the result is printed to standard output.+-- Finally, "Pinchot.Examples.Newman" shows how to actually run the+-- Earley parsers, find the locations of various productions, and+-- show the results on-screen.  You can play with+-- 'Pinchot.Examples.Newman.address' and+-- 'Pinchot.Examples.Newman.addressFromFile' in GHCi.  Or, if you+-- compile the Pinchot package using the @executables@ flag, you+-- will get an executable named @newman@ that you can play with from+-- the command line.  module Pinchot.Examples where--import Pinchot-import Pinchot.Examples.Postal

@@ -1,12 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--- | Provides an example of the use of 'Pinchot.AllEarleyGrammars'.--- You will want to look at the source code, as it shows what sort--- of Template Haskell splice to use.--module Pinchot.Examples.AllEarleyGrammars where--import qualified Pinchot-import qualified Pinchot.Examples.Postal as Postal-import qualified Pinchot.Examples.PostalAstAllRules as PostalAstAllRules--Pinchot.allEarleyGrammars "PostalAstAllRules" ''Char Postal.postal

@@ -1,12 +1,14 @@--- | 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 #-}+{-# LANGUAGE OverloadedLists #-}++-- | This module shows how to generate a product type holding all+-- the productions that result from a given 'Rule'.  You wil want to+-- look at the source code, as the Haddocks will show you only the+-- generated type, not the Template Haskell used to generate it. module Pinchot.Examples.AllRulesRecord where -import qualified Pinchot-import qualified Pinchot.Examples.Postal as Postal-import qualified Pinchot.Examples.PostalAstAllRules as AllRules+import Pinchot+import Pinchot.Examples.Postal+import qualified Pinchot.Examples.SyntaxTrees as SyntaxTrees -Pinchot.allRulesRecord "AllRules" ''Char Postal.postal+$(allRulesRecord "SyntaxTrees" ''Char [rAddress])

@@ -0,0 +1,21 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedLists #-}++-- | This module shows how to generate Earley grammars for your+-- context-free grammar.  You will want to look at the source code.+module Pinchot.Examples.Earley where++import Pinchot+import Pinchot.Examples.Postal+import qualified Pinchot.Examples.SyntaxTrees as SyntaxTrees+import qualified Pinchot.Examples.AllRulesRecord as AllRulesRecord+import Text.Earley++addressGrammar+  :: Grammar r (Prod r String (Char, a) (SyntaxTrees.Address Char a))+addressGrammar = $(earleyGrammarFromRule "SyntaxTrees" rAddress)++addressAllProductions+  :: Grammar r (AllRulesRecord.Productions r Char a)+addressAllProductions = $(earleyProduct "SyntaxTrees" "AllRulesRecord"+  [rAddress])

@@ -1,32 +0,0 @@-{-# 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

@@ -0,0 +1,130 @@+-- | This module provides a simple example of use of everything in+-- Pinchot.  'address' parses a postal address from a string and+-- prints a simple report showing some of the elements of the+-- address and their locations.+module Pinchot.Examples.Newman where++import Pinchot++import Pinchot.Examples.Earley+import Pinchot.Examples.SyntaxTrees+import Pinchot.Examples.Terminalize+import Pinchot.Examples.RulesToOptics++import qualified Control.Lens as Lens+import Data.Foldable (toList)+import Data.List (intersperse)+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq+import qualified Text.Earley as Earley++-- | Formats a 'Loc' for nice on-screen display.+labelLoc :: Loc -> String+labelLoc (Loc l c p)+  = "(line: " ++ show l ++ " col: " ++ show c ++ " pos: "+  ++ show p ++ ")"++-- | Labels a single field, where the field may or may not appear in+-- a parsed result.+labelOpt :: String -> Seq (Char, Loc) -> String+labelOpt l sq+  = l ++ ": " ++ show (toList . fmap fst $ sq)+  ++ " " ++ loc ++ "\n"+  where+    loc = case Lens.uncons sq of+      Nothing -> "(no location)"+      Just ((_, loc), _) -> labelLoc loc++-- | Labels a single field, where the field will always appear in a+-- parsed result.+labelNE :: String -> NonEmpty (Char, Loc) -> String+labelNE l sq+  = l ++ ": " ++ show (toList . fmap fst $ sq)+  ++ " " ++ loc ++ "\n"+  where+    loc = labelLoc . snd . _front $ sq++-- | Formats a single 'Address' for nice on-screen display.+showAddress :: Address Char Loc -> String+showAddress a = name ++ street ++ city+  where+    name = labelNE "Name" . t'Words+      . _r'NameLine'0'Words . _r'Address'0'NameLine $ a+    street = number ++ pre ++ streetName ++ suf+      where+        number = labelNE "Number" . t'Number . _r'StreetLine'0'Number+          . _r'Address'1'StreetLine $ a++        pre = labelOpt "Direction prefix"+          . maybe Seq.empty flatten+          . Lens.preview (r'Address'1'StreetLine+                          . r'StreetLine'2'DirectionSpace'Opt+                          . Lens._Wrapped'+                          . Lens._Just+                          . r'DirectionSpace'0'Direction+                          . Lens.to t'Direction)+          $ a++        streetName = labelNE "Street"+          . t'StreetName+          . _r'StreetLine'3'StreetName+          . _r'Address'1'StreetLine+          $ a++        suf = labelOpt "Street suffix"+          . maybe Seq.empty flatten+          . Lens.preview (r'Address'1'StreetLine+                          . r'StreetLine'4'SpaceSuffix'Opt+                          . Lens._Wrapped'+                          . Lens._Just+                          . r'SpaceSuffix'1'Suffix+                          . Lens.to t'Suffix)+          $ a+    city = cty ++ st ++ zip+      where+        cty = labelNE "City"+          . t'City+          . _r'CityLine'0'City+          . _r'Address'2'CityLine+          $ a++        st = labelNE "State"+          . t'State+          . _r'CityLine'3'State+          . _r'Address'2'CityLine+          $ a++        zip = labelNE "Zip"+          . t'ZipCode+          . _r'CityLine'5'ZipCode+          . _r'Address'2'CityLine+          $ a++-- | Formats successful 'Address' parses and the 'Earley.Report' for+-- nice on-screen display.+showParseResult+  :: ([Address Char Loc], Earley.Report String (Seq (Char, Loc)))+  -> String+showParseResult (addresses, report) = addresses' ++ "\n" ++ report'+  where+    addresses' = ("Full parses:\n\n" ++)+      . concat . intersperse "---\n" . map showAddress+      $ addresses+    report' = ("Earley report:\n\n" ++) . show+      $ report { Earley.unconsumed = toList . fmap fst+      . Earley.unconsumed $ report }++-- | Parse an address and print the resulting report.  Good for use+-- in GHCi.+address :: String -> IO ()+address = putStrLn . showParseResult . locatedFullParses addressGrammar++-- | Read an address from a file and print the resulting report.+-- Good for use in GHCi.+addressFromFile+  :: String+  -- ^ Filename+  -> IO ()+addressFromFile fn = do+  str <- readFile fn+  putStrLn . showParseResult . locatedFullParses addressGrammar $ str

@@ -1,58 +1,105 @@-{-# LANGUAGE OverloadedStrings, OverloadedLists, RecursiveDo #-}+{-# LANGUAGE OverloadedLists #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++-- | This module contains a context-free grammar for U.S. postal+-- addresses.  It would never hold up to real-world use but it gives+-- you a good idea of how to write grammars in Pinchot.+--+-- The grammar is ambiguous.+--+-- There are no signatures; the type of every declaration in the+-- module is 'Rule' 'Char'. module Pinchot.Examples.Postal where  import Pinchot- import Data.Monoid ((<>)) --- | A grammar for simple U.S. postal addresses.  This example would never--- hold up to real-world usage but it gives you a flavor of how--- Pinchot works.------ The grammar is ambiguous.-postal :: Pinchot Char (Rule Char)-postal = mdo-  digit <- terminal "Digit" (include '0' '9') <?> "digit from 0 to 9"-  digits <- list1 digit-  letter <- terminal "Letter" (include 'a' 'z' <> include 'A' 'Z')-    <?> "letter from A to Z"-  north <- terminal "North" (solo 'N')-  south <- terminal "South" (solo 'S')-  east <- terminal "East" (solo 'E')-  west <- terminal "West" (solo 'W')-  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 <- union "Suffix" [street, avenue, way, boulevard]-  space <- terminal "Space" (solo ' ')-  comma <- terminal "Comma" (solo ',')+rDigit = terminal "Digit" (include '0' '9') <?> "digit from 0 to 9" -  -- You could do this with 'list' but this demonstrates how to write-  -- a recurvsive rule.-  letters <- nonTerminal "Letters"-    [ ("NoLetter", [])-    , ("ConsLetter", [letter, letters])-    ]+rDigits = plus rDigit -  -- Named "PostalWord" to avoid clash with Prelude.Word-  word <- record "PostalWord" [letter, letters]-  preSpacedWord <- record "PreSpacedWord" [space, word]-  preSpacedWords <- list preSpacedWord-  words <- record "Words" [word, preSpacedWords]+rLetter = terminal "Letter" (include 'a' 'z' <> include 'A' 'Z')+  <?> "letter from A to Z" -  number <- wrap "Number" digits-  streetName <- wrap "StreetName" words-  city <- wrap "City" words-  state <- wrap "State" word-  zipCode <- wrap "ZipCode" digits-  directionSpace <- record "DirectionSpace" [direction, space]-  spaceSuffix <- record "SpaceSuffix" [space, suffix]-  optDirection <- option directionSpace-  optSuffix <- option spaceSuffix-  address <- record "Address"-    [ number, space, optDirection, streetName, optSuffix,-      comma, space, city, comma, space, state, space, zipCode-    ]-  return address+rNorth = terminal "North" (solo 'N')++rSouth = terminal "South" (solo 'S')++rEast = terminal "East" (solo 'E')++rWest = terminal "West" (solo 'W')++rNE = terminals "NE" "NE"++rNW = terminals "NW" "NW"++rSW = terminals "SW" "SW"++rSE = terminals "SE" "SE"++rDirection = union "Direction"+  [rNorth, rSouth, rEast, rWest, rNE, rNW, rSE, rSW]++rStreet = terminals "Street" "St"++rAvenue = terminals "Avenue" "Ave"++rWay = terminals "Way" "Way"++rBoulevard = terminals "Boulevard" "Blvd"++rSuffix = union "Suffix" [rStreet, rAvenue, rWay, rBoulevard]++rSpace = terminal "Space" (solo ' ')++rComma = terminal "Comma" (solo ',')++rNewline = terminal "Newline" (solo '\n')++rCommaSpace = record "CommaSpace" [rComma, rSpace]++rSeparator = union "Separator" [rCommaSpace, rNewline]++rLetters = nonTerminal "Letters"+  [ ("NoLetter", [])+  , ("ConsLetter", [rLetter, rLetters])+  ]++-- Named "PostalWord" to avoid clash with Prelude.Word+rPostalWord = record "PostalWord" [rLetter, rLetters]++rPreSpacedWord = record "PreSpacedWord" [rSpace, rPostalWord]++rPreSpacedWords = star rPreSpacedWord++rWords = record "Words" [rPostalWord, rPreSpacedWords]++rNumber = wrap "Number" rDigits++rStreetName = wrap "StreetName" rWords++rCity = wrap "City" rWords++rState = wrap "State" rWords++rZipCode = record "ZipCode" [rDigit, rDigit, rDigit, rDigit, rDigit]++rDirectionSpace = record "DirectionSpace" [rDirection, rSpace]++rSpaceSuffix = record "SpaceSuffix" [rSpace, rSuffix]++rOptDirection = opt rDirectionSpace++rOptSuffix = opt rSpaceSuffix++rOptNewline = opt rNewline++rNameLine = record "NameLine" [rWords, rSeparator]++rStreetLine = record "StreetLine" [rNumber, rSpace, rOptDirection,+  rStreetName, rOptSuffix, rSeparator]++rCityLine = record "CityLine" [rCity, rComma, rSpace, rState,+  rSpace, rZipCode, rOptNewline]++rAddress = record "Address" [rNameLine, rStreetLine, rCityLine]

@@ -1,27 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE OverloadedLists #-}---- | Provides an example of the use of 'ruleTreeToTypes'.  You will--- want to look at the source code, as it has a Template Haskell--- splice that produces all of the data types that you see in the--- Haddocks.-module Pinchot.Examples.PostalAstAllRules where--import Pinchot-import Pinchot.Examples.Postal---- Earley is imported only for the type signature for 'postalGrammar'.  The--- Template Haskell does not need the import.-import Text.Earley (Grammar, Prod)---- This Template Haskell splice will produce a list of declarations,--- with one declaration for each production rule in the grammar.--- Unlike 'ruleTreeToTypes', this splice will contain every rule that--- was defined in the 'Pinchot'.-allRulesToTypes makeOptics ''Char [''Eq, ''Ord, ''Show] postal---- | Earley grammar created using Template Haskell.--postalGrammar :: Grammar r (Prod r String Char Address)-postalGrammar = $(earleyGrammar "" postal)

@@ -1,24 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE OverloadedLists #-}--- | Provides an example of 'ruleTreeToTypes', but unlike--- "Pinchot.Examples.PostalAstAllRules", does not make optics.--module Pinchot.Examples.PostalAstNoLenses where--import Pinchot-import Pinchot.Examples.Postal---- Earley is imported only for the type signature for 'myParser'.  The--- Template Haskell does not need the import.-import Text.Earley (Grammar, Prod)---- This Template Haskell splice will produce a list of declarations,--- with one declaration for each production rule in the grammar.--- Unlike 'ruleTreeToTypes', this splice will contain every rule that--- was defined in the 'Pinchot'.-allRulesToTypes noOptics ''Char [''Eq, ''Ord, ''Show] postal---- | Earley grammar created using Template Haskell.--postalGrammar :: Grammar r (Prod r String Char Address)-postalGrammar = $(earleyGrammar "" postal)

@@ -1,28 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE OverloadedLists #-}---- | Provides an example of the use of 'ruleTreeToTypes'.  You will--- want to look at the source code, as it has a Template Haskell--- splice that produces all of the data types that you see in the--- Haddocks.-module Pinchot.Examples.PostalAstRuleTree where--import Pinchot-import Pinchot.Examples.Postal---- Earley is imported only for the type signature for 'myParser'.  The--- Template Haskell does not need the import.-import Text.Earley (Grammar, Prod)---- This Template Haskell splice will produce a list of declarations,--- with one declaration for each production rule in the grammar.--- Unlike 'allRulesToTypes', this splice will contain only the--- 'Address' rule and its ancestors.--ruleTreeToTypes makeOptics ''Char [''Eq, ''Ord, ''Show] postal---- | Earley grammar created using Template Haskell.--postalGrammar :: Grammar r (Prod r String Char Address)-postalGrammar = $(earleyGrammar "" postal)

@@ -1,19 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}---- | Provides an example of the use of 'earleyParser' with a qualified--- import of the data types that comprise the grammar.--module Pinchot.Examples.QualifiedImport where--import Pinchot-import qualified Pinchot.Examples.PostalAstRuleTree as Ast-import qualified Pinchot.Examples.Postal as Postal---- Earley is imported only for the type signature for 'myParser'.  The--- Template Haskell does not need the import.-import Text.Earley (Grammar, Prod)---- | Earley parser created using Template Haskell.--myParser :: Grammar r (Prod r String Char Ast.Address)-myParser = $(earleyGrammar "Ast" Postal.postal)

@@ -0,0 +1,15 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedLists #-}++-- | This module shows how to use Template Haskell to generate+-- optics (lenses, prisms, and isos) for the rules in your grammar.+-- You will want to look at the source code, as the Haddocks will+-- show the generated types but it will not show the Template+-- Haskell used to generate them.+module Pinchot.Examples.RulesToOptics where++import Pinchot+import Pinchot.Examples.Postal+import qualified Pinchot.Examples.SyntaxTrees as SyntaxTrees++$(rulesToOptics "SyntaxTrees" ''Char [rAddress])

@@ -0,0 +1,29 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}++-- The following extension is required only for the splice of Lens wrapped+-- instances in 'wrappedInstances'+{-# LANGUAGE TypeFamilies #-}++-- | This module shows how to use Template Haskell to generate the+-- data types corresponding to your context-free grammar.  You will+-- want to look at the source; the Haddocks will show only the+-- generated types and not the Template Haskell that was used to+-- generate them.+module Pinchot.Examples.SyntaxTrees where++import Pinchot+import Pinchot.SyntaxTree.Wrappers+import Pinchot.Examples.Postal++import qualified Control.Lens as Lens++-- This generates the data types corresponding to the 'rAddress'+-- 'Rule', as well as all the ancestors of that 'Rule'.+$(syntaxTrees ''Char+  [''Eq, ''Ord, ''Show, ''Foldable, ''Traversable, ''Functor]+  [rAddress])++-- This generates intances of the Lens Wrapped typeclass.+$(wrappedInstances [rAddress])

@@ -0,0 +1,16 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedLists #-}++-- | This module shows how to use Template Haskell to generate+-- functions that will reduce any production to the terminal tokens+-- that were used to create it.+module Pinchot.Examples.Terminalize where++import Pinchot+import Pinchot.Examples.Postal+import qualified Pinchot.Examples.SyntaxTrees as SyntaxTrees++terminalizeAddress :: SyntaxTrees.Address t a -> NonEmpty (t, a)+terminalizeAddress = $(terminalizeRuleExp "SyntaxTrees" rAddress)++$(terminalizers "SyntaxTrees" ''Char [rAddress])

@@ -1,1535 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}--- | Pinchot internals.  Ordinarily the "Pinchot" module should have--- everything you need.--module Pinchot.Internal where--import Pinchot.Intervals--import Control.Applicative ((<|>), liftA2)-import Control.Exception (Exception)-import qualified Control.Lens as Lens-import Control.Monad (join, when)-import Control.Monad.Fix (MonadFix, mfix)-import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.Except (ExceptT, throwE, runExceptT)-import Control.Monad.Trans.State (State, runState, get, put)-import Data.Char (isUpper)-import Data.Foldable (toList)-import Data.Map (Map)-import qualified Data.Map as M-import Data.Monoid ((<>))-import Data.Set (Set)-import Data.Sequence (Seq, ViewL(EmptyL, (:<)), viewl, (<|))-import qualified Data.Sequence as Seq-import qualified Data.Set as Set-import Data.Typeable (Typeable)-import Language.Haskell.TH-  (ExpQ, ConQ, normalC, mkName, strictType, notStrict, newtypeD,-   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---- | 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--- data construtor.  If you are creating a 'nonTerminal', you will--- specify the name of each data constructor with 'AlternativeName'.-type RuleName = String---- | Type synonym the the name of an alternative in a 'nonTerminal'.--- This name must not conflict with any other data constructor, either--- one specified as an 'AlternativeName' or one that was created using--- 'terminal', 'option', 'list', or 'list1'.-type AlternativeName = String---- | A branch in a sum rule.  In @Branch s ls@, @s@ is the name of the--- data constructor, and @ls@ is the list of rules that this branch--- produces.-data Branch t = Branch String (Seq (Rule t))-  deriving (Eq, Ord, Show)--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)-  | RList1 (Rule t)-  | RWrap (Rule t)-  | RRecord (Seq (Rule t))-  deriving (Eq, Ord, Show)---- Rule n d t, where------ n is the name of the rule.  This is used as the name of the--- corresponding data type.------ d is the description of the rule.  This is optional and is used for--- the parser's error messages.  If there is no description, the name--- is used for error messages.------ t is the type of rule (terminal, branch, etc.)---- | A single production rule.  It may be a terminal or a non-terminal.-data Rule t = Rule String (Maybe String) (RuleType t)-  deriving (Eq, Ord, Show)---- | Name a 'Rule' for use in error messages.  If you do not name a--- rule using this combinator, the rule's type name will be used in--- error messages.-label :: String -> Rule t -> Rule t-label s (Rule n _ t) = Rule n (Just s) t---- | Infix form of 'label' for use in a 'Pinchot'; handy for use in--- @do@ or @mdo@ notation.-(<?>) :: Pinchot t (Rule t) -> String -> Pinchot t (Rule t)-p <?> s = fmap (label s) p-infixr 0 <?>--data Names t = Names-  { tyConNames :: Set RuleName-  , dataConNames :: Set String-  , nextIndex :: Int-  , allRules :: Map Int (Rule t)-  } deriving (Eq, Ord, Show)---- | Errors that may arise when constructing an AST.-data Error-  = InvalidName String-  -- ^ A name was invalid.  The field is the invalid name.  The name-  -- might be invalid because it was already used, or because it does-  -- not begin with a capital letter.-  | EmptyNonTerminal String-  -- ^ A non-terminal must have at least one summand.  The field is-  -- the name of the empty non-terminal.-  deriving (Show, Typeable)--instance Exception Error---- | Constructs new 'Rule's.  @t@ is the type of the token; often this--- will be 'Char'.------ 'Pinchot' is a 'Monad' and an 'Applicative' so you can combine--- computations using the usual methods of those classes.  Also,--- 'Pinchot' is a 'MonadFix'.  This allows you to construct a 'Rule'--- that depends on itself, and to construct sets of 'Rule's that have--- mutually recursive dependencies.  'MonadFix' also allows you to use--- the GHC @RecursiveDo@ extension.  Put------ @--- {-\# LANGUAGE RecursiveDo \#-}--- @------ at the top of your module, then use @mdo@ instead of @do@.  Because--- an @mdo@ block is recursive, you can use a binding before it is--- defined, just as you can in a set of @let@ bindings.--newtype Pinchot t a-  = 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 ()-addRuleName name = Pinchot $ do-  old@(Names tyNames _ _ _) <- lift get-  case name of-    [] -> throw-    x:_ -> do-      when (not (isUpper x)) throw-      when (Set.member name tyNames) throw-      lift $ put (old { tyConNames = Set.insert name tyNames })-  where-    throw = throwE $ InvalidName name--addDataConName-  :: AlternativeName-  -> Pinchot t ()-addDataConName name = Pinchot $ do-  old@(Names _ dcNames _ _) <- lift get-  case name of-    [] -> throw-    x:_ -> do-      when (not (isUpper x)) throw-      when (Set.member name dcNames) throw-      lift $ put (old { dataConNames = Set.insert name dcNames })-  where-    throw = throwE $ InvalidName name--newRule-  :: RuleName-  -> RuleType t-  -> Pinchot t (Rule t)-newRule name ty = Pinchot $ do-  runPinchot (addRuleName name)-  st <- lift get-  let r = Rule name Nothing ty-      newSt = st { nextIndex = succ (nextIndex st)-                 , allRules = M.insert (nextIndex st) r-                            (allRules st)-                 }-  lift (put newSt)-  runPinchot $ addDataConNames r-  return r---- | Creates a terminal production rule.-terminal--  :: RuleName--  -> Intervals t-  -- ^ Valid terminal symbols--  -> Pinchot t (Rule t)--terminal name ivls = newRule name (RTerminal ivls)--splitNonTerminal-  :: String-  -> Seq (String, Seq (Rule t))-  -> Pinchot t ((String, Seq (Rule t)), Seq (String, Seq (Rule t)))-splitNonTerminal n sq = Pinchot $ case viewl sq of-  EmptyL -> throwE $ EmptyNonTerminal n-  x :< xs -> return (x, xs)---- | Creates a production for a sequence of terminals.  Useful for--- parsing specific words.-terminalSeq--  :: RuleName--  -> Seq t-  -- ^ Sequence of terminal symbols to recognize--  -> Pinchot t (Rule t)--terminalSeq name sq = newRule name (RSeqTerm sq)---- | Creates a new non-terminal production rule.-nonTerminal--  :: RuleName--  -> Seq (AlternativeName, Seq (Rule t))-  -- ^ Alternatives.  There must be at least one alternative;-  -- otherwise, an error will result.  In each pair @(a, b)@, @a@ will-  -- be the data constructor, so this must be a valid Haskell data-  -- constructor name.  @b@ is the sequence of production rules, which-  -- can be empty (this is how to create an epsilon production).--  -> Pinchot t (Rule t)--nonTerminal name sq = do-  (b1, bs) <- splitNonTerminal name sq-  let branches = RBranch (uncurry Branch b1, fmap (uncurry Branch) bs)-  newRule name branches--ruleConstructorNames-  :: Rule t-  -> Seq AlternativeName-ruleConstructorNames (Rule n _ t) = case t of-  RTerminal _ -> Seq.singleton n-  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-  RList1 _ -> Seq.singleton n-  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.  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 (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 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:------ @_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--- field itself.  For an example, see--- 'Pinchot.Examples.PostalAstAllRules.Address'.------ Currently there is no way to change the names of the record fields.-record-  :: RuleName-  -- ^ The name of this rule, which is used both as the type name and-  -- the name of the sole data constructor.-  -> Seq (Rule t)-  -- ^ The right-hand side of this rule.  This sequence can be empty,-  -- which results in an epsilon production.-  -> Pinchot t (Rule t)-record name sq = newRule name (RRecord sq)----- | Creates a rule for the production of a sequence of other rules.--- The name for the created 'Rule' is the name of the 'Rule' to which--- this function is applied, with @'Seq@ appended.-list-  :: Rule t-  -- ^ The resulting 'Rule' is a sequence of productions of this-  -- 'Rule'; that is, this 'Rule' may appear zero or more times.--  -> Pinchot t (Rule t)-list r@(Rule inner _ _) = newRule name (RList r)-  where-    name = inner ++ "'Seq"---- | Creates a rule for a production that appears at least once.  The--- name for the created 'Rule' is the name of the 'Rule' to which this--- function is applied, with @'Seq1@ appended.-list1-  :: Rule t-  -- ^ The resulting 'Rule' produces this 'Rule' at least once.-  -> Pinchot t (Rule t)-list1 r@(Rule inner _ _) = newRule name (RList1 r)-  where-    name = inner ++ "'Seq1"---- | Creates a rule for a production that optionally produces another--- rule.  The name for the created 'Rule' is the name of the 'Rule' to--- which this function is applied, with @'Maybe@ appended to the end.-option-  :: Rule t-  -- ^ The resulting 'Rule' optionally produces this 'Rule'; that is,-  -- this 'Rule' may appear once or not at all.--  -> Pinchot t (Rule t)-option r@(Rule inner _ _) = newRule name (ROptional r)-  where-    name = inner ++ "'Maybe"---- | Creates a newtype wrapper.--wrap-  :: RuleName-  -> Rule t-  -- ^ The resulting 'Rule' simply wraps this 'Rule'.-  -> Pinchot t (Rule t)-wrap name r = newRule name (RWrap r)---- | Gets all ancestor 'Rule's.  Skips duplicates.-getAncestors-  :: Rule t-  -> State (Set String) (Seq (Rule t))-getAncestors r@(Rule name _ ei) = do-  set <- get-  if Set.member name set-    then return Seq.empty-    else do-      put (Set.insert name set)-      case ei of-        RTerminal _ -> return (Seq.singleton r)-        RBranch (b1, bs) -> do-          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-          return $ r <| cs-        RList c -> do-          cs <- getAncestors c-          return $ r <| cs-        RList1 c -> do-          cs <- getAncestors c-          return $ r <| cs-        RWrap c -> do-          cs <- getAncestors c-          return $ r <| cs-        RRecord ls -> do-          cs <- fmap join . mapM getAncestors $ ls-          return $ r <| cs-  where-    branchAncestors (Branch _ rs) = fmap join . mapM getAncestors $ rs---- | Returns both this 'Rule' and any 'Rule's that are ancestors.-ruleAndAncestors-  :: Rule t-  -> Seq (Rule t)-ruleAndAncestors r = fst $ runState (getAncestors r) Set.empty---- | Given a sequence of 'Rule', determine which rules are on a--- right-hand side before they are defined.-rulesDemandedBeforeDefined :: Foldable f => f (Rule t) -> Set Name-rulesDemandedBeforeDefined = snd . foldl f (Set.empty, Set.empty)-  where-    f (lhsDefined, results) (Rule nm _ ty)-      = (Set.insert nm lhsDefined, results')-      where-        results' = case ty of-          RTerminal _ -> results-          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-          RList1 r -> addHelper $ checkRule r results-          RWrap r -> checkRule r results-          RRecord sq -> foldr checkRule results $ sq-        checkRule (Rule name _ _) rslts-          | Set.member name lhsDefined = rslts-          | otherwise = Set.insert (ruleName name) rslts-        addHelper = Set.insert (helperName nm)-  --thBranch :: Branch t -> ConQ-thBranch (Branch nm rules) = normalC name fields-  where-    name = mkName nm-    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-  => Bool-  -- ^ If True, make lenses.-  -> Name-  -- ^ Name of terminal type-  -> Seq Name-  -- ^ What to derive-  -> Rule t-  -> TH.Q [TH.Dec]-thRule doLenses typeName derives (Rule nm _ ruleType) = do-  ty <- makeType typeName derives nm ruleType-  lenses <- if doLenses then ruleToOptics typeName nm ruleType-    else return []-  inst <- productionDecl nm typeName ruleType-  return (ty : inst ++ lenses)---makeType-  :: Name-  -- ^ Name of terminal type-  -> Seq Name-  -- ^ What to derive-  -> String-  -- ^ Name of rule-  -> RuleType t-  -> TH.Q TH.Dec-makeType typeName derivesSeq nm ruleType = case ruleType of-  RTerminal _ -> newtypeD (cxt []) name [] newtypeCon derives-    where-      newtypeCon = normalC name-        [strictType notStrict (conT typeName)]--  RBranch (b1, bs) -> dataD (cxt []) name [] cons derives-    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-        [strictType notStrict (appT [t| Seq |]-                                    (conT typeName))]--  ROptional (Rule inner _ _) -> newtypeD (cxt []) name [] newtypeCon derives-    where-      newtypeCon = normalC name-        [strictType notStrict (appT [t| Maybe |]-                                    (conT (mkName inner)))]--  RList (Rule inner _ _) -> newtypeD (cxt []) name [] newtypeCon derives-    where-      newtypeCon = normalC name-        [strictType notStrict (appT [t| Seq |]-                                    (conT (mkName inner)))]--  RList1 (Rule inner _ _) -> newtypeD (cxt []) name [] cons derives-    where-      cons = normalC name-        [ strictType notStrict (TH.tupleT 2 `appT` (conT (mkName inner))-            `appT` ([t| Seq |] `appT` (conT (mkName inner)))) ]--  RWrap (Rule inner _ _) -> newtypeD (cxt []) name [] newtypeCon derives-    where-      newtypeCon = normalC name-        [ strictType notStrict (conT (mkName inner)) ]--  RRecord sq -> dataD (cxt []) name [] [ctor] derives-    where-      ctor = recC name . zipWith mkField [(0 :: Int) ..] . toList $ sq-      mkField num (Rule rn _ _) = varStrictType (mkName fldNm)-        (strictType notStrict (conT (mkName rn)))-        where-          fldNm = '_' : fieldName num nm rn--  where-    name = mkName nm-    derives = toList derivesSeq---- | Field name - without a leading underscore-fieldName-  :: Int-  -- ^ Index-  -> String-  -- ^ Parent type name-  -> String-  -- ^ Inner type name-  -> String-fieldName idx par inn = "r'" ++ par ++ "'" ++ show idx ++ "'" ++ inn--thAllRules-  :: Syntax.Lift t-  => Bool-  -- ^ If True, make optics as well.-  -> Name-  -- ^ Terminal type constructor name-  -> Seq Name-  -- ^ What to derive-  -> Map Int (Rule t)-  -> DecsQ-thAllRules doOptics typeName derives-  = fmap join-  . sequence-  . fmap (thRule doOptics typeName derives)-  . fmap snd-  . M.toAscList--makeWrapped-  :: TH.Type-  -- ^ Name of wrapped type-  -> String-  -- ^ Name of wrapper type-  -> TH.Dec-makeWrapped wrappedType nm = TH.InstanceD [] typ decs-  where-    name = TH.mkName nm-    local = mkName "_x"-    typ = (TH.ConT ''Lens.Wrapped) `TH.AppT` (TH.ConT name)-    decs = [assocType, wrapper]-      where-        assocType = TH.TySynInstD ''Lens.Unwrapped-          (TH.TySynEqn [TH.ConT name] wrappedType)-        wrapper = TH.FunD 'Lens._Wrapped-          [TH.Clause [] (TH.NormalB body) []]-          where-            body = (TH.VarE 'Lens.iso)-              `TH.AppE` unwrap-              `TH.AppE` doWrap-              where-                unwrap = TH.LamE [lambPat] (TH.VarE local)-                  where-                    lambPat = TH.ConP name [TH.VarP local]-                doWrap = TH.LamE [lambPat] expn-                  where-                    expn = (TH.ConE name)-                      `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-  -- ^ Terminal type name-  -> String-  -- ^ Rule name-  -> Seq t-  -> TH.Q [TH.Dec]-seqTermToOptics termName nm sq = do-  e1 <- TH.sigD (TH.mkName ('_':nm)) (TH.conT ''Lens.Prism'-    `TH.appT` (TH.conT ''Seq `TH.appT` TH.conT termName)-    `TH.appT` TH.conT (TH.mkName nm))-  e2 <- TH.valD prismName (TH.normalB expn) []-  return [e1, e2]-  where-    prismName = TH.varP (TH.mkName ('_' : nm))-    fetchPat = TH.conP (TH.mkName nm) [TH.varP (TH.mkName "_x")]-    fetchName = TH.varE (TH.mkName "_x")-    ctor = TH.conE (TH.mkName nm)-    expn = [| let fetch $fetchPat = $fetchName-                  store _term-                    | $(liftSeq sq) == _term = Right ($ctor _term)-                    | otherwise = Left _term-              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-  -- ^ Terminal type name-  -> String-  -- ^ Rule name-  -> Intervals t-  -> TH.Q [TH.Dec]-terminalToOptics termName nm ivls = do-  e1 <- TH.sigD (TH.mkName ('_':nm)) (TH.conT ''Lens.Prism'-        `TH.appT` TH.conT termName-        `TH.appT` TH.conT (TH.mkName nm))-  e2 <- TH.valD prismName (TH.normalB expn) []-  return [e1, e2]-  where-    prismName = TH.varP (TH.mkName ('_' : nm))-    fetchPat = TH.conP (TH.mkName nm) [TH.varP (TH.mkName "_x")]-    fetchName = TH.varE (TH.mkName "_x")-    ctor = TH.conE (TH.mkName nm)-    expn = [| let fetch $fetchPat = $fetchName-                  store _term-                    | inIntervals ivls _term = Right ($ctor _term)-                    | otherwise = Left _term-              in Lens.prism fetch store-           |]-    --optionalToOptics-  :: String-  -- ^ Wrapped rule name-  -> String-  -- ^ Wrapping Rule name-  -> TH.Dec-optionalToOptics wrappedName = makeWrapped maybeName-  where-    maybeName = (TH.ConT ''Maybe) `TH.AppT` (TH.ConT (TH.mkName wrappedName))--many1ToOptics-  :: String-  -- ^ Wrapped rule name-  -> String-  -- ^ Wrapping Rule name-  -> TH.Dec-many1ToOptics wrappedName = makeWrapped tupName-  where-    tupName = (TH.TupleT 2)-      `TH.AppT` (TH.ConT (TH.mkName wrappedName))-      `TH.AppT` ((TH.ConT ''Seq) `TH.AppT` (TH.ConT (TH.mkName wrappedName)))--manyToOptics-  :: String-  -- ^ Wrapped rule name-  -> String-  -- ^ Wrapping Rule name-  -> TH.Dec-manyToOptics wrappedName = makeWrapped innerName-  where-    innerName = (TH.ConT ''Seq) `TH.AppT` (TH.ConT (TH.mkName wrappedName))--wrapToOptics-  :: String-  -- ^ Wrapped rule name-  -> String-  -- ^ Wrapping Rule name-  -> TH.Dec-wrapToOptics wrappedName = makeWrapped innerName-  where-    innerName = TH.ConT (TH.mkName wrappedName)--terminalSeqToOptics-  :: Name-  -- ^ Terminal type name-  -> String-  -- ^ Rule name-  -> TH.Dec-terminalSeqToOptics terminalName = makeWrapped sqType-  where-    sqType = (TH.ConT ''Seq) `TH.AppT` (TH.ConT terminalName)--branchesToOptics-  :: String-  -- ^ Rule name-  -> Branch t-  -> Seq (Branch t)-  -> [TH.Dec]-branchesToOptics nm b1 bsSeq = concat $ makePrism b1 : fmap makePrism bs-  where-    bs = toList bsSeq-    makePrism (Branch inner rulesSeq) = [ signature, binding ]-      where-        rules = toList rulesSeq-        prismName = TH.mkName ('_' : inner)-        signature = TH.SigD prismName-          $ (TH.ConT ''Lens.Prism')-          `TH.AppT` (TH.ConT (TH.mkName nm))-          `TH.AppT` fieldsType-          where-            fieldsType = case rules of-              [] -> TH.TupleT 0-              Rule r1 _ _ : [] -> TH.ConT (TH.mkName r1)-              rs -> foldl addType (TH.TupleT (length rs)) rs-                where-                  addType soFar (Rule r _ _) = soFar `TH.AppT`-                    (TH.ConT (TH.mkName r))-        binding = TH.ValD (TH.VarP prismName) body []-          where-            body = TH.NormalB-              $ (TH.VarE 'Lens.prism)-              `TH.AppE` setter-              `TH.AppE` getter-              where-                setter = TH.LamE [pat] expn-                  where-                    (pat, expn) = case rules of-                      [] -> (TH.TupP [], TH.ConE (TH.mkName inner))-                      _ : [] -> (TH.VarP local,-                        TH.ConE (TH.mkName inner)-                        `TH.AppE` TH.VarE local)-                        where-                          local = TH.mkName "_x"-                      ls -> (TH.TupP pats, set)-                        where-                          pats = fmap (\i -> TH.VarP (mkName ("_x" ++ show i)))-                            . take (length ls) $ [(0 :: Int) ..]-                          set = foldl addVar start . take (length ls)-                            $ [(0 :: Int) ..]-                            where-                              addVar acc i = acc `TH.AppE`-                                (TH.VarE (TH.mkName ("_x" ++ show i)))-                              start = TH.ConE (TH.mkName inner)--                getter = TH.LamE [pat] expn-                  where-                    local = TH.mkName "_x"-                    pat = TH.VarP local-                    expn = TH.CaseE (TH.VarE (TH.mkName "_x")) $-                      TH.Match patCtor bodyCtor []-                      : rest-                      where-                        patCtor = TH.ConP (TH.mkName inner)-                          . fmap (\i -> TH.VarP (TH.mkName $ "_y" ++ show i))-                          . take (length rules)-                          $ [(0 :: Int) ..]-                        bodyCtor = TH.NormalB . (TH.ConE 'Right `TH.AppE`)-                          $ case rules of-                          [] -> TH.TupE []-                          _:[] -> TH.VarE (TH.mkName "_y0")-                          _ -> TH.TupE-                            . fmap (\i -> TH.VarE (TH.mkName $ "_y" ++ show i))-                            . take (length rules)-                            $ [(0 :: Int) ..]-                        rest = case bs of-                          [] -> []-                          _ -> [TH.Match patBlank bodyBlank []]-                          where-                            patBlank = TH.VarP (TH.mkName "_z")-                            bodyBlank = TH.NormalB-                              $ 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-  -- ^ Rule name-  -> Seq (Rule t)-  -> [TH.Dec]-recordsToOptics nm-  = concat . zipWith makeLens [(0 :: Int) ..] . toList-  where-    makeLens index (Rule inner _ _) = [ signature, function ]-      where-        fieldNm = fieldName index nm inner-        lensName = mkName fieldNm-        signature = TH.SigD lensName-          $ (TH.ConT ''Lens.Lens')-          `TH.AppT` (TH.ConT (TH.mkName nm))-          `TH.AppT` (TH.ConT (TH.mkName inner))--        function = TH.FunD lensName [TH.Clause [] (TH.NormalB body) []]-          where-            namedRec = TH.mkName "_namedRec"-            namedNewVal = TH.mkName "_namedNewVal"-            body = (TH.VarE 'Lens.lens) `TH.AppE` getter `TH.AppE` setter-              where-                getter = TH.LamE [pat] expn-                  where-                    pat = TH.VarP namedRec-                    expn = (TH.VarE (TH.mkName ('_' : fieldNm)))-                      `TH.AppE` (TH.VarE namedRec)--                setter = TH.LamE [patRec, patNewVal] expn-                  where-                    patRec = TH.VarP namedRec-                    patNewVal = TH.VarP namedNewVal-                    expn = TH.RecUpdE (TH.VarE namedRec)-                      [ (TH.mkName ('_' : fieldNm), TH.VarE namedNewVal) ]---ruleToOptics-  :: Syntax.Lift t-  => Name-  -- ^ Terminal type name-  -> String-  -- ^ Rule name-  -> RuleType t-  -> TH.DecsQ-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]-  RList1 (Rule inner _ _) -> return [many1ToOptics inner nm]-  RWrap (Rule inner _ _) -> return [wrapToOptics inner nm]-  RRecord recs -> return $ recordsToOptics nm recs---- | Should optics be made?-type MakeOptics = Bool---- | Creates optics.------ If you use this option, you will need--- @--- \{\-\# LANGUAGE TypeFamilies \#\-\}--- @------ at the top of the module into which you splice in the--- declarations, because you will get instances of 'Lens.Wrapped'.------ Creates the listed optics for each kind of--- 'Rule', as follows:------ * 'terminal': @'Lens.Prism'' a b@, where @a@ is the type of the--- terminal token (often 'Char') and @b@ is the type of this--- particular production.  For an example, see--- 'Pinchot.Examples.PostalAstAllRules._Comma'.------ >>> ',' ^? _Comma--- Just (Comma ',')--- >>> 'a' ^? _Comma--- Nothing--- >>> Comma ',' ^. re _Comma--- ','------ Thus this gives you a safe way to insert tokens into types made--- with 'terminal' (useful if you want to construct a syntax tree.)------ * 'terminalSeq': @'Lens.Prism'' ('Seq' a) b@, where @a@ is the type--- of the terminal token (often 'Char') and @b@ is the type of this--- particular production.  As with 'terminal' this gives you a safe--- way to insert values into the types made with 'terminalSeq'.------ * 'nonTerminal': one 'Lens.Prism'' for each data constructor (even if--- there is only one data constructor)------ * 'union': one 'Lens.Prism' for each data constructor (even if--- there is only one data constructor)------ * 'record': one 'Lens.Lens' for each field------ * 'list': 'Lens.Wrapped', wrapping a @'Seq' a@------ * 'list1': 'Lens.Wrapped', wrapping a pair @(a, 'Seq' a)@------ * 'option': 'Lens.Wrapped', wrapping a @'Maybe' a@------ * 'wrap': 'Lens.Wrapped', wrapping the underlying type-makeOptics :: MakeOptics-makeOptics = True---- | Do not make any optics.-noOptics :: MakeOptics-noOptics = False---- | Creates data types for every 'Rule' created in the 'Pinchot'.  The data--- types are created in the same order in which they were created in--- the 'Pinchot'.  When spliced, the 'DecsQ' is a list of--- declarations, each of which is an appropriate @data@ or @newtype@.--- For an example use of 'allRulesToTypes', see--- "Pinchot.Examples.PostalAstAllRules".------ Also creates bindings whose names are prefixed with @t'@.  Each--- of these is a function that, when given a particular production,--- reduces it to a sequence of terminal symbols.--allRulesToTypes-  :: Syntax.Lift t-  => MakeOptics--  -> Name-  -- ^ Terminal type constructor name.  Typically you will use the-  -- Template Haskell quoting mechanism to get this.--  -> Seq Name-  -- ^ What to derive.  For instance, you might use @Eq@, @Ord@, and-  -- @Show@ here.  Each created data type will derive these instances.--  -> Pinchot t a-  -- ^ The return value from the 'Pinchot' is ignored.--  -> DecsQ-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.------ Also creates bindings whose names are prefixed with @t'@.  Each--- of these is a function that, when given a particular production,--- reduces it to a sequence of terminal symbols.-ruleTreeToTypes-  :: Syntax.Lift t-  => MakeOptics--  -> Name-  -- ^ Terminal type constructor name.  Typically you will use the-  -- Template Haskell quoting mechanism to get this.--  -> Seq Name-  -- ^ What to derive.  For instance, you might use @Eq@, @Ord@, and-  -- @Show@ here.  Each created data type will derive these instances.--  -> Pinchot t (Rule t)-  -- ^ 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 = 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--addPrefix-  :: String-  -> String-  -> String-addPrefix pfx suf-  | null pfx = suf-  | otherwise = pfx ++ '.':suf--ruleToParser-  :: Syntax.Lift t-  => String-  -- ^ Module prefix-  -> Rule t-  -> [(Name, ExpQ)]-ruleToParser prefix (Rule nm mayDescription rt) = case rt of--  RTerminal ivls -> [makeRule expression]-    where-      expression = [| fmap $constructor (satisfy (inIntervals ivls)) |]--  RBranch (b1, bs) -> [makeRule expression]-    where-      expression = foldl addBranch (branchToParser prefix b1) bs-        where-          addBranch tree branch =-            [| $tree <|> $(branchToParser prefix branch) |]--  RUnion (Rule r1 _ _, rs) -> [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 -> [nestRule, topRule]-    where-      nestRule = (helper, [| rule $(foldl addTerm start sq) |])-        where-          start = [|pure Seq.empty|]-          addTerm acc x = [| liftA2 (<|) (symbol x) $acc |]-      topRule = makeRule (wrapper helper)--  ROptional (Rule innerNm _ _) -> [makeRule expression]-    where-      expression = [| fmap $constructor (pure Nothing <|> $(just)) |]-        where-          just = [| fmap Just $(varE (ruleName innerNm)) |]--  RList (Rule innerNm _ _) -> [nestRule, makeRule (wrapper helper)]-    where-      nestRule = (helper, ([|rule|] `appE` parseSeq))-        where-          parseSeq = uInfixE [|pure Seq.empty|] [|(<|>)|] pSeq-            where-              pSeq = [|liftA2 (<|) $(varE (ruleName innerNm)) $(varE helper) |]--  RList1 (Rule innerNm _ _) -> [nestRule, makeRule topExpn]-    where-      nestRule = (helper, [|rule $(parseSeq)|])-        where-          parseSeq = [| pure Seq.empty <|> $pSeq |]-            where-              pSeq = [| (<|) <$> $(varE (ruleName innerNm))-                             <*> $(varE helper) |]-      topExpn = [| $constructor <$> ( (,) <$> $(varE (ruleName innerNm))-                                        <*> $(varE helper)-                                    ) |]--  RWrap (Rule innerNm _ _) -> [makeRule expression]-    where-      expression = [|fmap $constructor $(varE (ruleName innerNm)) |]--  RRecord sq -> [makeRule expression]-    where-      expression = case viewl sq of-        EmptyL -> [| pure $constructor |]-        Rule r1 _ _ :< restFields -> foldl addField fstField restFields-          where-            fstField = [| $constructor <$> $(varE (ruleName r1)) |]-            addField soFar (Rule r _ _)-              = [| $soFar <*> $(varE (ruleName r)) |]-    --  where-    makeRule expression = (ruleName nm,-      [|rule ($expression Text.Earley.<?> $(textToExp desc))|])-    desc = maybe nm id mayDescription-    textToExp txt = [| $(Syntax.lift txt) |]-    constructor = constructorName prefix nm-    wrapper wrapRule = [|fmap $constructor $(varE wrapRule) |]-    helper = helperName nm---constructorName-  :: String-  -- ^ Module prefix-  -> String-  -- ^ Name of constructor-  -> ExpQ-constructorName pfx nm = conE (mkName name)-  where-    name = pfx' ++ nm-    pfx'-      | null pfx = ""-      | otherwise = pfx ++ "."--ruleName :: String -> Name-ruleName suffix = mkName ("_rule'" ++ suffix)--helperName :: String -> Name-helperName suffix = mkName ("_helper'" ++ suffix)--branchToParser-  :: Syntax.Lift t-  => String-  -- ^ Module prefix-  -> Branch t-  -> ExpQ-branchToParser prefix (Branch name rules) = case viewl rules of-  EmptyL -> [| pure $constructor |]-  (Rule rule1 _ _) :< xs -> foldl f z xs-    where-      z = [| $constructor <$> $(varE (ruleName rule1)) |]-      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.  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-  -> Q Pat-lazyPattern = finish . foldr gen [p| () |]-  where-    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-  => 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 = [| ( $(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--- "Pinchot.Examples.PostalAstRuleTree" and for--- "Pinchot.Examples.PostalAstAllRules".--earleyGrammar-  :: Syntax.Lift t--  => 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-  -- @'Text.Earley.Grammar' r ('Text.Earley.Prod' r 'String' t a)@-  ---  -- where-  -- -  -- @r@ is left universally quantified-  ---  -- @t@ is the type of the token (usually 'Char')-  ---  -- @a@ is the type defined by the 'Rule'.-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-    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-  => String-  -- ^ Module prefix-  -> Rule t-  -> Q Exp-earleyGrammarFromRule prefix r@(Rule top _ _) = recursiveDo binds final-  where-    binds = concatMap (ruleToParser prefix) . toList . ruleAndAncestors $ r-    final = [| return $(TH.varE $ ruleName top) |]---- | Creates an Earley grammar for each 'Rule' created in a--- '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--  => 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-  -- ignored.--  -> DecsQ-  -- ^ When spliced, this is a list of declarations.  Each-  -- declaration has type-  -- @'Text.Earley.Grammar' r ('Text.Earley.Prod' r 'String' t a)@-  ---  -- where-  -- -  -- @r@ is left universally quantified-  ---  -- @t@ is the type of the token (usually 'Char')-  ---  -- @a@ is the type defined by the 'Rule'.-  ---  -- The name of each declaration is-  -- g'TYPE_NAME-  ---  -- where TYPE_NAME is the name of the type defined in the-  -- corresponding 'Rule'.-allEarleyGrammars prefix termName pinc = do-  st <- fmap fst $ goPinchot pinc-  sequence . concat . fmap makeDecl . fmap snd . M.toList-    . allRules $ st-  where-    makeDecl rule@(Rule nm _ _) = [signature, TH.valD pat body []]-      where-        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-prodDeclName name = TH.mkName $ "t'" ++ name--prodFn :: String -> TH.ExpQ-prodFn = TH.varE . prodDeclName--addIndices :: Foldable c => c a -> [(Int, a)]-addIndices = zip [0..] . toList---- | Creates a production declaration for a 'Rule'.-productionDecl-  :: String-  -- ^ Rule name-  -> Name-  -- ^ Name of terminal type-  -> RuleType t-  -> 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-          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 []]-        where-          pat = TH.conP (TH.mkName n) [TH.varP (TH.mkName "_x")]-          bdy = TH.normalB (dyn "_x")--      ROptional (Rule inner _ _) -> [justClause, nothingClause]-        where-          justClause-            = TH.clause [TH.conP (TH.mkName n)-                [TH.conP 'Just [TH.varP (TH.mkName "_b")]]]-                (TH.normalB [| $(prodFn inner)-                               $(TH.varE (TH.mkName "_b")) |])-                []-          nothingClause-            = TH.clause [TH.conP (TH.mkName n)-                [TH.conP 'Nothing []]]-                (TH.normalB [| Seq.empty |]) []--      RList (Rule inner _ _) -> [TH.clause [pat] bdy []]-        where-          pat = TH.conP (TH.mkName n) [TH.varP (TH.mkName "_a")] -          bdy = TH.normalB [| join-            $ fmap $(prodFn inner) $(TH.varE (TH.mkName "_a")) |]--      RList1 (Rule inner _ _) -> [TH.clause [pat] bdy []]-        where-          pat = TH.conP (TH.mkName n)-            [TH.tupP [ dynP "_x1", dynP "_xs" ]]-          bdy = TH.normalB-            [| $lft `mappend` (join (fmap $(prodFn inner)-                $(dyn "_xs"))) |]-            where-              lft = [| $(prodFn inner) $(dyn "_x1") |]--      RWrap (Rule inner _ _) -> [TH.clause [pat] bdy []]-        where-          pat = TH.conP (TH.mkName n) [dynP "_x"]-          bdy = TH.normalB [| $(prodFn inner) $(dyn "_x") |]--      RRecord sq -> [TH.clause [pat] (TH.normalB bdy) []]-        where-          pat = TH.conP (TH.mkName n) . fmap mkPat-            . fmap fst . addIndices $ sq-            where-              mkPat idx = dynP ("_x'" ++ show idx)-          bdy = foldr addField [| Seq.empty |] . addIndices $ sq-            where-              addField (idx, (Rule nm _ _)) acc = [| $this `mappend` $acc |]-                where-                  this = [| $(prodFn nm) $(dyn ("_x'" ++ show idx)) |]--      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 [| $(prodFn inner) $(dyn "_x") |]---branchToClause :: Branch t -> TH.ClauseQ-branchToClause (Branch n rs) = TH.clause [pat] bdy []-  where-    pat = TH.conP (TH.mkName n) fields-      where-        fields = fmap mkField . fmap fst . addIndices $ rs-          where-            mkField idx = TH.varP (TH.mkName ("_x'" ++ show idx))-    bdy = TH.normalB [| join $sq |]-      where-        sq = foldr addField (TH.varE 'Seq.empty) . addIndices $ rs-          where-            addField (idx, (Rule inner _ _)) acc = [| $newTerm <| $acc |]-              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

@@ -1,3 +1,4 @@+{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE TemplateHaskell #-} @@ -6,6 +7,7 @@ -- usually need. module Pinchot.Intervals where +import qualified Control.Lens as Lens import Control.Monad (join) import Data.Monoid ((<>)) import Data.Ord (comparing)@@ -19,17 +21,19 @@ -- 'mappend', which will combine both the included and excluded -- terminal symbols from each operand. data Intervals a = Intervals-  { included :: Seq (a, a)+  { _included :: Seq (a, a)   -- ^ Each pair @(a, b)@ is an inclusive range of terminal symbols,   -- in order.  For instance, @('a', 'c')@ includes the characters   -- @'a'@, @'b'@, and @'c'@.  The 'included' sequence contains all   -- terminals that are included in the 'Intervals', except for those   -- that are 'excluded'.-  , excluded :: Seq (a, a)+  , _excluded :: Seq (a, a)   -- ^ Each symbol in 'excluded' is not in the 'Intervals', even if   -- the symbol is 'included'.   } deriving (Eq, Ord, Show) +Lens.makeLenses ''Intervals+ instance Functor Intervals where   fmap f (Intervals a b) = Intervals (fmap g a) (fmap g b)     where@@ -42,7 +46,7 @@  -- | Include a range of symbols in the 'Intervals'.  For instance, to -- include the characters @'a'@, @'b'@, and @'c'@, use @include 'a'--- 'c'@.+-- 'c'@.  Example: 'Pinchot.Examples.Postal.rLetter'. include :: a -> a -> Intervals a include l h = Intervals [(l, h)] [] @@ -52,7 +56,8 @@ exclude :: a -> a -> Intervals a exclude l h = Intervals [] [(l, h)] --- | Include a single symbol.+-- | Include a single symbol.  Example:+-- 'Pinchot.Examples.Postal.rNorth'. solo :: a -> Intervals a solo x = Intervals [(x, x)] [] 

@@ -0,0 +1,59 @@+{-# OPTIONS_HADDOCK not-home #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+module Pinchot.Locator where++import Pinchot.Types++import qualified Data.ListLike as ListLike+import Data.Sequence (Seq, (|>))+import qualified Data.Sequence as Seq+import qualified Text.Earley as Earley++-- | Advances the location for 'Char' values.  Tabs advance to the+-- next eight-column tab stop; newlines advance to the next line and+-- reset the column number to 1.  All other characters advance the+-- column by 1.+advanceChar :: Char -> Loc -> Loc+advanceChar c (Loc !lin !col !pos)+  | c == '\n' = Loc (lin + 1) 1 (pos + 1)+  | c == '\t' = Loc lin (col + 8 - ((col - 1) `mod` 8)) (pos + 1)+  | otherwise = Loc lin (col + 1) (pos + 1)++-- | Takes any ListLike value based on 'Char' (@Seq@, @Text@,+-- @String@, etc.) and creates a 'Seq' which pairs each 'Char' with+-- its location.  Example: 'locatedFullParses'.+locations+  :: ListLike.FoldableLL full Char+  => full+  -> Seq (Char, Loc)+locations = fst . ListLike.foldl' f (Seq.empty, Loc 1 1 1)+  where+    f (!sq, !loc) c = (sq |> (c, loc), advanceChar c loc)++-- | Breaks a ListLike into a 'Seq' but does not assign locations.+noLocations+  :: ListLike.FoldableLL full item+  => full+  -> Seq (item, ())+noLocations = ListLike.foldl' f Seq.empty+  where+    f !sq c = sq |> (c, ())++-- | Obtains all full Earley parses from a given input string, after+-- assigning a location to every 'Char'.  Example:+-- 'Pinchot.Examples.Newman.address'.+locatedFullParses+  :: ListLike.FoldableLL full Char+  => (forall r. Earley.Grammar r (Earley.Prod r String (Char, Loc) (p Char Loc)))+  -- ^ Earley grammar with production that you want to parse.+  -> full+  -- ^ Source text, e.g. 'String', 'Data.Text', etc.+  -> ([p Char Loc], Earley.Report String (Seq (Char, Loc)))+  -- ^ A list of successful parses that when to the end of the+  -- source string, along with the Earley report showing possible+  -- errors.+locatedFullParses g+  = Earley.fullParses (Earley.parser g)+  . locations

@@ -0,0 +1,61 @@+{-# OPTIONS_HADDOCK not-home #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+-- | Sequences that always contain at least one element.++module Pinchot.NonEmpty where++import Control.Monad (join, ap)+import Data.Sequence (Seq, (<|))+import qualified Data.Sequence as Seq+import qualified Control.Lens as Lens++-- | A non-empty sequence.+data NonEmpty a = NonEmpty+  { _front :: a+  -- ^ The first item+  , _rest :: Seq a+  -- ^ All remaining items+  } deriving (Eq, Ord, Show, Functor, Foldable, Traversable)++Lens.makeLenses ''NonEmpty++-- | Convert a 'NonEmpty' to a 'Seq'.+flatten :: NonEmpty a -> Seq a+flatten (NonEmpty a as) = a <| as++instance Monad NonEmpty where+  return a = NonEmpty a Seq.empty+  NonEmpty a as >>= f = NonEmpty (_front r1) rs+    where+      r1 = f a+      rs = _rest r1 `mappend` rss+      rss = join . fmap flatten . fmap f $ as++instance Applicative NonEmpty where+  pure = return+  (<*>) = ap++-- | Converts a non-empty 'Seq' to a 'NonEmpty'; 'Nothing' if the+-- 'Seq' is empty.+seqToNonEmpty :: Seq a -> Maybe (NonEmpty a)+seqToNonEmpty = fmap (uncurry NonEmpty) . Lens.uncons++-- | Prepends a 'Seq' to a 'NonEmpty'.+prependSeq :: Seq a -> NonEmpty a -> NonEmpty a+prependSeq sq (NonEmpty a as) = case Lens.uncons sq of+  Nothing -> NonEmpty a as+  Just (l, ls) -> NonEmpty l (ls `mappend` (a <| as))++-- | Appends a 'Seq' to a 'NonEmpty'.+appendSeq :: NonEmpty a -> Seq a -> NonEmpty a+appendSeq (NonEmpty a as) sq = NonEmpty a (as `mappend` sq)++-- | Associative operation that appends to 'NonEmpty'.+append :: NonEmpty a -> NonEmpty a -> NonEmpty a+append (NonEmpty l1 ls) (NonEmpty r1 rs)+  = NonEmpty l1 (ls `mappend` (r1 <| rs))++-- | Place a single item at the head of the 'NonEmpty'.+singleton :: a -> NonEmpty a+singleton a = NonEmpty a Seq.empty

@@ -0,0 +1,76 @@+{-# OPTIONS_HADDOCK not-home #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Emulating recursive do notation, as TH does not support it.+module Pinchot.RecursiveDo where++import Control.Monad.Fix (mfix)+import qualified Language.Haskell.TH as T++-- | Creates a lazy pattern for all the given names.  Adds an empty+-- 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 T.Name+  -> T.Q T.Pat+lazyPattern = finish . foldr gen [p| () |]+  where+    gen name rest = [p| ($(T.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+  => T.ExpQ+  -- ^ This expression will be the first one in the tuple.+  -> c T.ExpQ+  -- ^ Remaining expressions in the tuple.+  -> T.ExpQ+bigTuple top = finish . foldr f [| () |]+  where+    f n rest = [| ( $(n), $rest) |]+    finish tup = [| ($(top), $tup) |]++-- | Builds a recursive @do@ expression (because TH has no support+-- for @mdo@ notation).+recursiveDo+  :: [(T.Name, T.ExpQ)]+  -- ^ Binding statements+  -> T.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.+  -> T.ExpQ+  -- ^ Returns an expression whose value is the final return value+  -- from the @do@ block.+recursiveDo binds final = [| fmap fst $ mfix $(fn) |]+  where+    fn = [| \ $(lazyPattern (fmap fst binds)) -> $doBlock |]+    doBlock = T.doE (bindStmts ++ returnStmts)+    bindStmts = map mkBind binds+      where+        mkBind (name, exp)+          = T.bindS (T.varP name) exp+    returnStmts = [bindRtnVal, returner]+      where+        rtnValName = T.mkName "_returner"+        bindRtnVal = T.bindS (T.varP rtnValName) final+        returner+          = T.noBindS+            [| return $(bigTuple (T.varE rtnValName) +                                 (fmap (T.varE . fst) binds)) |]+

@@ -0,0 +1,223 @@+{-# OPTIONS_HADDOCK not-home #-}+{-# LANGUAGE OverloadedLists #-}+module Pinchot.Rules where++import qualified Control.Lens as Lens+import Control.Monad (join)+import Control.Monad.Trans.State (get, put, State)+import qualified Control.Monad.Trans.State as State+import Data.Monoid ((<>))+import Data.Sequence (Seq, (<|))+import qualified Data.Sequence as Seq+import Data.Set (Set)+import qualified Data.Set as Set++import Pinchot.Types+import Pinchot.Intervals++-- | Name a 'Rule' for use in error messages.  If you do not name a+-- rule using this combinator, the rule's type name will be used in+-- error messages.+label :: Rule t -> String -> Rule t+label (Rule n _ t) s = Rule n (Just s) t++-- | Infix synonym for 'label'.  Example:+-- 'Pinchot.Examples.Postal.rDigit'.+(<?>) :: Rule t -> String -> Rule t+(<?>) = label+infixr 0 <?>++-- | Constructs a 'Rule' with no description.+rule :: RuleName -> RuleType t -> Rule t+rule n = Rule n Nothing++-- | Creates a terminal production rule.  Example:+-- 'Pinchot.Examples.Postal.rLetter'.+terminal+  :: RuleName+  -> Intervals t+  -- ^ Valid terminal symbols+  -> Rule t+terminal n i = rule n (Terminal i)++-- | Creates a non-terminal production rule.  This is the most+-- flexible way to create non-terminals.  You can even create a+-- non-terminal that depends on itself.  Example:+-- 'Pinchot.Examples.Postal.rLetters'.++nonTerminal+  :: RuleName+  -- ^ Will be used for the name of the resulting type+  -> Seq (BranchName, Seq (Rule t))+  -- ^ Branches of the non-terminal production rule.  This 'Seq'+  -- must have at least one element; otherwise, an error will+  -- result.+  -> Rule t+nonTerminal n branches = case Lens.uncons branches of+  Nothing -> error $ "nonTerminal: rule has no branches: " ++ n+  Just (b, bs) -> rule n (NonTerminal (f b) (fmap f bs))+    where+      f = uncurry Branch++-- | Creates a non-terminal production rule where each branch has+-- only one production.  This function ultimately uses+-- 'nonTerminal'.  Each branch is assigned a 'BranchName' that 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.+--+-- Example: 'Pinchot.Examples.Postal.rDirection'.+union+  :: RuleName+  -- ^ Will be used for the name of the resulting type+  -> Seq (Rule t)+  -- ^ List of branches.  There must be at least one branch;+  -- otherwise a compile-time error will occur.+  -> Rule t+union n rs = nonTerminal n (fmap f rs)+  where+    f rule@(Rule branchName _ _)+      = (n ++ '\'' : branchName, Seq.singleton rule)++-- | Creates a production for a sequence of terminals.  Useful for+-- parsing specific words.  Ultimately this is simply a function+-- that creates a 'Rule' using the 'record' function.+--+-- In @terminals n s@, For each 'Char' in the 'String', a 'Rule' is+-- created whose 'RuleName' is @n@ followed by an apostrophe+-- followed by the index of the position of the 'Char'.+--+-- Examples: 'Pinchot.Examples.Postal.rBoulevard'.++terminals+  :: RuleName+  -- ^ Will be used for the name of the resulting type, and for the+  -- name of the sole data constructor+  -> String+  -> Rule Char+terminals n s = record n rules+  where+    rules = Seq.fromList . zipWith mkRule [(0 :: Int) ..] $ s+    mkRule idx char = terminal nm (solo char)+      where+        nm = n ++ ('\'' : show idx)++-- | Creates a newtype wrapper.  Example:+-- 'Pinchot.Examples.Postal.rCity'.+wrap+  :: RuleName+  -- ^ Will be used for the name of the resulting data type, and for+  -- the name of the sole data constructor+  -> Rule t+  -- ^ The resulting 'Rule' simply wraps this 'Rule'.+  -> Rule t+wrap n r = rule n (Wrap r)+++-- | Creates a new non-terminal production rule with only one+-- alternative where each field has a record name.  The name of each+-- record is:+--+-- @_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+-- field itself.+--+-- Currently there is no way to change the names of the record fields.+--+-- Example: 'Pinchot.Examples.Postal.rAddress'.+record+  :: RuleName+  -- ^ The name of this rule, which is used both as the type name+  -- and for the name of the sole data constructor++  -> Seq (Rule t)+  -- ^ The right-hand side of this rule.  This sequence can be empty,+  -- which results in an epsilon production.+  -> Rule t+record n rs = rule n (Record rs)++-- | Creates a rule for a production that optionally produces another+-- rule.  The name for the created 'Rule' is the name of the 'Rule' to+-- which this function is applied, with @'Opt@ appended to the end.+--+-- Example: 'Pinchot.Examples.Postal.rOptNewline'.+opt+  :: Rule t+  -> Rule t+opt r@(Rule innerNm _ _) = rule n (Opt r)+  where+    n = innerNm ++ "'Opt"++-- | Creates a rule for the production of a sequence of other rules.+-- The name for the created 'Rule' is the name of the 'Rule' to which+-- this function is applied, with @'Star@ appended.+--+-- Example: 'Pinchot.Examples.Postal.rPreSpacedWord'.+star+  :: Rule t+  -> Rule t+star r@(Rule innerNm _ _) = rule (innerNm ++ "'Star") (Star r)++-- | Creates a rule for a production that appears at least once.  The+-- name for the created 'Rule' is the name of the 'Rule' to which this+-- function is applied, with @'Plus@ appended.+--+-- Example: 'Pinchot.Examples.Postal.rDigits'.+plus+  :: Rule t+  -> Rule t+plus r@(Rule innerNm _ _) = rule (innerNm ++ "'Plus") (Plus r)++-- | Gets all ancestor rules to this 'Rule'.  Includes the current+-- rule if it has not already been seen.+getAncestors :: Rule t -> State (Set RuleName) (Seq (Rule t))+getAncestors r@(Rule name _ ty) = do+  set <- get+  if Set.member name set+    then return Seq.empty+    else do+      put (Set.insert name set)+      case ty of+        Terminal _ -> return (Seq.singleton r)+        NonTerminal b1 bs -> do+          as1 <- branchAncestors b1+          ass <- fmap join . traverse branchAncestors $ bs+          return $ r <| as1 <> ass+        Wrap c -> do+          cs <- getAncestors c+          return $ r <| cs+        Record ls -> do+          cs <- fmap join . traverse getAncestors $ ls+          return $ r <| cs+        Opt c -> do+          cs <- getAncestors c+          return $ r <| cs+        Star c -> do+          cs <- getAncestors c+          return $ r <| cs+        Plus c -> do+          cs <- getAncestors c+          return $ r <| cs+  where+    branchAncestors (Branch _ rs) = fmap join . traverse getAncestors $ rs++-- | Gets all ancestor 'Rule's.  Includes the current 'Rule'.  Skips+-- duplicates.+family+  :: Rule t+  -> Seq (Rule t)+family rule = State.evalState (getAncestors rule) Set.empty++-- | Gets all the ancestor 'Rule's of a sequence of 'Rule'.  Includes+-- each 'Rule' that is in the sequence.  Skips duplicates.+families+  :: Seq (Rule t)+  -> Seq (Rule t)+families+  = join+  . flip State.evalState Set.empty+  . traverse getAncestors

@@ -0,0 +1,113 @@+{-# OPTIONS_HADDOCK not-home #-}+{-# LANGUAGE TemplateHaskell #-}+-- | Grower - grows the types to hold a syntax tree++module Pinchot.SyntaxTree where++import Data.Foldable (toList)+import Data.Sequence (Seq)+import qualified Language.Haskell.TH as T++import Pinchot.NonEmpty+import Pinchot.Rules+import Pinchot.Types++-- | Makes the top-level declarations for each given 'Rule' and for+-- all ancestors of the given 'Rule's.  Since ancestors are+-- included, you can get the entire tree of types that you need by+-- applying this function to a single start symbol.  Example:+-- "Pinchot.Examples.SyntaxTrees".+syntaxTrees+  :: T.Name+  -- ^ Name of terminal type.  Typically you will get this from the+  -- Template Haskell quoting mechanism, e.g. @''Char@.+  -> [T.Name]+  -- ^ What to derive, e.g. @[''Eq, ''Ord, ''Show]@+  -> Seq (Rule t)+  -> T.DecsQ+syntaxTrees term derives+  = traverse (ruleToType term derives)+  . toList+  . families++branchConstructor :: Branch t -> T.ConQ+branchConstructor (Branch nm rules) = T.normalC name fields+  where+    name = T.mkName nm+    mkField (Rule n _ _) = T.strictType T.notStrict+      [t| $(T.conT (T.mkName n)) $(charTypeVar) $(anyTypeVar) |]+    fields = toList . fmap mkField $ rules+    anyTypeVar = T.varT (T.mkName "a")+    charTypeVar = T.varT (T.mkName "t")++-- | Makes the top-level declaration for a given rule.+ruleToType+  :: T.Name+  -- ^ Name of terminal type+  -> [T.Name]+  -- ^ What to derive+  -> Rule t+  -> T.Q T.Dec+ruleToType typeName derives (Rule nm _ ruleType) = case ruleType of+  Terminal _ ->+    T.newtypeD (T.cxt []) name [charType, anyType] newtypeCon derives+    where+      newtypeCon = T.normalC name+        [T.strictType T.notStrict+          [t| ( $(charTypeVar), $(anyTypeVar) ) |] ]++  NonTerminal b1 bs -> T.dataD (T.cxt []) name [charType, anyType] cons derives+    where+      cons = branchConstructor b1 : toList (fmap branchConstructor bs)++  Wrap (Rule inner _ _) ->+    T.newtypeD (T.cxt []) name [charType, anyType] newtypeCon derives+    where+      newtypeCon = T.normalC name+        [ T.strictType T.notStrict+            [t| $(T.conT (T.mkName inner)) $(charTypeVar) $(anyTypeVar) |] ]++  Record sq -> T.dataD (T.cxt []) name [charType, anyType] [ctor] derives+    where+      ctor = T.recC name . zipWith mkField [(0 :: Int) ..] . toList $ sq+      mkField num (Rule rn _ _) = T.varStrictType (T.mkName fldNm)+        (T.strictType T.notStrict+          [t| $(T.conT (T.mkName rn)) $(charTypeVar) $(anyTypeVar) |])+        where+          fldNm = '_' : recordFieldName num nm rn++  Opt (Rule inner _ _) ->+    T.newtypeD (T.cxt []) name [charType, anyType] newtypeCon derives+    where+      newtypeCon = T.normalC name+        [T.strictType T.notStrict+          [t| Maybe ( $(T.conT (T.mkName inner)) $(charTypeVar)+                                                 $(anyTypeVar)) |]]++  Star (Rule inner _ _) ->+    T.newtypeD (T.cxt []) name [charType, anyType] newtypeCon derives+    where+      newtypeCon = T.normalC name [sq]+        where+          sq = T.strictType T.notStrict+            [t| Seq ( $(T.conT (T.mkName inner)) $(charTypeVar)+                                                 $(anyTypeVar) ) |]++  Plus (Rule inner _ _) ->+    T.newtypeD (T.cxt []) name [charType, anyType] cons derives+    where+      cons = T.normalC name [ne]+        where+          ne = T.strictType T.notStrict [t| NonEmpty $(ins) |]+            where+              ins = [t| $(T.conT (T.mkName inner))+                $(charTypeVar) $(anyTypeVar) |]++  where+    name = T.mkName nm+    anyType = T.PlainTV (T.mkName "a")+    anyTypeVar = T.varT (T.mkName "a")+    charType = T.PlainTV (T.mkName "t")+    charTypeVar = T.varT (T.mkName "t")++

@@ -0,0 +1,246 @@+{-# LANGUAGE TemplateHaskell #-}+module Pinchot.SyntaxTree.Optics where++import Data.Coerce (coerce)+import Data.Foldable (toList)+import Data.Maybe (catMaybes)+import Data.Sequence (Seq)+import qualified Control.Lens as Lens+import qualified Language.Haskell.TH as T+import qualified Language.Haskell.TH.Syntax as Syntax++import Pinchot.Rules+import Pinchot.Types+import Pinchot.Intervals++-- | Creates optics declarations for a 'Rule', if optics can+-- be made for the 'Rule':+--+-- * 'Pinchot.terminal' gets a single 'Lens.Prism'+--+-- * 'Pinchot.nonTerminal' gets a 'Lens.Prism' for each constructor+--+-- * 'Pinchot.record' gets a single 'Lens.Lens'+--+-- * 'Pinchot.wrap', 'Pinchot.opt', 'Pinchot.star',+-- and 'Pinchot.plus' do not get optics.+--+-- Each rule in the sequence of 'Rule', as well as all ancestors of+-- those 'Rule's, will be handled.+--+-- Example: "Pinchot.Examples.RulesToOptics".+rulesToOptics+  :: Syntax.Lift t+  => Qualifier+  -- ^ Qualifier for module containing the data types that will get+  -- optics+  -> T.Name+  -- ^ Type name for the terminal+  -> Seq (Rule t)+  -> T.Q [T.Dec]+rulesToOptics qual termName+  = fmap concat+  . traverse (ruleToOptics qual termName)+  . families++-- | Creates optics declarations for a single 'Rule', if optics can+-- be made for the 'Rule':+--+-- * 'Terminal' gets a single 'Lens.Prism'+--+-- * 'NonTerminal' gets a 'Lens.Prism' for each constructor+--+-- * 'Terminals' gets a single 'Lens.Prism'+--+-- * 'Record' gets a single 'Lens.Lens'+--+-- * 'Wrap', 'Opt', 'Star', and 'Plus' do not get optics.+ruleToOptics+  :: Syntax.Lift t+  => Qualifier+  -- ^ Qualifier for module containing the data type that will get+  -- optics+  -> T.Name+  -- ^ Type name for the terminal+  -> Rule t+  -> T.Q [T.Dec]+ruleToOptics qual termName (Rule nm _ ty) = case ty of+  Terminal ivls -> terminalToOptics qual termName nm ivls+  NonTerminal b1 bs -> sequence $ nonTerminalToOptics qual nm b1 bs+  Record sq -> sequence $ recordsToOptics qual nm sq+  _ -> return []+  ++-- | 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+  => Qualifier+  -- ^ Qualifier for module containing the data type that will get+  -- optics+  -> T.Name+  -- ^ Terminal type name+  -> String+  -- ^ Rule name+  -> Intervals t+  -> T.Q [T.Dec]+terminalToOptics qual termName nm ivls = do+  e1 <- T.sigD (T.mkName ('_':nm))+    $ T.forallT [ T.PlainTV (T.mkName "a")] (return [])+    [t| Lens.Prism' ( $(T.conT termName), $(anyType) )+                    ($(T.conT (quald qual nm)) $(T.conT termName) $(anyType))+    |]+  +  e2 <- T.valD prismName (T.normalB expn) []+  return [e1, e2]+  where+    anyType = T.varT (T.mkName "a")+    charType = T.varT (T.mkName "t")+    prismName = T.varP (T.mkName ('_' : nm))+    fetchPat = T.conP (quald qual nm) [T.varP (T.mkName "_x")]+    fetchName = T.varE (T.mkName "_x")+    ctor = T.conE (quald qual nm)+    expn = [| let fetch $fetchPat = $fetchName+                  store (term, a)+                    | inIntervals ivls term = Just ($(ctor) (term, a))+                    | otherwise = Nothing+              in Lens.prism' fetch store+           |]++-- | Creates prisms for each 'Branch'.+nonTerminalToOptics+  :: Qualifier+  -- ^ Qualifier for module containing the data type that will get+  -- optics+  -> String+  -- ^ Rule name+  -> Branch t+  -> Seq (Branch t)+  -> [T.Q T.Dec]+nonTerminalToOptics qual nm b1 bsSeq+  = concat $ makePrism b1 : fmap makePrism bs+  where+    bs = toList bsSeq+    makePrism (Branch inner rulesSeq) = [ signature, binding ]+      where+        charType = T.varT (T.mkName "t")+        anyType = T.varT (T.mkName "a")+        rules = toList rulesSeq+        prismName = T.mkName ('_' : inner)+        signature = T.sigD prismName+          (forallA [t| Lens.Prism'+              ($(T.conT (quald qual nm)) $(charType) $(anyType))+              $(fieldsType) |])+          where+            fieldsType = case rules of+              [] -> T.tupleT 0+              Rule r1 _ _ : [] -> [t| $(T.conT (quald qual r1))+                $(charType) $(anyType) |]+              rs -> foldl addType (T.tupleT (length rs)) rs+                where+                  addType soFar (Rule r _ _) = soFar `T.appT`+                    [t| $(T.conT (quald qual r)) $(charType) $(anyType) |]+        binding = T.valD (T.varP prismName) body []+          where+            body = T.normalB+              $ (T.varE 'Lens.prism)+              `T.appE` setter+              `T.appE` getter+              where+                setter = T.lamE [pat] expn+                  where+                    (pat, expn) = case rules of+                      [] -> (T.tupP [], T.conE (quald qual inner))+                      _ : [] -> (T.varP local,+                        T.conE (quald qual inner)+                        `T.appE` T.varE local)+                        where+                          local = T.mkName "_x"+                      ls -> (T.tupP pats, set)+                        where+                          pats = fmap (\i -> T.varP (T.mkName ("_x" ++ show i)))+                            . take (length ls) $ [(0 :: Int) ..]+                          set = foldl addVar start . take (length ls)+                            $ [(0 :: Int) ..]+                            where+                              addVar acc i = acc `T.appE`+                                (T.varE (T.mkName ("_x" ++ show i)))+                              start = T.conE (quald qual inner)++                getter = T.lamE [pat] expn+                  where+                    local = T.mkName "_x"+                    pat = T.varP local+                    expn = T.caseE (T.varE (T.mkName "_x")) $+                      T.match patCtor bodyCtor []+                      : rest+                      where+                        patCtor = T.conP (quald qual inner)+                          . fmap (\i -> T.varP (T.mkName $ "_y" ++ show i))+                          . take (length rules)+                          $ [(0 :: Int) ..]+                        bodyCtor = T.normalB . (T.conE 'Right `T.appE`)+                          $ case rules of+                          [] -> T.tupE []+                          _:[] -> T.varE (T.mkName "_y0")+                          _ -> T.tupE+                            . fmap (\i -> T.varE (T.mkName $ "_y" ++ show i))+                            . take (length rules)+                            $ [(0 :: Int) ..]+                        rest = case bs of+                          [] -> []+                          _ -> [T.match patBlank bodyBlank []]+                          where+                            patBlank = T.varP (T.mkName "_z")+                            bodyBlank = T.normalB+                              $ T.conE ('Left)+                              `T.appE` T.varE (T.mkName "_z")++recordsToOptics+  :: Qualifier+  -- ^ Qualifier for module containing the data type that will get+  -- optics+  -> String+  -- ^ Rule name+  -> Seq (Rule t)+  -> [T.Q T.Dec]+recordsToOptics qual nm+  = concat . zipWith makeLens [(0 :: Int) ..] . toList+  where+    makeLens index (Rule inner _ _) = [ signature, function ]+      where+        charType = T.varT (T.mkName "t")+        anyType = T.varT (T.mkName "a")+        fieldNm = recordFieldName index nm inner+        lensName = T.mkName fieldNm+        signature = T.sigD lensName (forallA+          [t| Lens.Lens' ($(T.conT (quald qual nm)) $(charType) $(anyType))+                         ($(T.conT (quald qual inner)) $(charType) $(anyType))+          |])++        function = T.funD lensName [T.clause [] (T.normalB body) []]+          where+            namedRec = T.mkName "_namedRec"+            namedNewVal = T.mkName "_namedNewVal"+            body = (T.varE 'Lens.lens) `T.appE` getter `T.appE` setter+              where+                getter = T.lamE [pat] expn+                  where+                    pat = T.varP namedRec+                    expn = (T.varE (quald qual ('_' : fieldNm)))+                      `T.appE` (T.varE namedRec)++                setter = T.lamE [patRec, patNewVal] expn+                  where+                    patRec = T.varP namedRec+                    patNewVal = T.varP namedNewVal+                    expn = T.recUpdE (T.varE namedRec)+                      [ return ( quald qual ('_' : fieldNm)+                               , T.VarE namedNewVal) ]++forallA :: T.TypeQ -> T.TypeQ+forallA = T.forallT [ T.PlainTV (T.mkName "t")+                    , T.PlainTV (T.mkName "a")] (return [])

@@ -0,0 +1,161 @@+{-# LANGUAGE TemplateHaskell #-}+module Pinchot.SyntaxTree.Wrappers where++import Data.Foldable (toList)+import Data.Maybe (catMaybes)+import Data.Sequence (Seq)+import qualified Control.Lens as Lens+import qualified Language.Haskell.TH as T++import Pinchot.NonEmpty+import Pinchot.Rules+import Pinchot.Types++-- # Wrapped++-- | Creates a 'Lens.Wrapped' instance for each 'Rule' and its+-- ancestors, if there is an instance.+-- Only 'Pinchot.terminal', 'Pinchot.wrap',+-- 'Pinchot.opt', 'Pinchot.star', and 'Pinchot.plus'+-- get instances of 'Lens.Wrapped'.+--+-- This must be+-- spliced in the same module in which the syntax tree types are+-- created; this way, no orphans are created.  Since ancestors are+-- included, you can get the entire tree of types that you need by+-- applying this function to a single start symbol.+--+-- Example: "Pinchot.Examples.SyntaxTrees".++wrappedInstances+  :: Seq (Rule t)+  -> T.DecsQ+wrappedInstances+  = sequence+  . catMaybes+  . toList+  . fmap singleWrappedInstance+  . families++-- | Creates a 'Lens.Wrapped' instance for the 'Rule', if there is+-- one.  Only 'Pinchot.terminal', 'Pinchot.wrap',+-- 'Pinchot.opt', 'Pinchot.star', and 'Pinchot.plus'+-- get instances of 'Wrapped'.+-- 'This must be spliced in the same module in which the+-- syntax tree types are created.++singleWrappedInstance+  :: Rule t+  -> Maybe (T.Q T.Dec)+singleWrappedInstance (Rule nm _ ty) = case ty of+  Terminal _ -> Just $ wrappedTerminal nm+  Wrap (Rule inner _ _) -> Just $ wrappedWrap inner nm+  Opt (Rule inner _ _) -> Just $ wrappedOpt inner nm+  Star (Rule inner _ _) -> Just $ wrappedStar inner nm+  Plus (Rule inner _ _) -> Just $ wrappedPlus inner nm+  _ -> Nothing+++makeWrapped+  :: T.TypeQ+  -- ^ Name of wrapped type+  -> String+  -- ^ Name of wrapper type+  -> T.Q T.Dec+makeWrapped wrappedType nm = T.instanceD (return []) typ decs+  where+    name = T.mkName nm+    local = T.mkName "_x"+    typ = (T.conT ''Lens.Wrapped) `T.appT`+      ((T.conT name)+        `T.appT` (T.varT (T.mkName "t"))+        `T.appT` (T.varT (T.mkName "a")))+    decs = [assocType, wrapper]+      where+        assocType = T.tySynInstD ''Lens.Unwrapped+          (T.tySynEqn [T.conT name+            `T.appT` (T.varT (T.mkName "t"))+            `T.appT` (T.varT (T.mkName "a"))]+                      wrappedType)+        wrapper = T.funD 'Lens._Wrapped'+          [T.clause [] (T.normalB body) []]+          where+            body = (T.varE 'Lens.iso)+              `T.appE` unwrap+              `T.appE` doWrap+              where+                unwrap = T.lamE [lambPat] (T.varE local)+                  where+                    lambPat = T.conP name [T.varP local]+                doWrap = T.lamE [lambPat] expn+                  where+                    expn = (T.conE name)+                      `T.appE` (T.varE local)+                    lambPat = T.varP local++wrappedOpt+  :: String+  -- ^ Wrapped rule name+  -> String+  -- ^ Wrapping Rule name+  -> T.Q T.Dec+wrappedOpt wrappedName = makeWrapped maybeName+  where+    maybeName = (T.conT ''Maybe)+      `T.appT`+      ((T.conT (T.mkName wrappedName))+        `T.appT` (T.varT (T.mkName "t"))+        `T.appT` (T.varT (T.mkName "a")))++wrappedTerminal+  :: String+  -- ^ Wrapper Rule name+  -> T.Q T.Dec+wrappedTerminal = makeWrapped+  [t| ( $(T.varT (T.mkName "t")), $(T.varT (T.mkName "a")) ) |]++wrappedTerminals+  :: String+  -- ^ Wrapper Rule name+  -> T.Q T.Dec+wrappedTerminals = makeWrapped+  [t| Seq ( $(T.varT (T.mkName "t")), $(T.varT (T.mkName "a")) ) |]++wrappedStar+  :: String+  -- ^ Wrapped rule name+  -> String+  -- ^ Wrapping Rule name+  -> T.Q T.Dec+wrappedStar wrappedName = makeWrapped innerName+  where+    innerName = (T.conT ''Seq) `T.appT`+      ((T.conT (T.mkName wrappedName))+        `T.appT` (T.varT (T.mkName "t"))+        `T.appT` (T.varT (T.mkName "a")))++wrappedPlus+  :: String+  -- ^ Wrapped rule name+  -> String+  -- ^ Wrapping Rule name+  -> T.Q T.Dec+wrappedPlus wrappedName = makeWrapped tupName+  where+    tupName = T.conT ''NonEmpty+      `T.appT` ((T.conT (T.mkName wrappedName))+                  `T.appT` (T.varT (T.mkName "t"))+                  `T.appT` (T.varT (T.mkName "a")))++wrappedWrap+  :: String+  -- ^ Wrapped rule name+  -> String+  -- ^ Wrapping Rule name+  -> T.Q T.Dec+wrappedWrap wrappedName = makeWrapped innerName+  where+    innerName =+      ((T.conT (T.mkName wrappedName))+        `T.appT` (T.varT (T.mkName "t"))+        `T.appT` (T.varT (T.mkName "a")))

@@ -0,0 +1,323 @@+{-# OPTIONS_HADDOCK not-home #-}+{-# LANGUAGE TemplateHaskell #-}+module Pinchot.Terminalize where++import Control.Monad (join)+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq+import Data.Foldable (foldlM, toList)+import Data.Map (Map)+import qualified Data.Map as Map+import qualified Language.Haskell.TH as T+import qualified Language.Haskell.TH.Syntax as Syntax++import Pinchot.NonEmpty (NonEmpty(NonEmpty))+import qualified Pinchot.NonEmpty as NonEmpty+import Pinchot.Types+import Pinchot.Rules++-- | For all the given rules and their ancestors, creates+-- declarations that reduce the rule and all its ancestors to+-- terminal symbols.  Each rule gets a declaration named+-- @t'RULE_NAME@ where @RULE_NAME@ is the name of the rule.  The+-- type of the declaration is either+--+-- Production a -> Seq (t, a)+--+-- or+--+-- Production a -> NonEmpty (t, a)+--+-- where @Production@ is the production corresponding to the given+-- 'Rule', @t@ is the terminal token type (often 'Char'), and @a@ is+-- arbitrary metadata about each token (often 'Loc').  'NonEmpty' is+-- returned for productions that must always contain at least one+-- terminal symbol; for those that can be empty, 'Seq' is returned.+--+-- Example: "Pinchot.Examples.Terminalize".+terminalizers+  :: Qualifier+  -- ^ Qualifier for the module containing the data types created+  -- from the 'Rule's+ +  -> T.Name+  -- ^ Name of terminal type.  Typically you will get this through+  -- the Template Haskell quoting mechanism, such as @''Char@.++  -> Seq (Rule t)+  -> T.Q [T.Dec]++terminalizers qual termType+  = fmap concat+  . traverse (terminalizer qual termType)+  . toList+  . families++-- | For the given rule, creates declarations that reduce the rule+-- to terminal symbols.  No ancestors are handled.  Each rule gets a+-- declaration named @t'RULE_NAME@ where @RULE_NAME@ is the name of+-- the rule.  The+-- type of the declaration is either+--+-- Production a -> Seq (t, a)+--+-- or+--+-- Production a -> NonEmpty (t, a)+--+-- where @Production@ is the production corresponding to the given+-- 'Rule', @t@ is the terminal token type (often 'Char'), and @a@ is+-- arbitrary metadata about each token (often 'Loc').  'NonEmpty' is+-- returned for productions that must always contain at least one+-- terminal symbol; for those that can be empty, 'Seq' is returned.++terminalizer+  :: Qualifier+  -- ^ Qualifier for the module containing the data types created+  -- from the 'Rule's+ +  -> T.Name+  -- ^ Name of terminal type.  Typically you will get this through+  -- the Template Haskell quoting mechanism, such as @''Char@.++  -> Rule t+  -> T.Q [T.Dec]++terminalizer qual termType rule@(Rule nm _ _) = sequence [sig, expn]+  where+    declName = "t'" ++ nm+    anyType = T.varT (T.mkName "a")+    charType = T.varT (T.mkName "t")+    sig+      | atLeastOne rule = T.sigD (T.mkName declName)+          . T.forallT [T.PlainTV (T.mkName "t")+                      , T.PlainTV (T.mkName "a")] (return [])+          $ [t| $(T.conT (quald qual nm)) $(charType) $(anyType)+            -> NonEmpty ($(charType), $(anyType)) |]+      | otherwise = T.sigD (T.mkName declName)+          . T.forallT [ T.PlainTV (T.mkName "t")+                      , T.PlainTV (T.mkName "a")] (return [])+          $ [t| $(T.conT (quald qual nm)) $(charType) $(anyType)+              -> Seq ($(charType), $(anyType)) |]+    expn = T.valD (T.varP $ T.mkName declName)+      (T.normalB (terminalizeRuleExp qual rule)) []++-- | For the given rule, returns an expression that has type of+-- either+--+-- Production a -> Seq (t, a)+--+-- or+--+-- Production a -> NonEmpty (t, a)+--+-- where @Production@ is the production corresponding to the given+-- 'Rule', and @t@ is the terminal token type.  'NonEmpty' is+-- returned for productions that must always contain at least one+-- terminal symbol; for those that can be empty, 'Seq' is returned.+--+-- Example:  'Pinchot.Examples.Terminalize.terminalizeAddress'.+terminalizeRuleExp+  :: Qualifier+  -> Rule t+  -> T.Q T.Exp+terminalizeRuleExp qual rule@(Rule nm _ _) = do+  let allRules = family rule +  lkp <- ruleLookupMap allRules+  let mkDec r@(Rule rn _ _) =+        let expn = terminalizeSingleRule qual lkp r+            decName = lookupName lkp rn+        in T.valD (T.varP decName) (T.normalB expn) []+  T.letE (fmap mkDec . toList $ allRules) (T.varE (lookupName lkp nm))++-- | Creates a 'Map' where each key is the name of the 'Rule' and+-- each value is a name corresponding to that 'Rule'.  No+-- ancestors are used.+ruleLookupMap+  :: Foldable c+  => c (Rule t)+  -> T.Q (Map RuleName (T.Name))+ruleLookupMap = foldlM f Map.empty+  where+    f mp (Rule nm _ _) = do+      name <- T.newName $ "rule" ++ nm+      return $ Map.insert nm name mp++lookupName+  :: Map RuleName T.Name+  -> RuleName+  -> T.Name+lookupName lkp n = case Map.lookup n lkp of+  Nothing -> error $ "lookupName: name not found: " ++ n+  Just r -> r++-- | For the given rule, returns an expression that has type+-- of either+--+-- Production a -> Seq (t, a)+--+-- or+--+-- Production a -> NonEmpty (t, a)+--+-- where @Production@ is the production corresponding to the given+-- 'Rule', and @t@ is the terminal token type.  'NonEmpty' is+-- returned for productions that must always contain at least one+-- terminal symbol; for those that can be empty, 'Seq' is returned.+-- Gets no ancestors.+terminalizeSingleRule+  :: Qualifier+  -- ^ Module qualifier for module containing the generated types+  -- corresponding to all 'Rule's+  -> Map RuleName T.Name+  -- ^ For a given Rule, looks up the name of the expression that+  -- will terminalize that rule.+  -> Rule t+  -> T.Q T.Exp+terminalizeSingleRule qual lkp rule@(Rule nm _ ty) = case ty of+  Terminal _ -> do+    x <- T.newName "x"+    let pat = T.conP (quald qual nm) [T.varP x]+    [| \ $(pat) -> NonEmpty.singleton $(T.varE x) |]++  NonTerminal b1 bs -> do+    x <- T.newName "x"+    let fTzn | atLeastOne rule = terminalizeProductAtLeastOne+             | otherwise = terminalizeProductAllowsZero+        tzr (Branch name sq)+          = fmap (\(pat, expn) -> T.match pat (T.normalB expn) [])+          (fTzn qual lkp name sq)+    m1 <- tzr b1+    ms <- traverse tzr . toList $ bs+    T.lamE [T.varP x] (T.caseE (T.varE x) (m1 : ms))++  Wrap (Rule inner _ _) -> do+    x <- T.newName "x"+    let pat = T.conP (quald qual nm) [T.varP x]+    [| \ $(pat) -> $(T.varE (lookupName lkp inner)) $(T.varE x) |]++  Record rs -> do+    (pat, expn) <- fTzr qual lkp nm rs+    [| \ $(pat) -> $(expn) |]+    where+      fTzr | atLeastOne rule = terminalizeProductAtLeastOne+           | otherwise = terminalizeProductAllowsZero++  Opt r@(Rule inner _ _) -> do+    x <- T.newName "x"+    let pat = T.conP (quald qual nm) [T.varP x]+    [| \ $(pat) -> maybe Seq.empty+          $(convert (T.varE (lookupName lkp inner))) $(T.varE x) |]+    where+      convert expn | atLeastOne r = [| NonEmpty.flatten . $(expn) |]+                   | otherwise = expn++  Star r@(Rule inner _ _) -> do+    x <- T.newName "x"+    let pat = T.conP (quald qual nm) [T.varP x]+        convert e | atLeastOne r = [| NonEmpty.flatten . $(e) |]+                  | otherwise = e+    [| \ $(pat) -> join . fmap $(convert (T.varE (lookupName lkp inner)))+          $ $(T.varE x) |]++  Plus r@(Rule inner _ _)+    | atLeastOne r -> do+        x <- T.newName "x"+        let pat = T.conP (quald qual nm) [T.varP x]+        [| \ $(pat) ->+            let getTermNonEmpty = $(T.varE (lookupName lkp inner))+                getTerms (NonEmpty e1 es) = join . fmap getTermNonEmpty+                  $ NonEmpty.NonEmpty e1 es+           in getTerms $(T.varE x)+          |]++    | otherwise -> do+        x <- T.newName "x"+        let pat = T.conP (quald qual nm) [T.varP x]+        [| let getTermSeq = $(T.varE (lookupName lkp inner))+               getTerms (NonEmpty e1 es) = getTermSeq e1+                `mappend` (join (fmap getTermSeq es))+           in getTerms $(T.varE x)+          |]++terminalizeProductAllowsZero+  :: Qualifier+  -> Map RuleName T.Name+  -> String+  -- ^ Rule name or branch name, as applicable+  -> Seq (Rule t)+  -> T.Q (T.PatQ, T.ExpQ)+terminalizeProductAllowsZero qual lkp name bs = do+  pairs <- fmap toList . traverse (terminalizeProductRule lkp) $ bs+  let pat = T.conP (quald qual name) (fmap (fst . snd) pairs)+      body = case pairs of+        [] -> [| Seq.empty |]+        x:xs -> foldl f start xs+          where+            f acc trip = [| $(acc) `mappend` $(procTrip trip) |]+            start = procTrip x+            procTrip (rule, (_, expn))+              | atLeastOne rule = [| NonEmpty.flatten $(expn) |]+              | otherwise = expn+  return (pat, body)++terminalizeProductAtLeastOne+  :: Qualifier+  -> Map RuleName T.Name+  -> String+  -- ^ Rule name or branch name, as applicable+  -> Seq (Rule t)+  -> T.Q (T.PatQ, T.ExpQ)+terminalizeProductAtLeastOne qual lkp name bs = do+  pairs <- fmap toList . traverse (terminalizeProductRule lkp) $ bs+  let pat = T.conP (quald qual name) (fmap (fst . snd) pairs)+      body = [| ( $(leadSeq) `NonEmpty.prependSeq` $(firstNonEmpty))+                `NonEmpty.appendSeq` $(trailSeq) |]+        where+          (leadRules, lastRules) = span (not . atLeastOne . fst) pairs+          (firstNonEmptyRule, trailRules) = case lastRules of+            [] -> error $ "terminalizeProductAtLeastOne: failure 1: " ++ name+            x:xs -> (x, xs)+          leadSeq = case fmap (snd . snd) leadRules of+            [] -> [| Seq.empty |]+            x:xs -> foldl f x xs+              where+                f acc expn = [| $(acc) `mappend` $(expn) |]+          firstNonEmpty = [| $(snd . snd $ firstNonEmptyRule) |]++          trailSeq = foldl f [| Seq.empty |] trailRules+            where+              f acc (rule, (_, expn))+                | atLeastOne rule =+                    [| $(acc) `mappend` NonEmpty.flatten $(expn) |]+                | otherwise =+                    [| $(acc) `mappend` $(expn) |]+  return (pat, body)++terminalizeProductRule+  :: Map RuleName T.Name+  -> Rule t+  -> T.Q (Rule t, (T.Q T.Pat, T.Q T.Exp))+terminalizeProductRule lkp r@(Rule nm _ _) = do+  x <- T.newName $ "terminalizeProductRule'" ++ nm+  let getTerms = [| $(T.varE (lookupName lkp nm)) $(T.varE x) |]+  return (r, (T.varP x, getTerms))++-- | Examines a rule to determine whether when terminalizing it will+-- always return at least one terminal symbol.+atLeastOne+  :: Rule t+  -> Bool+  -- ^ True if the rule will always have at least one terminal+  -- symbol.+atLeastOne (Rule _ _ ty) = case ty of+  Terminal _ -> True+  NonTerminal b1 bs -> branchAtLeastOne b1 && all branchAtLeastOne bs+    where+      branchAtLeastOne (Branch _ rs) = any atLeastOne rs+  Wrap r -> atLeastOne r+  Record rs -> any atLeastOne rs+  Opt _ -> False+  Star _ -> False+  Plus r -> atLeastOne r+

@@ -0,0 +1,180 @@+{-# OPTIONS_HADDOCK not-home #-}+module Pinchot.Types where++import Pinchot.Intervals++import qualified Control.Lens as Lens+import Data.Sequence (Seq)+import qualified Language.Haskell.TH as T++-- | 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.+-- Typically each context-free grammar that you write will have+-- several production rules; you will want to make sure that every+-- 'RuleName' that you create for a single context-free grammar is+-- unique.  However, Pinchot currently does not check for+-- uniqueness.  If you use names that are not unique, GHC will give+-- an error message when you try to splice the resulting code, as+-- the data types will not have unique names.+type RuleName = String++-- | Type synonym the the name of an alternative in a 'nonTerminal'.+-- This name must not conflict with any other data constructor in+-- your grammar.+type BranchName = String++-- Rule n d t, where+--+-- n is the name of the rule.  This is used as the name of the+-- corresponding data type.+--+-- d is the description of the rule.  This is optional and is used for+-- the parser's error messages.  If there is no description, the name+-- is used for error messages.+--+-- t is the type of rule (terminal, branch, etc.)++-- | A single production rule.+data Rule t = Rule+  { _ruleName :: RuleName+  , _ruleDescription :: Maybe String+  , _ruleType :: RuleType t+  } deriving (Eq, Ord, Show)++-- Can't use Template Haskell in this module due to corecursive+-- types++ruleName :: Lens.Lens' (Rule t) RuleName+ruleName+  = Lens.lens _ruleName (\r n -> r { _ruleName = n })++ruleDescription :: Lens.Lens' (Rule t) (Maybe String)+ruleDescription+  = Lens.lens _ruleDescription (\r d -> r { _ruleDescription = d })++ruleType :: Lens.Lens' (Rule t) (RuleType t)+ruleType+  = Lens.lens _ruleType (\r t -> r { _ruleType = t })++-- | A branch in a sum rule.  In @Branch s ls@, @s@ is the name of the+-- data constructor, and @ls@ is the list of rules that this branch+-- produces.+data Branch t = Branch+  { _branchName :: BranchName+  , _branches :: Seq (Rule t)+  } deriving (Eq, Ord, Show)++branchName :: Lens.Lens' (Branch t) BranchName+branchName+  = Lens.lens _branchName (\b n -> b { _branchName = n })++branches :: Lens.Lens' (Branch t) (Seq (Rule t))+branches+  = Lens.lens _branches (\b s -> b { _branches = s})++-- | The type of a particular rule.+data RuleType t+  = Terminal (Intervals t)+  | NonTerminal (Branch t) (Seq (Branch t))+  | Wrap (Rule t)+  | Record (Seq (Rule t))+  | Opt (Rule t)+  | Star (Rule t)+  | Plus (Rule t)+  deriving (Eq, Ord, Show)++_Terminal :: Lens.Prism' (RuleType t) (Intervals t)+_Terminal = Lens.prism' (\i -> Terminal i)+  (\r -> case r of { Terminal i -> Just i; _ -> Nothing })++_NonTerminal :: Lens.Prism' (RuleType t) (Branch t, Seq (Branch t))+_NonTerminal = Lens.prism' (\(b, bs) -> NonTerminal b bs)+  (\r -> case r of { NonTerminal b bs -> Just (b, bs); _ -> Nothing })++_Wrap :: Lens.Prism' (RuleType t) (Rule t)+_Wrap = Lens.prism' (\r -> Wrap r)+  (\r -> case r of { Wrap x -> Just x; _ -> Nothing })++_Record :: Lens.Prism' (RuleType t) (Seq (Rule t))+_Record = Lens.prism' (\r -> Record r)+  (\r -> case r of { Record x -> Just x; _ -> Nothing })++_Opt :: Lens.Prism' (RuleType t) (Rule t)+_Opt = Lens.prism' (\r -> Opt r)+  (\r -> case r of { Opt x -> Just x; _ -> Nothing })++_Star :: Lens.Prism' (RuleType t) (Rule t)+_Star = Lens.prism' (\r -> Star r)+  (\r -> case r of { Star x -> Just x; _ -> Nothing })++_Plus :: Lens.Prism' (RuleType t) (Rule t)+_Plus = Lens.prism' (\r -> Plus r)+  (\r -> case r of { Plus x -> Just x; _ -> Nothing })++-- | The name of a field in a record, without the leading+-- underscore.+recordFieldName+  :: Int+  -- ^ Index+  -> String+  -- ^ Parent type name+  -> String+  -- ^ Inner type name+  -> String+recordFieldName idx par inn = "r'" ++ par ++ "'" ++ show idx ++ "'" ++ inn++-- | Many functions take an argument that holds the name qualifier+-- for the module that contains the data types created by applying a+-- function such as 'Pinchot.SyntaxTree.syntaxTrees' or+-- 'Pinchot.Earley.earleyProduct'.+--+-- You will have to make sure that these data types 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 the function that takes a+-- 'Qualifier' argument, 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 'Pinchot.SyntaxTree.syntaxTrees' or+-- 'Pinchot.Earley.earleyProduct', 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+++-- | Prepends a qualifier to a string, and returns the resulting+-- Name.+quald+  :: Qualifier+  -> String+  -- ^ Item to be named - constructor, value, etc.+  -> T.Name+quald qual suf+  | null qual = T.mkName suf+  | otherwise = T.mkName (qual ++ '.':suf)++-- | A location.++data Loc = Loc+  { _line :: Int+  , _col :: Int+  , _pos :: Int+  } deriving (Eq, Ord, Read, Show)++line :: Lens.Lens' Loc Int+line = Lens.lens _line (\r l -> r { _line = l })++col :: Lens.Lens' Loc Int+col = Lens.lens _col (\r l -> r { _col = l })++pos :: Lens.Lens' Loc Int+pos = Lens.lens _pos (\r l -> r { _pos = l })

@@ -3,11 +3,11 @@ -- http://www.github.com/massysett/cartel -- -- Script name used to generate: genCabal.hs--- Generated on: 2016-03-04 16:15:31.455268 EST+-- Generated on: 2016-04-10 09:37:56.35801 EDT -- Cartel library version: 0.14.2.8  name: pinchot-version: 0.14.0.0+version: 0.16.0.0 cabal-version: >= 1.14 license: BSD3 license-file: LICENSE@@ -18,11 +18,10 @@ stability: Experimental homepage: http://www.github.com/massysett/pinchot bug-reports: http://www.github.com/massysett/pinchot/issues-synopsis: Build parsers and ASTs for context-free grammars+synopsis: Write grammars, not parsers description:   Pinchot provides a simple language that you use to write a Haskell-  program that describes a context-free grammar.  When run, this program-  creates a value representing the grammar.  Using this value, you can+  value that describes a context-free grammar.  Using this value, you can   automatically generate data types corresponding to the grammar,   as well as an Earley parser to parse strings in that grammar.   .@@ -34,24 +33,33 @@ Library   exposed-modules:     Pinchot+    Pinchot.Earley     Pinchot.Examples-    Pinchot.Examples.AllEarleyGrammars     Pinchot.Examples.AllRulesRecord-    Pinchot.Examples.EarleyProduct+    Pinchot.Examples.Earley+    Pinchot.Examples.Newman     Pinchot.Examples.Postal-    Pinchot.Examples.PostalAstAllRules-    Pinchot.Examples.PostalAstNoLenses-    Pinchot.Examples.PostalAstRuleTree-    Pinchot.Examples.QualifiedImport-    Pinchot.Internal+    Pinchot.Examples.RulesToOptics+    Pinchot.Examples.SyntaxTrees+    Pinchot.Examples.Terminalize     Pinchot.Intervals+    Pinchot.Locator+    Pinchot.NonEmpty+    Pinchot.RecursiveDo+    Pinchot.Rules+    Pinchot.SyntaxTree+    Pinchot.SyntaxTree.Optics+    Pinchot.SyntaxTree.Wrappers+    Pinchot.Terminalize+    Pinchot.Types   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+    , Earley >= 0.11.0.1     , lens >= 4.13+    , ListLike >= 4.2.1   other-extensions:     TemplateHaskell   default-language: Haskell2010@@ -62,126 +70,31 @@   type: git   location: https://github.com/massysett/penny.git -Executable print-postal-grammar-  main-is: print-postal-grammar.hs+Executable newman+  main-is: newman.hs   if flag(executables)     buildable: True     other-modules:       Pinchot+      Pinchot.Earley       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 postal-parser-  main-is: postal-parser.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-      Pinchot.Examples.PostalAstRuleTree-      Pinchot.Examples.QualifiedImport-      Pinchot.Internal-      Pinchot.Intervals-    hs-source-dirs:-      exe-    build-depends:-        pretty-show >= 1.6.9-      , 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 parrot-  main-is: parrot.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-      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.Earley+      Pinchot.Examples.Newman       Pinchot.Examples.Postal-      Pinchot.Examples.PostalAstAllRules-      Pinchot.Examples.PostalAstNoLenses-      Pinchot.Examples.PostalAstRuleTree-      Pinchot.Examples.QualifiedImport-      Pinchot.Internal+      Pinchot.Examples.RulesToOptics+      Pinchot.Examples.SyntaxTrees+      Pinchot.Examples.Terminalize       Pinchot.Intervals+      Pinchot.Locator+      Pinchot.NonEmpty+      Pinchot.RecursiveDo+      Pinchot.Rules+      Pinchot.SyntaxTree+      Pinchot.SyntaxTree.Optics+      Pinchot.SyntaxTree.Wrappers+      Pinchot.Terminalize+      Pinchot.Types     hs-source-dirs:       exe     build-depends:@@ -189,8 +102,9 @@       , containers >= 0.5.6.2       , transformers >= 0.4.2.0       , template-haskell >= 2.10-      , Earley >= 0.10.1.0+      , Earley >= 0.11.0.1       , lens >= 4.13+      , ListLike >= 4.2.1     other-extensions:       TemplateHaskell     default-language: Haskell2010