pinchot 0.10.0.0 → 0.12.0.0
raw patch · 7 files changed
+238/−160 lines, 7 files
Files
- lib/Pinchot.hs +3/−14
- lib/Pinchot/Examples.hs +3/−0
- lib/Pinchot/Examples/AllEarleyGrammars.hs +12/−0
- lib/Pinchot/Examples/PostalAstAllRules.hs +1/−1
- lib/Pinchot/Examples/PostalAstNoLenses.hs +0/−1
- lib/Pinchot/Internal.hs +213/−134
- pinchot.cabal +6/−10
lib/Pinchot.hs view
@@ -8,15 +8,6 @@ Template Haskell to create an Earley parser that will parse all strings in the context-free language. -You will need to have--@-\{\-\# LANGUAGE TypeFamilies \#\-\}-@--at the top of any module in which you use Template Haskell to splice in-the resulting data types.- For examples, please consult "Pinchot.Examples". You should also look at the BNF Converter.@@ -71,16 +62,14 @@ , label , (<?>) - -- * Transforming an AST to code- , earleyGrammar+ -- * Transforming a Pinchot value to code , MakeOptics , makeOptics , noOptics , allRulesToTypes , ruleTreeToTypes-- -- * Manipulating productions- , Production(..)+ , earleyGrammar+ , allEarleyGrammars ) where import Pinchot.Internal
lib/Pinchot/Examples.hs view
@@ -14,6 +14,9 @@ -- "Pinchot.Examples.PostalAstRuleTree" shows you how to use -- 'ruleTreeToTypes' and 'earleyGrammar'. --+-- "Pinchot.Examples.AllEarleyGrammars" shows you how to use+-- 'allEarleyGrammars'.+-- -- Three executables are included in the @pinchot@ package. To get -- them, compile @pinchot@ with the @executables@ Cabal flag. --
+ lib/Pinchot/Examples/AllEarleyGrammars.hs view
@@ -0,0 +1,12 @@+{-# 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 Pinchot+import Pinchot.Examples.Postal+import Pinchot.Examples.PostalAstAllRules++allEarleyGrammars "" postal
lib/Pinchot/Examples/PostalAstAllRules.hs view
@@ -11,7 +11,7 @@ import Pinchot import Pinchot.Examples.Postal --- Earley is imported only for the type signature for 'myParser'. The+-- Earley is imported only for the type signature for 'postalGrammar'. The -- Template Haskell does not need the import. import Text.Earley (Grammar, Prod)
lib/Pinchot/Examples/PostalAstNoLenses.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedLists #-}-{-# LANGUAGE TypeFamilies #-} -- | Provides an example of 'ruleTreeToTypes', but unlike -- "Pinchot.Examples.PostalAstAllRules", does not make optics.
lib/Pinchot/Internal.hs view
@@ -28,8 +28,8 @@ import Data.Typeable (Typeable) import Language.Haskell.TH (ExpQ, ConQ, normalC, mkName, strictType, notStrict, newtypeD,- cxt, conT, Name, dataD, appT, DecsQ, appE, Q, Stmt(NoBindS), uInfixE, bindS,- varE, varP, conE, Pat, Exp(AppE, DoE), lamE, recC, varStrictType, dyn)+ cxt, conT, Name, dataD, appT, DecsQ, appE, Q, uInfixE, bindS,+ varE, varP, conE, Pat, Exp, lamE, recC, varStrictType, dyn) import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Syntax as Syntax import Text.Earley (satisfy, rule, symbol)@@ -457,7 +457,7 @@ ty <- makeType typeName derives nm ruleType lenses <- if doLenses then ruleToOptics typeName nm ruleType else return []- inst <- productionInstance typeName nm ruleType+ inst <- productionDecl nm ruleType return (ty : inst : lenses) @@ -871,8 +871,14 @@ -- | Creates optics. ----- pragma at the top of the module in which you splice this in.+-- 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: --@@ -924,6 +930,10 @@ -- 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@@ -950,6 +960,10 @@ -- | 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@@ -989,25 +1003,21 @@ => String -- ^ Module prefix -> Rule t- -> Q [Stmt]+ -> [TH.StmtQ] ruleToParser prefix (Rule nm mayDescription rt) = case rt of - RTerminal ivls -> do- topRule <- makeRule expression- return [topRule]+ RTerminal ivls -> [makeRule expression] where expression = [| fmap $constructor (satisfy (inIntervals ivls)) |] - RBranch (b1, bs) -> do- topRule <- makeRule expression- return [topRule]+ 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) -> fmap (:[]) (makeRule expression)+ RUnion (Rule r1 _ _, rs) -> [makeRule expression] where expression = foldl adder start rs where@@ -1017,50 +1027,45 @@ start = branch r1 adder soFar (Rule r _ _) = [| $soFar <|> $(branch r) |] - RSeqTerm sq -> do- let nestRule = bindS (varP helper) [| rule $(foldl addTerm start sq) |]- where- start = [|pure Seq.empty|]- addTerm acc x = [| liftA2 (<|) (symbol x) $acc |]- nest <- nestRule- topRule <- makeRule (wrapper helper)- return [nest, topRule]+ RSeqTerm sq -> [nestRule, topRule]+ where+ nestRule = bindS (varP 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 _ _) -> fmap (:[]) (makeRule expression)+ ROptional (Rule innerNm _ _) -> [makeRule expression] where expression = [| fmap $constructor (pure Nothing <|> $(just)) |] where just = [| fmap Just $(varE (ruleName innerNm)) |] - RList (Rule innerNm _ _) -> do- let nestRule = bindS (varP helper) ([|rule|] `appE` parseSeq)- where- parseSeq = uInfixE [|pure Seq.empty|] [|(<|>)|] pSeq- where- pSeq = [|liftA2 (<|) $(varE (ruleName innerNm)) $(varE helper) |]- nest <- nestRule- top <- makeRule $ wrapper helper- return [nest, top]+ RList (Rule innerNm _ _) -> [nestRule, makeRule (wrapper helper)]+ where+ nestRule = bindS (varP helper) ([|rule|] `appE` parseSeq)+ where+ parseSeq = uInfixE [|pure Seq.empty|] [|(<|>)|] pSeq+ where+ pSeq = [|liftA2 (<|) $(varE (ruleName innerNm)) $(varE helper) |] - RList1 (Rule innerNm _ _) -> do- let nestRule = bindS (varP helper) [|rule $(parseSeq)|]- where- parseSeq = [| pure Seq.empty <|> $pSeq |]- where- pSeq = [| (<|) <$> $(varE (ruleName innerNm))- <*> $(varE helper) |]- nest <- nestRule- let topExpn = [| $constructor <$> ( (,) <$> $(varE (ruleName innerNm))+ RList1 (Rule innerNm _ _) -> [nestRule, makeRule topExpn]+ where+ nestRule = bindS (varP helper) [|rule $(parseSeq)|]+ where+ parseSeq = [| pure Seq.empty <|> $pSeq |]+ where+ pSeq = [| (<|) <$> $(varE (ruleName innerNm))+ <*> $(varE helper) |]+ topExpn = [| $constructor <$> ( (,) <$> $(varE (ruleName innerNm)) <*> $(varE helper)- ) |]- top <- makeRule topExpn- return [nest, top]+ ) |] - RWrap (Rule innerNm _ _) -> fmap (:[]) (makeRule expression)+ RWrap (Rule innerNm _ _) -> [makeRule expression] where expression = [|fmap $constructor $(varE (ruleName innerNm)) |] - RRecord sq -> fmap (:[]) (makeRule expression)+ RRecord sq -> [makeRule expression] where expression = case viewl sq of EmptyL -> [| pure $constructor |]@@ -1170,114 +1175,189 @@ -> 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 = 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) |]+ Right r -> earleyGrammarFromRule prefix r where (ei, _) = runState (runExceptT (runPinchot pinc)) (Names Set.empty Set.empty 0 M.empty) --- | Typeclass for all productions, which allows you to extract a--- sequence of terminal symbols from any production.+earleyGrammarFromRule+ :: Syntax.Lift t+ => String+ -- ^ Module prefix+ -> Rule t+ -> Q Exp+earleyGrammarFromRule prefix r@(Rule top _ _) = [| fmap fst (mfix $lamb) |]+ where+ neededRules = ruleAndAncestors r+ otherNames = rulesDemandedBeforeDefined neededRules+ expression =+ let stmts = concatMap (ruleToParser prefix)+ . toList $ neededRules+ result = bigTuple (ruleName top) otherNames+ in TH.doE (stmts ++ [TH.noBindS ([|return|] `appE` result)])+ lamb = lamE [lazyPattern otherNames] expression -class Production a where- type Terminal a :: *- terminals :: a -> Seq (Terminal a)+-- | Creates an Earley grammar for each 'Rule' created in a+-- 'Pinchot'. --- | Creates a 'Production' instance for a 'Rule'.-productionInstance- :: Name- -- ^ Terminal type- -> String+allEarleyGrammars+ :: Syntax.Lift t++ => String+ -- ^ Module prefix. You have to make sure that the data types you+ -- created with 'ruleTreeToTypes' or with 'allRulesToTypes' are in+ -- scope, either because they were spliced into the same module that+ -- 'earleyParser' is spliced into, or because they are @import@ed+ -- into scope. The spliced Template Haskell code has to know where+ -- to look for these data types. If you did an unqualified @import@+ -- or if the types are in the same module as is the splice of+ -- 'earleyParser', just pass the empty string here. If you did a+ -- qualified import, pass the appropriate namespace here.+ --+ -- For example, if you used @import qualified MyAst@, pass+ -- @\"MyAst\"@ here. If you used @import qualified+ -- Data.MyLibrary.MyAst as MyLibrary.MyAst@, pass+ -- @\"MyLibrary.MyAst\"@ here.+ --+ -- This argument is similar to that for 'earleyGrammar' so+ -- the examples there might be useful.+ --+ -- For an example using this function, please see+ -- "Pinchot.Examples.AllEarleyGrammars".++ -> 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 pinc = case ei of+ Left err -> fail $ "pinchot: bad grammar: " ++ show err+ Right _ -> sequence . fmap makeDecl . fmap snd . M.toList . allRules $ st+ where+ (ei, st) = runState (runExceptT (runPinchot pinc))+ (Names Set.empty Set.empty 0 M.empty)+ makeDecl rule@(Rule nm _ _) = TH.valD pat body []+ where+ pat = TH.varP (TH.mkName $ "g'" ++ nm)+ body = TH.normalB (earleyGrammarFromRule prefix rule)+++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 -> RuleType t -> TH.DecQ-productionInstance term n t = TH.instanceD (return []) ty ds+productionDecl n t = TH.funD (prodDeclName n) clauses where- ty = [t| Production $(TH.conT (TH.mkName n)) |]- ds = [syn, TH.funD 'terminals clauses]- where- syn = TH.tySynInstD ''Terminal- $ TH.tySynEqn [ TH.conT (TH.mkName n) ] (TH.conT term)- 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")) |]+ 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)+ 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")+ RSeqTerm _ -> [TH.clause [pat] bdy []]+ where+ pat = TH.conP (TH.mkName n) [TH.varP (TH.mkName "_x")]+ bdy = TH.normalB (dyn "_x") - ROptional _ -> [justClause, nothingClause]- where- justClause- = TH.clause [TH.conP (TH.mkName n)- [TH.conP 'Just [TH.varP (TH.mkName "_b")]]]- (TH.normalB [| terminals $(TH.varE (TH.mkName "_b")) |])- []- nothingClause- = TH.clause [TH.conP (TH.mkName n)- [TH.conP 'Nothing []]]- (TH.normalB [| Seq.empty |]) []+ 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 _ -> [TH.clause [pat] bdy []]- where- pat = TH.conP (TH.mkName n) [TH.varP (TH.mkName "_a")] - bdy = TH.normalB [| join- $ fmap terminals $(TH.varE (TH.mkName "_a")) |]+ 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 _ -> [TH.clause [pat] bdy []]+ 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- pat = TH.conP (TH.mkName n)- [TH.tupP [ dynP "_x1", dynP "_xs" ]]- bdy = TH.normalB- [| $lft `mappend` (join (fmap terminals- $(dyn "_xs"))) |]- where- lft = [| terminals $(dyn "_x1") |]+ lft = [| $(prodFn inner) $(dyn "_x1") |] - RWrap _ -> [TH.clause [pat] bdy []]- where- pat = TH.conP (TH.mkName n) [dynP "_x"]- bdy = TH.normalB [| terminals $(dyn "_x") |]+ 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) []]+ RRecord sq -> [TH.clause [pat] (TH.normalB bdy) []]+ where+ pat = TH.conP (TH.mkName n) . fmap mkPat+ . fmap fst . addIndices $ sq where- pat = TH.conP (TH.mkName n) . fmap mkPat- . take (Seq.length sq) $ [0 :: Int ..]- where- mkPat idx = dynP ("_x" ++ show idx)- bdy = foldr addField [| Seq.empty |]- . take (Seq.length sq) $ [0 :: Int ..]+ mkPat idx = dynP ("_x'" ++ show idx)+ bdy = foldr addField [| Seq.empty |] . addIndices $ sq+ where+ addField (idx, (Rule nm _ _)) acc = [| $this `mappend` $acc |] where- addField idx acc = [| $this `mappend` $acc |]- where- this = [| terminals $(dyn ("_x" ++ show idx)) |]+ this = [| $(prodFn nm) $(dyn ("_x'" ++ show idx)) |] - RUnion (r1, rs) -> mkClause r1 : fmap mkClause (toList rs)+ RUnion (r1, rs) -> mkClause r1 : fmap mkClause (toList rs)+ where+ mkClause (Rule inner _ _) = TH.clause [pat] bdy [] where- mkClause (Rule inner _ _) = TH.clause [pat] bdy []- where- pat = TH.conP (TH.mkName (unionBranchName n inner))- [dynP "_x"]- bdy = TH.normalB [| terminals $(dyn "_x") |]+ pat = TH.conP (TH.mkName (unionBranchName n inner))+ [dynP "_x"]+ bdy = TH.normalB [| $(prodFn inner) $(dyn "_x") |] branchToClause :: Branch t -> TH.ClauseQ@@ -1285,15 +1365,14 @@ where pat = TH.conP (TH.mkName n) fields where- fields = fmap mkField . take (Seq.length rs) $ [0 :: Int ..]+ fields = fmap mkField . fmap fst . addIndices $ rs where- mkField idx = TH.varP (TH.mkName ("_x" ++ show idx))+ mkField idx = TH.varP (TH.mkName ("_x'" ++ show idx)) bdy = TH.normalB [| join $sq |] where- sq = foldr addField (TH.varE 'Seq.empty)- . take (Seq.length rs) $ [0 :: Int ..]+ sq = foldr addField (TH.varE 'Seq.empty) . addIndices $ rs where- addField idx acc = [| $newTerm <| $acc |]+ addField (idx, (Rule inner _ _)) acc = [| $newTerm <| $acc |] where- newTerm = [| terminals $(TH.varE- (TH.mkName ("_x" ++ show idx))) |]+ newTerm = [| $(prodFn inner) $(TH.varE+ (TH.mkName ("_x'" ++ show idx))) |]
pinchot.cabal view
@@ -3,11 +3,11 @@ -- http://www.github.com/massysett/cartel -- -- Script name used to generate: genCabal.hs--- Generated on: 2016-01-27 06:31:22.93227 EST+-- Generated on: 2016-02-27 17:45:07.736409 EST -- Cartel library version: 0.14.2.8 name: pinchot-version: 0.10.0.0+version: 0.12.0.0 cabal-version: >= 1.14 license: BSD3 license-file: LICENSE@@ -35,6 +35,7 @@ exposed-modules: Pinchot Pinchot.Examples+ Pinchot.Examples.AllEarleyGrammars Pinchot.Examples.Postal Pinchot.Examples.PostalAstAllRules Pinchot.Examples.PostalAstNoLenses@@ -49,8 +50,6 @@ , template-haskell >= 2.10 , Earley >= 0.10.1.0 , lens >= 4.13- ghc-options:- -Wall other-extensions: TemplateHaskell default-language: Haskell2010@@ -68,6 +67,7 @@ other-modules: Pinchot Pinchot.Examples+ Pinchot.Examples.AllEarleyGrammars Pinchot.Examples.Postal Pinchot.Examples.PostalAstAllRules Pinchot.Examples.PostalAstNoLenses@@ -84,8 +84,6 @@ , template-haskell >= 2.10 , Earley >= 0.10.1.0 , lens >= 4.13- ghc-options:- -Wall other-extensions: TemplateHaskell default-language: Haskell2010@@ -101,6 +99,7 @@ other-modules: Pinchot Pinchot.Examples+ Pinchot.Examples.AllEarleyGrammars Pinchot.Examples.Postal Pinchot.Examples.PostalAstAllRules Pinchot.Examples.PostalAstNoLenses@@ -118,8 +117,6 @@ , template-haskell >= 2.10 , Earley >= 0.10.1.0 , lens >= 4.13- ghc-options:- -Wall other-extensions: TemplateHaskell default-language: Haskell2010@@ -135,6 +132,7 @@ other-modules: Pinchot Pinchot.Examples+ Pinchot.Examples.AllEarleyGrammars Pinchot.Examples.Postal Pinchot.Examples.PostalAstAllRules Pinchot.Examples.PostalAstNoLenses@@ -151,8 +149,6 @@ , template-haskell >= 2.10 , Earley >= 0.10.1.0 , lens >= 4.13- ghc-options:- -Wall other-extensions: TemplateHaskell default-language: Haskell2010