diff --git a/exe/parrot.hs b/exe/parrot.hs new file mode 100644 --- /dev/null +++ b/exe/parrot.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedLists #-} + +-- | 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 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 . terminals + mapM_ printSeq ls diff --git a/lib/Pinchot.hs b/lib/Pinchot.hs --- a/lib/Pinchot.hs +++ b/lib/Pinchot.hs @@ -8,6 +8,15 @@ 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. @@ -69,6 +78,9 @@ , noOptics , allRulesToTypes , ruleTreeToTypes + + -- * Manipulating productions + , Production(..) ) where import Pinchot.Internal diff --git a/lib/Pinchot/Examples.hs b/lib/Pinchot/Examples.hs --- a/lib/Pinchot/Examples.hs +++ b/lib/Pinchot/Examples.hs @@ -1,4 +1,5 @@ {-# 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 @@ -13,13 +14,22 @@ -- "Pinchot.Examples.PostalAstRuleTree" shows you how to use -- 'ruleTreeToTypes' and 'earleyGrammar'. -- --- 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 +-- Three 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. +-- 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. +-- +-- 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. module Pinchot.Examples where diff --git a/lib/Pinchot/Examples/Postal.hs b/lib/Pinchot/Examples/Postal.hs --- a/lib/Pinchot/Examples/Postal.hs +++ b/lib/Pinchot/Examples/Postal.hs @@ -33,7 +33,7 @@ space <- terminal "Space" (solo ' ') comma <- terminal "Comma" (solo ',') - -- You could do this with 'many' but this demonstrates how to write + -- You could do this with 'list' but this demonstrates how to write -- a recurvsive rule. letters <- nonTerminal "Letters" [ ("NoLetter", []) diff --git a/lib/Pinchot/Examples/PostalAstNoLenses.hs b/lib/Pinchot/Examples/PostalAstNoLenses.hs --- a/lib/Pinchot/Examples/PostalAstNoLenses.hs +++ b/lib/Pinchot/Examples/PostalAstNoLenses.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE TypeFamilies #-} -- | Provides an example of 'ruleTreeToTypes', but unlike -- "Pinchot.Examples.PostalAstAllRules", does not make optics. diff --git a/lib/Pinchot/Internal.hs b/lib/Pinchot/Internal.hs --- a/lib/Pinchot/Internal.hs +++ b/lib/Pinchot/Internal.hs @@ -1,5 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} -- | Pinchot internals. Ordinarily the "Pinchot" module should have -- everything you need. @@ -62,8 +63,8 @@ | RBranch (Branch t, Seq (Branch t)) | RSeqTerm (Seq t) | ROptional (Rule t) - | RMany (Rule t) - | RMany1 (Rule t) + | RList (Rule t) + | RList1 (Rule t) | RWrap (Rule t) | RRecord (Seq (Rule t)) deriving (Eq, Ord, Show) @@ -243,8 +244,8 @@ branchName (Branch x _) = x RSeqTerm _ -> Seq.singleton n ROptional _ -> Seq.singleton n - RMany _ -> Seq.singleton n - RMany1 _ -> Seq.singleton n + RList _ -> Seq.singleton n + RList1 _ -> Seq.singleton n RWrap _ -> Seq.singleton n RRecord _ -> Seq.singleton n @@ -291,7 +292,7 @@ -- 'Rule'; that is, this 'Rule' may appear zero or more times. -> Pinchot t (Rule t) -list name r = newRule name (RMany r) +list name r = newRule name (RList r) -- | Creates a rule for a production that appears at least once. list1 @@ -299,7 +300,7 @@ -> Rule t -- ^ The resulting 'Rule' produces this 'Rule' at least once. -> Pinchot t (Rule t) -list1 name r = newRule name (RMany1 r) +list1 name r = newRule name (RList1 r) -- | Creates a rule for a production that optionally produces another -- rule. @@ -341,10 +342,10 @@ ROptional c -> do cs <- getAncestors c return $ r <| cs - RMany c -> do + RList c -> do cs <- getAncestors c return $ r <| cs - RMany1 c -> do + RList1 c -> do cs <- getAncestors c return $ r <| cs RWrap c -> do @@ -377,8 +378,8 @@ 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 + 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 @@ -396,7 +397,8 @@ thRule - :: Bool + :: Syntax.Lift t + => Bool -- ^ If True, make lenses. -> Name -- ^ Name of terminal type @@ -406,11 +408,9 @@ -> TH.Q [TH.Dec] thRule doLenses typeName derives (Rule nm _ ruleType) = do ty <- makeType typeName derives nm ruleType - return (ty : lenses) - where - lenses - | doLenses = ruleToOptics typeName nm ruleType - | otherwise = [] + lenses <- if doLenses then ruleToOptics typeName nm ruleType + else return [] + return (ty : productionInstance typeName nm ruleType : lenses) makeType @@ -444,13 +444,13 @@ [strictType notStrict (appT [t| Maybe |] (conT (mkName inner)))] - RMany (Rule inner _ _) -> newtypeD (cxt []) name [] newtypeCon derives + RList (Rule inner _ _) -> newtypeD (cxt []) name [] newtypeCon derives where newtypeCon = normalC name [strictType notStrict (appT [t| Seq |] (conT (mkName inner)))] - RMany1 (Rule inner _ _) -> newtypeD (cxt []) name [] cons derives + RList1 (Rule inner _ _) -> newtypeD (cxt []) name [] cons derives where cons = normalC name [ strictType notStrict (TH.tupleT 2 `appT` (conT (mkName inner)) @@ -485,7 +485,8 @@ fieldName idx par inn = "f'" ++ par ++ "'" ++ show idx ++ "'" ++ inn thAllRules - :: Bool + :: Syntax.Lift t + => Bool -- ^ If True, make optics as well. -> Name -- ^ Terminal type constructor name @@ -531,15 +532,58 @@ `TH.AppE` (TH.VarE local) lambPat = TH.VarP local +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 + |] + terminalToOptics - :: Name + :: Syntax.Lift t + => Name -- ^ Terminal type name -> String -- ^ Rule name - -> TH.Dec -terminalToOptics terminalName = makeWrapped term + -> 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 - term = TH.ConT terminalName + 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 @@ -713,40 +757,54 @@ ruleToOptics - :: Name + :: Syntax.Lift t + => Name -- ^ Terminal type name -> String -- ^ Rule name -> RuleType t - -> [TH.Dec] + -> TH.DecsQ ruleToOptics terminalName nm ty = case ty of - RTerminal _ -> [terminalToOptics terminalName nm] - RBranch (b1, bs) -> branchesToOptics nm b1 bs - RSeqTerm _ -> [terminalSeqToOptics terminalName nm] - ROptional (Rule inner _ _) -> [optionalToOptics inner nm] - RMany (Rule inner _ _) -> [manyToOptics inner nm] - RMany1 (Rule inner _ _) -> [many1ToOptics inner nm] - RWrap (Rule inner _ _) -> [wrapToOptics inner nm] - RRecord recs -> recordsToOptics nm recs + RTerminal ivl -> terminalToOptics terminalName nm ivl + RBranch (b1, bs) -> return $ branchesToOptics nm b1 bs + 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 to have a --- --- {-\# LANGUAGE TypeFamilies \#-} +-- | Creates optics. -- -- pragma at the top of the module in which you splice this in. -- -- Creates the listed optics for each kind of -- 'Rule', as follows: -- --- * 'terminal': 'Lens.Wrapped', wrapping the type of the terminal. +-- * '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'. -- --- * 'terminalSeq': 'Lens.Wrapped', wrapping a @'Seq' a@, where @a@ is --- the type of the terminal. +-- >>> ',' ^? _Comma +-- Just (Comma ',') +-- >>> 'a' ^? _Comma +-- Nothing +-- >>> Comma ',' ^. re _Comma +-- ',' -- --- * 'nonTerminal': one 'Lens.Prism' for each data constructor (even if +-- 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 @@ -776,8 +834,8 @@ -- "Pinchot.Examples.PostalAstAllRules". allRulesToTypes - - :: MakeOptics + :: Syntax.Lift t + => MakeOptics -> Name -- ^ Terminal type constructor name. Typically you will use the @@ -801,7 +859,8 @@ -- | Creates data types only for the 'Rule' returned from the 'Pinchot', and -- for its ancestors. ruleTreeToTypes - :: MakeOptics + :: Syntax.Lift t + => MakeOptics -> Name -- ^ Terminal type constructor name. Typically you will use the @@ -865,7 +924,7 @@ where just = [| fmap Just $(varE (ruleName innerNm)) |] - RMany (Rule innerNm _ _) -> do + RList (Rule innerNm _ _) -> do let nestRule = bindS (varP helper) ([|rule|] `appE` parseSeq) where parseSeq = uInfixE [|pure Seq.empty|] [|(<|>)|] pSeq @@ -875,7 +934,7 @@ top <- makeRule $ wrapper helper return [nest, top] - RMany1 (Rule innerNm _ _) -> do + RList1 (Rule innerNm _ _) -> do let nestRule = bindS (varP helper) [|rule $(parseSeq)|] where parseSeq = [| pure Seq.empty <|> $pSeq |] @@ -1021,3 +1080,114 @@ 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. + +class Production a where + type Terminal a :: * + terminals :: a -> Seq (Terminal a) + +-- | Creates a 'Production' instance for a 'Rule'. + +productionInstance + :: Name + -- ^ Terminal type + -> String + -- ^ Rule name + -> RuleType t + -> TH.Dec +productionInstance term n t = TH.InstanceD [] ty ds + where + ty = TH.ConT ''Production `TH.AppT` (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 (TH.VarE 'Seq.singleton + `TH.AppE` 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 (TH.VarE (TH.mkName "_x")) + + ROptional _ -> [justClause, nothingClause] + where + justClause + = TH.Clause [TH.ConP (TH.mkName n) + [TH.ConP 'Just [TH.VarP (TH.mkName "_x")]]] + (TH.NormalB (TH.VarE 'terminals + `TH.AppE` (TH.VarE (TH.mkName "_x")))) + [] + nothingClause + = TH.Clause [TH.ConP (TH.mkName n) + [TH.ConP 'Nothing []]] + (TH.NormalB (TH.VarE 'Seq.empty)) [] + + RList _ -> [TH.Clause [pat] bdy []] + where + pat = TH.ConP (TH.mkName n) [TH.VarP (TH.mkName "_x")] + bdy = (TH.NormalB (TH.VarE 'join + `TH.AppE` ((TH.VarE 'fmap) `TH.AppE` (TH.VarE 'terminals) + `TH.AppE` (TH.VarE (TH.mkName "_x"))))) + + RList1 _ -> [TH.Clause [pat] bdy []] + where + pat = TH.ConP (TH.mkName n) + [TH.TupP [ TH.VarP (TH.mkName "_x1") + , TH.VarP (TH.mkName "_xs")]] + bdy = TH.NormalB (TH.UInfixE lft mpnd rst) + where + lft = TH.VarE 'terminals `TH.AppE` TH.VarE (TH.mkName "_x1") + mpnd = TH.VarE 'mappend + rst = TH.VarE 'join `TH.AppE` nested + where + nested = TH.VarE 'fmap `TH.AppE` TH.VarE 'terminals + `TH.AppE` TH.VarE (TH.mkName "_xs") + + RWrap _ -> [TH.Clause [pat] bdy []] + where + pat = TH.ConP (TH.mkName n) [TH.VarP (TH.mkName "_x")] + bdy = TH.NormalB (TH.VarE 'terminals `TH.AppE` + TH.VarE (TH.mkName "_x")) + + RRecord sq -> [TH.Clause [pat] (TH.NormalB bdy) []] + where + pat = TH.ConP (TH.mkName n) . fmap mkPat + . take (Seq.length sq) $ [0 :: Int ..] + where + mkPat idx = TH.VarP (TH.mkName ("_x" ++ show idx)) + bdy = foldr addField (TH.VarE 'Seq.empty) + . take (Seq.length sq) $ [0 :: Int ..] + where + addField idx acc = TH.UInfixE this cons acc + where + this = TH.VarE 'terminals `TH.AppE` TH.VarE + (TH.mkName ("_x" ++ show idx)) + cons = TH.VarE 'mappend + +branchToClause :: Branch t -> TH.Clause +branchToClause (Branch n rs) = TH.Clause [pat] bdy [] + where + pat = TH.ConP (TH.mkName n) fields + where + fields = fmap mkField . take (Seq.length rs) $ [0 :: Int ..] + where + mkField idx = TH.VarP (TH.mkName ("_x" ++ show idx)) + bdy = TH.NormalB (TH.VarE 'join `TH.AppE` sq) + where + sq = foldr addField (TH.VarE 'Seq.empty) + . take (Seq.length rs) $ [0 :: Int ..] + where + addField idx acc = TH.UInfixE newTerm cons acc + where + newTerm = (TH.VarE 'terminals) + `TH.AppE` (TH.VarE (TH.mkName ("_x" ++ show idx))) + cons = TH.VarE '(<|) diff --git a/pinchot.cabal b/pinchot.cabal --- a/pinchot.cabal +++ b/pinchot.cabal @@ -3,11 +3,11 @@ -- http://www.github.com/massysett/cartel -- -- Script name used to generate: genCabal.hs --- Generated on: 2015-12-13 10:06:27.884105 EST +-- Generated on: 2015-12-16 22:57:48.137493 EST -- Cartel library version: 0.14.2.8 name: pinchot -version: 0.4.0.0 +version: 0.6.0.0 cabal-version: >= 1.14 license: BSD3 license-file: LICENSE @@ -113,6 +113,39 @@ 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 + ghc-options: + -Wall + 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.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