packages feed

pinchot (empty) → 0.2.0.0

raw patch · 12 files changed

+1302/−0 lines, 12 filesdep +Earleydep +basedep +containers

Dependencies added: Earley, base, containers, pretty-show, template-haskell, transformers

Files

+ LICENSE view
@@ -0,0 +1,31 @@+Copyright (c) 2015 Omari Norman.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++    * Redistributions of source code must retain the above copyright+    notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above copyright+    notice, this list of conditions and the following disclaimer in+    the documentation and/or other materials provided with the+    distribution.++    * Neither the name of Omari Norman nor the names of contributors+    to this software may be used to endorse or promote products+    derived from this software without specific prior written+    permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README view
@@ -0,0 +1,8 @@+Pinchot helps you build Haskell data types and parsers+corresponding to a context-free grammar.++Documentation is contained in the Haddock markup in the+source files.++Pinchot is licensed under the BSD license; see the+LICENSE file.
+ exe/postal-parser.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE TemplateHaskell #-}++-- | 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)++ruleTreeToCode ''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
+ exe/print-postal-grammar.hs view
@@ -0,0 +1,14 @@+{-# 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
+ lib/Pinchot.hs view
@@ -0,0 +1,705 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TemplateHaskell #-}+{- |++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+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.++For examples, please consult "Pinchot.Examples".++You should also look at the BNF Converter.++<http://bnfc.digitalgrammars.com>++Primary differences between BNFC and this library:++* the BNF Converter works as a standalone binary that parses+text BNF files.  With Pinchot you specify your grammar in Haskell.++* the BNF Converter currently generates many more outputs, such+as LaTeX.  It also generates code for many languages.  Pinchot+only works in Haskell.++* the BNF Converter generates input for parser generators like+Happy and Bison.  Pinchot currently only generates input+for the Haskell Earley library.++* Pinchot integrates seamlessly into Haskell using Template Haskell.++* the BNF Converter is GPL.  Pinchot is BSD3.++Pinchot grows and harvests syntax trees, so it is named after+Gifford Pinchot, first chief of the United States Forest Service.++-}+module Pinchot+  ( -- * Intervals+    Intervals+  , include+  , exclude+  , solo+  , pariah++  -- * Simple production rules+  , Pinchot+  , RuleName+  , AlternativeName+  , Rule+  , terminal+  , terminalSeq+  , nonTerminal++  -- * Rules that modify other rules+  , list+  , list1+  , option+  , wrap+  , label+  , (<?>)++  -- * Transforming an AST to code+  , earleyGrammar+  , allRulesToCode+  , ruleTreeToCode+  ) where++import Pinchot.Intervals++import Control.Applicative ((<|>), liftA2)+import Control.Exception (Exception)+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 qualified Data.Set as Set+import Data.Typeable (Typeable)+import Language.Haskell.TH+  (ExpQ, ConQ, normalC, mkName, strictType, notStrict, DecQ, newtypeD,+   cxt, conT, Name, dataD, appT, DecsQ, appE, Q, Stmt(NoBindS), uInfixE, bindS,+   varE, varP, conE, Pat, Exp(AppE, DoE), lamE)+import qualified Language.Haskell.TH.Syntax as Syntax+import Text.Earley (satisfy, rule, symbol)+import qualified Text.Earley ((<?>))++data RuleType t+  = RTerminal (Intervals t)+  | RBranch (Branch t, [(Branch t)])+  | RSeqTerm [t] +  | ROptional (Rule t)+  | RMany (Rule t)+  | RMany1 (Rule t)+  | RWrap (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 Branch t = Branch String [(Rule t)]+  deriving (Eq, Ord, Show)++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)++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+  :: String+  -> 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)+  return r++-- | Type synonym for the name of a production rule.  +-- This will be the name of the type constructor for the corresponding+-- type in the AST, so this must be a valid Haskell type constructor+-- name.+--+-- 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++-- | 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+  -> [(String, [(Rule t)])]+  -> Pinchot t ((String, [(Rule t)]), [(String, [Rule t])])+splitNonTerminal n sq = Pinchot $ case sq of+  [] -> throwE $ EmptyNonTerminal n+  x : xs -> return (x, xs)++-- | Creates a production for a sequence of terminals.  Useful for+-- parsing specific words.+terminalSeq++  :: RuleName++  -> [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++  -> [(AlternativeName, [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+  mapM_ addDataConName . fmap fst $ sq+  (b1, bs) <- splitNonTerminal name sq+  let branches = RBranch (uncurry Branch b1, fmap (uncurry Branch) bs)+  newRule name branches++-- | Creates a rule for the production of a sequence of other rules.+list+  :: RuleName++  -> 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 name r = newRule name (RMany r)++-- | Creates a rule for a production that appears at least once.+list1+  :: RuleName+  -> Rule t+  -- ^ The resulting 'Rule' produces this 'Rule' at least once.+  -> Pinchot t (Rule t)+list1 name r = newRule name (RMany1 r)++-- | Creates a rule for a production that optionally produces another+-- rule.+option+  :: RuleName+  -> 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 name r = newRule name (ROptional r)++-- | 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) [Rule t]+getAncestors r@(Rule name _ ei) = do+  set <- get+  if Set.member name set+    then return []+    else do+      put (Set.insert name set)+      case ei of+        RTerminal _ -> return [r]+        RBranch (b1, bs) -> do+          as1 <- branchAncestors b1+          ass <- fmap join . mapM branchAncestors $ bs+          return $ r : as1 <> ass+        RSeqTerm _ -> return [r]+        ROptional c -> do+          cs <- getAncestors c+          return $ r : cs+        RMany c -> do+          cs <- getAncestors c+          return $ r : cs+        RMany1 c -> do+          cs <- getAncestors c+          return $ r : cs+        RWrap c -> do+          cs <- getAncestors c+          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+  -> [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+          RSeqTerm _ -> results+          ROptional r -> checkRule r results+          RMany r -> addHelper $ checkRule r results+          RMany1 r -> addHelper $ checkRule r results+          RWrap r -> checkRule r results+        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+++thRule+  :: Name+  -- ^ Name of terminal type+  -> [Name]+  -- ^ What to derive+  -> Rule t+  -> DecQ+thRule typeName derives (Rule 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)++  RSeqTerm _ -> dataD (cxt []) name [] cons derives+    where+      cons = [normalC name+        [strictType notStrict (appT [t| [] |]+                                    (conT typeName))]]++  ROptional (Rule inner _ _) -> newtypeD (cxt []) name [] newtypeCon derives+    where+      newtypeCon = normalC name+        [strictType notStrict (appT [t| Maybe |]+                                    (conT (mkName inner)))]++  RMany (Rule inner _ _) -> newtypeD (cxt []) name [] newtypeCon derives+    where+      newtypeCon = normalC name+        [strictType notStrict (appT [t| [] |]+                                    (conT (mkName inner)))]++  RMany1 (Rule inner _ _) -> dataD (cxt []) name [] [cons] derives+    where+      cons = normalC name+        [ strictType notStrict (conT (mkName inner))+        , strictType notStrict (appT [t| [] |]+                                     (conT (mkName inner)))]++  RWrap (Rule inner _ _) -> newtypeD (cxt []) name [] newtypeCon derives+    where+      newtypeCon = normalC name+        [ strictType notStrict (conT (mkName inner)) ]+++  where+    name = mkName nm++thAllRules+  :: Name+  -- ^ Terminal type constructor name+  -> [Name]+  -- ^ What to derive+  -> Map Int (Rule t)+  -> DecsQ+thAllRules typeName derives+  = sequence+  . fmap (thRule typeName derives)+  . fmap snd+  . M.toAscList+++-- | Creates code 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 'allRulesToCode', see+-- "Pinchot.Examples.PostalAstAllRules".++allRulesToCode++  :: Name+  -- ^ Terminal type constructor name.  Typically you will use the+  -- Template Haskell quoting mechanism to get this.++  -> [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+allRulesToCode typeName derives pinchot = case ei of+  Left err -> fail $ "pinchot: bad grammar: " ++ show err+  Right _ -> thAllRules typeName derives (allRules st')+  where+    (ei, st') = runState (runExceptT (runPinchot pinchot))+      (Names Set.empty Set.empty 0 M.empty)++-- | Creates code only for the 'Rule' returned from the 'Pinchot', and+-- for its ancestors.+ruleTreeToCode+  :: Name+  -- ^ Terminal type constructor name.  Typically you will use the+  -- Template Haskell quoting mechanism to get this.++  -> [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+ruleTreeToCode typeName derives pinchot = case ei of+  Left err -> fail $ "pinchot: bad grammar: " ++ show err+  Right r -> sequence . toList . fmap (thRule typeName derives)+    . runCalc . getAncestors $ r+  where+    runCalc stateCalc = fst $ runState stateCalc (Set.empty)+    (ei, _) = runState (runExceptT (runPinchot pinchot))+      (Names Set.empty Set.empty 0 M.empty)++++ruleToParser+  :: Syntax.Lift t+  => String+  -- ^ Module prefix+  -> Rule t+  -> Q [Stmt]+ruleToParser prefix (Rule nm mayDescription rt) = case rt of++  RTerminal ivls -> do+    topRule <- makeRule expression+    return [topRule]+    where+      expression = [| fmap $constructor (satisfy (inIntervals ivls)) |]++  RBranch (b1, bs) -> do+    topRule <- makeRule expression+    return [topRule]+    where+      expression = foldl addBranch (branchToParser prefix b1) bs+        where+          addBranch tree branch =+            [| $tree <|> $(branchToParser prefix branch) |]++  RSeqTerm sq -> do+    let nestRule = bindS (varP helper) [|rule $(go sq)|]+          where+            go sqnce = case sqnce of+              [] -> [|pure []|]+              x : xs -> [|liftA2 (:) (symbol x) $(go xs)|]+    nest <- nestRule+    topRule <- makeRule (wrapper helper)+    return [nest, topRule]++  ROptional (Rule innerNm _ _) -> fmap (:[]) (makeRule expression)+    where+      expression = [| fmap $constructor (pure Nothing <|> $(just)) |]+        where+          just = [| fmap Just $(varE (ruleName innerNm)) |]++  RMany (Rule innerNm _ _) -> do+    let nestRule = bindS (varP helper) ([|rule|] `appE` parseSeq)+          where+            parseSeq = uInfixE [|pure []|] [|(<|>)|] pSeq+              where+                pSeq = [|liftA2 (:) $(varE (ruleName innerNm)) $(varE helper) |]+    nest <- nestRule+    top <- makeRule $ wrapper helper+    return [nest, top]++  RMany1 (Rule innerNm _ _) -> do+    let nestRule = bindS (varP helper) [|rule $(parseSeq)|]+          where+            parseSeq = [| pure [] <|> $pSeq |]+              where+                pSeq = [| (:) <$> $(varE (ruleName innerNm))+                              <*> $(varE helper) |]+    nest <- nestRule+    let topExpn = [| $constructor <$> $(varE (ruleName innerNm))+                                  <*> $(varE helper) |]+    top <- makeRule topExpn+    return [nest, top]++  RWrap (Rule innerNm _ _) -> fmap (:[]) (makeRule expression)+    where+      expression = [|fmap $constructor $(varE (ruleName innerNm)) |]+    ++  where+    makeRule expression = varP (ruleName nm) `bindS`+      [|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 ("_r'" ++ suffix)++helperName :: String -> Name+helperName suffix = mkName ("_h'" ++ suffix)++branchToParser+  :: Syntax.Lift t+  => String+  -- ^ Module prefix+  -> Branch t+  -> ExpQ+branchToParser prefix (Branch name rules) = case rules of+  [] -> [| 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+    +-- | Creates a lazy pattern for all the given names.  Adds an empty+-- pattern onto the front.+lazyPattern+  :: Foldable c+  => c Name+  -> Q Pat+lazyPattern = finish . foldr gen [p| () |]+  where+    gen name rest = [p| ($(varP name), $rest) |]+    finish pat = [p| ~(_, $pat) |]++bigTuple+  :: Foldable c+  => Name+  -> c Name+  -> ExpQ+bigTuple top = finish . foldr f [| () |]+  where+    f n rest = [| ( $(varE n), $rest) |]+    finish tup = [| ($(varE 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++  => String+  -- ^ Module prefix.  You have to make sure that the data types you+  -- created with 'ruleTreeToCode' or with 'allRulesToCode' are in+  -- scope, either because they were spliced into the same module that+  -- 'earleyParser' is spliced into, or because they are @import@ed+  -- into scope.  The spliced Template Haskell code has to know where+  -- to look for these data types.  If you did an unqualified @import@+  -- or if the types are in the same module as is the splice of+  -- 'earleyParser', just pass the empty string here.  If you did a+  -- qualified import, pass the appropriate namespace here.+  --+  -- For example, if you used @import qualified MyAst@, pass+  -- @\"MyAst\"@ here.  If you used @import qualified+  -- Data.MyLibrary.MyAst as MyLibrary.MyAst@, pass+  -- @\"MyLibrary.MyAst\"@ here.+  --+  -- For an example where the types are in the same module, see+  -- "Pinchot.Examples.PostalAstRuleTree" or+  -- "Pinchot.Examples.PostalAstAllRules".+  --+  -- For an example using a qualified import, see+  -- "Pinchot.Examples.QualifiedImport".++  -> Pinchot t (Rule t)+  -- ^ Creates an Earley parser for the 'Rule' that the 'Pinchot'+  -- returns.+  -> Q Exp+earleyGrammar prefix pinc = case ei of+  Left err -> fail $ "pinchot: bad grammar: " ++ show err+  Right r@(Rule top _ _) -> do+    let neededRules = ruleAndAncestors r+        otherNames = rulesDemandedBeforeDefined neededRules+        lamb = lamE [lazyPattern otherNames] expression+        expression = do+          stmts <- fmap concat . mapM (ruleToParser prefix)+            . toList $ neededRules+          result <- bigTuple (ruleName top) otherNames+          rtn <- [|return|]+          let returner = rtn `AppE` result+          return $ DoE (stmts ++ [NoBindS returner])+    [| fmap fst (mfix $lamb) |]+  where+    (ei, _) = runState (runExceptT (runPinchot pinc))+      (Names Set.empty Set.empty 0 M.empty)+
+ lib/Pinchot/Examples.hs view
@@ -0,0 +1,27 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-}++-- | 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+-- 'allRulesToCode' and 'earleyParser', while+-- "Pinchot.Examples.PostalAstRuleTree" shows you how to use+-- 'ruleTreeToCode' and 'earleyParser'.+--+-- Two executables are included in the @pinchot@ package.  To get+-- them, compile @pinchot@ with the @executables@ Cabal flag.  The+-- @print-postal-grammar@ executable will pretty print the Haskell+-- source that results from applying 'earleyGrammar' to the 'postal'+-- grammar.  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.++module Pinchot.Examples where++import Pinchot+import Pinchot.Examples.Postal
+ lib/Pinchot/Examples/Postal.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE OverloadedStrings, OverloadedLists, RecursiveDo #-}+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 "Digits" 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 <- nonTerminal "Direction"+    [ ("DNorth", [north]), ("DSouth", [south]), ("DEast", [east])+    , ("DWest", [west])]+  street <- terminalSeq "Street" "St"+  avenue <- terminalSeq "Avenue" "Ave"+  way <- terminalSeq "Way" "Way"+  boulevard <- terminalSeq "Boulevard" "Blvd"+  suffix <- nonTerminal "Suffix"+    [ ("SStreet", [street]), ("SAvenue", [avenue]), ("SWay", [way])+    , ("SBoulevard", [boulevard])]+  space <- terminal "Space" (solo ' ')+  comma <- terminal "Comma" (solo ',')++  -- Named "PostalWord" to avoid clash with Prelude.Word+  word <- list1 "PostalWord" letter+  preSpacedWord <- nonTerminal "PreSpacedWord"+    [("PreSpacedWord", [space, word])]+  preSpacedWords <- list "PreSpacedWords" preSpacedWord+  words <- nonTerminal "Words"+    [("Words", [word, preSpacedWords])]++  number <- wrap "Number" digits+  streetName <- wrap "StreetName" words+  city <- wrap "City" words+  state <- wrap "State" word+  zipCode <- wrap "ZipCode" digits+  directionSpace <- nonTerminal "DirectionSpace"+    [("DirectionSpace", [direction, space])]+  spaceSuffix <- nonTerminal "SpaceSuffix"+    [("SpaceSuffix", [space, suffix])]+  optDirection <- option "MaybeDirection" directionSpace+  optSuffix <- option "MaybeSuffix" spaceSuffix++  address <- nonTerminal "Address"+    [("Address", [ number, space, optDirection, streetName, optSuffix,+                   comma, space, city, comma, space, state,+                   space, zipCode ])]+  return address
+ lib/Pinchot/Examples/PostalAstAllRules.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Provides an example of the use of 'ruleTreeToCode'.  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 '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 'ruleTreeToCode', this splice will contain every rule that+-- was defined in the 'Pinchot'.+allRulesToCode ''Char [''Eq, ''Ord, ''Show] postal++-- | Earley grammar created using Template Haskell.++postalGrammar :: Grammar r (Prod r String Char Address)+postalGrammar = $(earleyGrammar "" postal)
+ lib/Pinchot/Examples/PostalAstRuleTree.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Provides an example of the use of 'ruleTreeToCode'.  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 'allRulesToCode', this splice will contain only the+-- 'Address' rule and its ancestors.++ruleTreeToCode ''Char [''Eq, ''Ord, ''Show] postal++-- | Earley grammar created using Template Haskell.++postalGrammar :: Grammar r (Prod r String Char Address)+postalGrammar = $(earleyGrammar "" postal)
+ lib/Pinchot/Examples/QualifiedImport.hs view
@@ -0,0 +1,19 @@+{-# 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)
+ lib/Pinchot/Intervals.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Intervals describe terminal symbols.  Ordinarily you will not+-- need to use this module, as "Pinchot" re-exports the things you+-- usually need.+module Pinchot.Intervals where++import Control.Monad (join)+import Data.Monoid ((<>))+import Data.Ord (comparing)+import Data.Sequence (Seq, ViewL(EmptyL, (:<)), viewl, (<|))+import qualified Data.Sequence as Seq+import Language.Haskell.TH+import Language.Haskell.TH.Syntax++-- | Groups of terminals.  Create an 'Intervals' using 'include',+-- 'exclude', 'solo' and 'pariah'.  Combine 'Intervals' using+-- 'mappend', which will combine both the included and excluded+-- terminal symbols from each operand.+data Intervals a = Intervals+  { 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)+  -- ^ Each symbol in 'excluded' is not in the 'Intervals', even if+  -- the symbol is 'included'.+  } deriving (Eq, Ord, Show)++instance Functor Intervals where+  fmap f (Intervals a b) = Intervals (fmap g a) (fmap g b)+    where+      g (x, y) = (f x, f y)++instance Monoid (Intervals a) where+  mempty = Intervals mempty mempty+  (Intervals x1 y1) `mappend` (Intervals x2 y2)+    = Intervals (x1 <> x2) (y1 <> y2)++-- | Include a range of symbols in the 'Intervals'.  For instance, to+-- include the characters @'a'@, @'b'@, and @'c'@, use @include 'a'+-- 'c'@.+include :: a -> a -> Intervals a+include l h = Intervals [(l, h)] []++-- | Exclude a range of symbols in the 'Intervals'.  Each symbol that+-- is 'exclude'd is not included in the 'Intervals', even if it is+-- also 'include'd.+exclude :: a -> a -> Intervals a+exclude l h = Intervals [] [(l, h)]++-- | Include a single symbol.+solo :: a -> Intervals a+solo x = Intervals [(x, x)] []++-- | Exclude a single symbol.+pariah :: a -> Intervals a+pariah x = Intervals [] [(x, x)]++-- | Left endpoint.+endLeft :: Ord a => (a, a) -> a+endLeft (a, b) = min a b++-- | Right endpoint.+endRight :: Ord a => (a, a) -> a+endRight (a, b) = max a b++-- | Is this symbol included in the interval?+inInterval :: Ord a => a -> (a, a) -> Bool+inInterval x i = x >= endLeft i && x <= endRight i++-- | Enumerate all members of an interval.+members :: (Ord a, Enum a) => (a, a) -> Seq a+members i = Seq.fromList [endLeft i .. endRight i]++-- | Sort a sequence of intervals.+sortIntervalSeq :: Ord a => Seq (a, a) -> Seq (a, a)+sortIntervalSeq = Seq.sortBy (comparing endLeft <> comparing endRight)++-- | Arrange an interval so the lower bound is first in the pair.+standardizeInterval :: Ord a => (a, a) -> (a, a)+standardizeInterval (a, b) = (min a b, max a b)++-- | Sorts the intervals using 'sortIntervalSeq' and presents them in a+-- regular order using 'flatten'.  The function @standardizeIntervalSeq a@ has+-- the following properties, where @b@ is the result:+--+-- @+-- 'uniqueMembers' a == 'uniqueMembers' b+--+-- let go [] = True+--     go (_:[]) = True+--     go (x:y:xs)+--          | 'endRight' x < 'endLeft' y+--              && 'endRight' x < pred ('endLeft' x)+--              = go (y:xs)+--          | otherwise = False+-- in go b+-- @+--+-- The second property means that adjacent intervals in the list must+-- be separated by at least one point on the number line.++standardizeIntervalSeq :: (Ord a, Enum a) => Seq (a, a) -> Seq (a, a)+standardizeIntervalSeq = flattenIntervalSeq . sortIntervalSeq++-- | Presents the intervals in a standard order, as described in+-- 'standardizeIntervalSeq'.  If the input has already been sorted with+-- 'sortIntervalSeq', the same properties for 'standardizeIntervalSeq' hold for+-- this function.  Otherwise, its properties are undefined.+flattenIntervalSeq :: (Ord a, Enum a) => Seq (a, a) -> Seq (a, a)+flattenIntervalSeq = fmap standardizeInterval . go Nothing+  where+    go mayCurr sq = case (mayCurr, viewl sq) of+      (Nothing, EmptyL) -> []+      (Just i, EmptyL) -> [i]+      (Nothing, x :< xs) -> go (Just x) xs+      (Just curr, x :< xs)+        | endRight curr < endLeft x+            && endRight curr < pred (endLeft x) -> curr <| go (Just x) xs+        | otherwise -> go (Just (endLeft curr,+            max (endRight curr) (endRight x))) xs+++{- |+Removes excluded members from a list of 'Interval'.  The+following properties hold:++@++removeProperties+  :: (Ord a, Enum a)+  => Seq (a, a)+  -> Seq (a, a)+  -> [Bool]+removeProperties inc exc =++ let r = removeExcludes inc exc+     allExcluded = concatMap members exc+     allIncluded = concatMap members inc+     allResults = concatMap members r+ in [+   -- intervals remain in original order+   allResults == filter (not . (\`elem\` allExcluded)) allIncluded++ -- Every resulting member was a member of the original include list+ , all (\`elem\` allIncluded) allResults++ -- No resulting member is in the exclude list+ , all (not . (\`elem\` allExcluded)) allResults++ -- Every included member that is not in the exclude list is+ -- in the result+ , all (\x -> x \`elem\` allExcluded || x \`elem\` allResults)+       allIncluded++ ]+@++-}+removeExcludes+  :: (Ord a, Enum a)+  => Seq (a, a)+  -- ^ Included intervals (not necessarily sorted)+  -> Seq (a, a)+  -- ^ Excluded intervals (not necessarily sorted)+  -> Seq (a, a)+removeExcludes inc = foldr remover inc++remover+  :: (Ord a, Enum a)+  => (a, a)+  -- ^ Remove this interval+  -> Seq (a, a)+  -- ^ From this sequence of intervals+  -> Seq (a, a)+remover ivl = join . fmap squash . fmap (removeInterval ivl)+  where+    squash (Nothing, Nothing) = Seq.empty+    squash (Just x, Nothing) = Seq.singleton x+    squash (Nothing, Just x) = Seq.singleton x+    squash (Just x, Just y) = x <| y <| Seq.empty++-- | Removes a single interval from a single other interval.  Returns+-- a sequence of intervals, which always+removeInterval+  :: (Ord a, Enum a)+  => (a, a)+  -- ^ Remove this interval+  -> (a, a)+  -- ^ From this interval+  -> (Maybe (a, a), Maybe (a, a))+removeInterval ivl oldIvl = (onLeft, onRight)+  where+    onLeft+      | endLeft ivl > endLeft oldIvl =+          Just ( endLeft oldIvl+               , min (pred (endLeft ivl)) (endRight oldIvl))+      | otherwise = Nothing+    onRight+      | endRight ivl < endRight oldIvl =+          Just ( max (succ (endRight ivl)) (endLeft oldIvl)+               , endRight oldIvl)+      | otherwise = Nothing++-- | Runs 'standardizeIntervalSeq' on the 'included' and 'excluded'+-- intervals.+standardizeIntervals+  :: (Ord a, Enum a)+  => Intervals a+  -> Intervals a+standardizeIntervals (Intervals i e)+  = Intervals (standardizeIntervalSeq i) (standardizeIntervalSeq e)++-- | Sorts the intervals using 'standardizeIntervalSeq', and then removes the+-- excludes with 'removeExcludes'.+splitIntervals+  :: (Ord a, Enum a)+  => Intervals a+  -> Seq (a, a)+splitIntervals (Intervals is es)+  = removeExcludes (standardizeIntervalSeq is) es++-- | 'True' if the given element is a member of the 'Intervals'.+inIntervals :: (Enum a, Ord a) => Intervals a -> a -> Bool+inIntervals ivls a = any (inInterval a) . splitIntervals $ ivls++liftSeq :: Lift a => Seq a -> ExpQ+liftSeq sq = case viewl sq of+  EmptyL -> varE 'Seq.empty+  x :< xs -> uInfixE (lift x) (varE '(<|)) (liftSeq xs)++instance Lift a => Lift (Intervals a) where+  lift (Intervals inc exc) = [| Intervals $sqInc $sqExc |]+    where+      sqInc = liftSeq inc+      sqExc = liftSeq exc
+ pinchot.cabal view
@@ -0,0 +1,125 @@+-- This Cabal file generated using the Cartel library.+-- Cartel is available at:+-- http://www.github.com/massysett/cartel+--+-- Script name used to generate: genCabal.hs+-- Generated on: 2015-12-05 12:15:13.707206 EST+-- Cartel library version: 0.14.2.8++name: pinchot+version: 0.2.0.0+cabal-version: >= 1.14+license: BSD3+license-file: LICENSE+build-type: Simple+copyright: 2015 Omari Norman+author: Omari Norman+maintainer: omari@smileystation.com+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+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+  automatically generate data types corresponding to the grammar,+  as well as an Earley parser to parse strings in that grammar.+  .+  For more documentation, see the Haddocks for the main Pinchot module.+category: Development+extra-source-files:+  README++Library+  exposed-modules:+    Pinchot+    Pinchot.Examples+    Pinchot.Examples.Postal+    Pinchot.Examples.PostalAstAllRules+    Pinchot.Examples.PostalAstRuleTree+    Pinchot.Examples.QualifiedImport+    Pinchot.Intervals+  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+  ghc-options:+    -Wall+  other-extensions:+    TemplateHaskell+  default-language: Haskell2010+  hs-source-dirs:+    lib++source-repository head+  type: git+  location: https://github.com/massysett/penny.git++Executable print-postal-grammar+  main-is: print-postal-grammar.hs+  if flag(executables)+    buildable: True+    other-modules:+      Pinchot+      Pinchot.Examples+      Pinchot.Examples.Postal+      Pinchot.Examples.PostalAstAllRules+      Pinchot.Examples.PostalAstRuleTree+      Pinchot.Examples.QualifiedImport+      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+    ghc-options:+      -Wall+    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.Postal+      Pinchot.Examples.PostalAstAllRules+      Pinchot.Examples.PostalAstRuleTree+      Pinchot.Examples.QualifiedImport+      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+    ghc-options:+      -Wall+    other-extensions:+      TemplateHaskell+    default-language: Haskell2010+    hs-source-dirs:+      lib+  else+    buildable: False++Flag executables+  description: Build executables+  default: False+  manual: True