peggy 0.3.1 → 0.3.1.1
raw patch · 19 files changed
+1619/−1619 lines, 19 filesdep ~mtlsetup-changedPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: mtl
API changes (from Hackage documentation)
Files
- LICENSE +30/−30
- README.md +69/−69
- Setup.hs +2/−2
- Text/Peggy.hs +11/−11
- Text/Peggy/CodeGen/TH.hs +311/−311
- Text/Peggy/LeftRec.hs +72/−72
- Text/Peggy/Normalize.hs +87/−87
- Text/Peggy/Parser.hs +294/−294
- Text/Peggy/Prim.hs +244/−244
- Text/Peggy/Quote.hs +134/−134
- Text/Peggy/SrcLoc.hs +34/−34
- Text/Peggy/Syntax.hs +64/−64
- bootstrap/Bootstrap.hs +39/−39
- bootstrap/README.md +10/−10
- bootstrap/Stage1.hs +10/−10
- bootstrap/Stage2.hs +13/−13
- bootstrap/peggy.peggy +102/−102
- example/Main.hs +31/−31
- peggy.cabal +62/−62
LICENSE view
@@ -1,30 +1,30 @@-Copyright (c)2011, Hideyuki Tanaka--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 Hideyuki Tanaka nor the names of other- contributors 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-OWNER 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.+Copyright (c)2011, Hideyuki Tanaka + +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 Hideyuki Tanaka nor the names of other + contributors 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 +OWNER 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.md view
@@ -1,69 +1,69 @@-# Peggy: A Parser Generator of Parsing Expression Grammer (PEG) #--# About--This is an yet another parser generator of Parsing Expression Grammer (PEG) which is:--* Simple-* Concise-* Fast-* Modern--# Usage--You can find a recent stable release in Hackage DB.-You can install this as following instruction:--~~~ {.bash}-$ cabal update-$ cabal install Peggy-~~~--# Why should you use Peggy?--Haskell has commonly used parser generators, one of them are Alex/Happy.-But I think Alex/Happy are not good in these points:--* Generates regacy codes--Alex uses only too basic libraries.-It does not use monad-transformers, iteratee, ListLike, Text, and so on.--* Tradisional Regexp/CFG based parser--Parsec has no good error recovery.--unnun, kannun...--...--# Quick Start--Here is an example of parsing arithmetic expressions.--~~~ {.haskell}-{-# QuasiQuotes #-}-{-# Language FlexibleContexts #-}--import Text.Peggy--[peggy|-exp :: Double- = exp "+" fact { $1 + $2 }- / exp "-" fact { $1 - $2 }- / fact-fact :: Double- = fact "*" term { $1 * $2 }- / fact "/" term { $1 / $2 }- / term-term :: Double- = "(" exp ")"- / number-number ::: Double- = ([1-9][0-9]*) { read $1 }-|]--main :: IO ()-main =- print . parse exp =<< getContents-~~~+# Peggy: A Parser Generator of Parsing Expression Grammer (PEG) # + +# About + +This is an yet another parser generator of Parsing Expression Grammer (PEG) which is: + +* Simple +* Concise +* Fast +* Modern + +# Usage + +You can find a recent stable release in Hackage DB. +You can install this as following instruction: + +~~~ {.bash} +$ cabal update +$ cabal install Peggy +~~~ + +# Why should you use Peggy? + +Haskell has commonly used parser generators, one of them are Alex/Happy. +But I think Alex/Happy are not good in these points: + +* Generates regacy codes + +Alex uses only too basic libraries. +It does not use monad-transformers, iteratee, ListLike, Text, and so on. + +* Tradisional Regexp/CFG based parser + +Parsec has no good error recovery. + +unnun, kannun... + +... + +# Quick Start + +Here is an example of parsing arithmetic expressions. + +~~~ {.haskell} +{-# QuasiQuotes #-} +{-# Language FlexibleContexts #-} + +import Text.Peggy + +[peggy| +exp :: Double + = exp "+" fact { $1 + $2 } + / exp "-" fact { $1 - $2 } + / fact +fact :: Double + = fact "*" term { $1 * $2 } + / fact "/" term { $1 / $2 } + / term +term :: Double + = "(" exp ")" + / number +number ::: Double + = ([1-9][0-9]*) { read $1 } +|] + +main :: IO () +main = + print . parse exp =<< getContents +~~~
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple-main = defaultMain+import Distribution.Simple +main = defaultMain
Text/Peggy.hs view
@@ -1,11 +1,11 @@-module Text.Peggy (- module Text.Peggy.Prim,- module Text.Peggy.SrcLoc,- module Text.Peggy.Syntax,- module Text.Peggy.Quote,- ) where--import Text.Peggy.Prim-import Text.Peggy.SrcLoc-import Text.Peggy.Syntax-import Text.Peggy.Quote+module Text.Peggy ( + module Text.Peggy.Prim, + module Text.Peggy.SrcLoc, + module Text.Peggy.Syntax, + module Text.Peggy.Quote, + ) where + +import Text.Peggy.Prim +import Text.Peggy.SrcLoc +import Text.Peggy.Syntax +import Text.Peggy.Quote
Text/Peggy/CodeGen/TH.hs view
@@ -1,311 +1,311 @@-{-# LANGUAGE TemplateHaskell, TupleSections, FlexibleContexts #-}--module Text.Peggy.CodeGen.TH (- genDecs,- genQQ,- ) where--import Control.Applicative-import Control.Monad-import qualified Data.HashTable.ST.Basic as HT-import Data.List-import qualified Data.ListLike as LL-import Data.Maybe-import Data.Typeable ()-import Language.Haskell.Meta-import Language.Haskell.TH-import Language.Haskell.TH.Syntax-import Language.Haskell.TH.Quote-import Text.Peggy.Prim-import Text.Peggy.Syntax-import Text.Peggy.SrcLoc-import Text.Peggy.Normalize-import Text.Peggy.LeftRec--genQQ :: Syntax -> (String, String) -> Q [Dec]-genQQ syn (qqName, parserName) = do- sig <- sigD (mkName qqName) (conT ''QuasiQuoter)- dat <- valD (varP $ mkName qqName) (normalB con) []- return [sig, dat]- where- con = do- e <- [| \str -> do- loc <- location- case parse $(varE $ mkName parserName) (SrcPos (loc_filename loc) 0 (fst $ loc_start loc) (snd $ loc_start loc)) str of- Left err -> error $ show err- Right a -> a- |]- u <- [| undefined |]- recConE 'QuasiQuoter [ return ('quoteExp, e)- , return ('quoteDec, u)- , return ('quotePat, u)- , return ('quoteType, u)- ]--genDecs :: Syntax -> Q [Dec]-genDecs = generate . normalize . removeLeftRecursion--generate :: Syntax -> Q [Dec]-generate defs = do- tblTypName <- newName "MemoTable"- tblDatName <- newName "MemoTable"- ps <- parsers tblTypName- sequence $ [ defTbl tblTypName tblDatName- , instTbl tblTypName tblDatName- ] ++ ps- where- n = length defs- - defTbl :: Name -> Name -> DecQ- defTbl tblTypName tblDatName = do- s <- newName "s"- str <- newName "str"- dataD (cxt []) tblTypName [PlainTV str, PlainTV s] [con s str] []- where- con s str = recC tblDatName $ map toMem defs where- toMem (Definition nont typ _) = do- let tt | isExp nont = [t| ExpQ |]- | otherwise = parseType' typ- t <- [t| HT.HashTable $(varT s) Int- (Result $(varT str) $tt) |]- return (mkName $ "tbl_" ++nont, NotStrict, t)-- instTbl :: Name -> Name -> DecQ- instTbl tblTypName tblDatName = do- str <- newName "str"- instanceD (cxt []) (conT ''MemoTable `appT` (conT tblTypName `appT` varT str))- [ valD (varP 'newTable) (normalB body) [] ]- where- body = do- names <- replicateM n (newName "t")- doE $ map (\name -> bindS (varP name) [| HT.new |]) names- ++ [ noBindS $ appsE [varE 'return, appsE $ conE tblDatName : map varE names]]-- parsers tblName = concat <$> mapM (gen tblName) defs-- isExp name = isJust $ find f defs where- f (Definition nont typ _)- | nont == name && head (words typ) == "Exp" = True- | otherwise = False- - gen tblName (Definition nont typ e)- | isExp nont = return $- [ genSig tblName nont [t| ExpQ |]- , funD (mkName nont)- [clause [] (normalB [| memo $(varE $ mkName $ "tbl_" ++ nont) $ $(genP True e) |]) []]]- | otherwise = return $- [ genSig tblName nont (parseType' typ)- , funD (mkName nont)- [clause [] (normalB [| memo $(varE $ mkName $ "tbl_" ++ nont) $ $(genP False e) |]) []]]- - genSig tblName name typ = do- str <- newName "str"- s <- newName "s"- sigD (mkName name) $- forallT [PlainTV str, PlainTV s]- (cxt [classP ''LL.ListLike [varT str, conT ''Char]]) $- conT ''Parser `appT`- (conT tblName `appT` varT str) `appT`- varT str `appT`- varT s `appT`- typ- - -- Generate Parser- genP :: Bool -> Expr -> ExpQ- genP isE e = case (isE, e) of- (False, Terminals False False str) ->- [| string str |]- (True, Terminals False False str) ->- [| lift <$> string str |]-- (False, TerminalSet rs) ->- [| satisfy $(genRanges rs) |]- (True, TerminalSet rs) ->- [| lift <$> satisfy $(genRanges rs) |]-- (False, TerminalCmp rs) ->- [| satisfy $ not . $(genRanges rs) |]- (True, TerminalCmp rs) ->- [| lift <$> (satisfy $ not . $(genRanges rs)) |]-- (False, TerminalAny) ->- [| anyChar |]- (True, TerminalAny) ->- [| lift <$> anyChar |]-- (False, NonTerminal nont) ->- if isExp nont then error $ "value cannot contain exp: " ++ nont- else [| $(varE $ mkName nont) |]- (True, NonTerminal nont) ->- if isExp nont- then [| $(varE $ mkName nont) |]- else [| lift <$> $(varE $ mkName nont) |]-- (False, Primitive name) ->- [| $(varE $ mkName name) |]- (True, Primitive name) ->- [| lift <$> $(varE $ mkName name) |]-- (False, Empty) ->- [| return () |]- (True, Empty) ->- [| lift <$> return () |]-- (False, Many f) ->- [| many $(genP isE f) |]- (True, Many f) ->- [| do eQs <- many $(genP isE f); return $ listE eQs |]-- (False, Some f) ->- [| some $(genP isE f) |]- (True, Some f) ->- [| do eQs <- some $(genP isE f); return $ listE eQs |]-- (False, Optional f) ->- [| optional $(genP isE f) |]- (True, Optional f) ->- [| do eQm <- optional $(genP isE f); case eQm of Nothing -> lift Nothing; Just q -> do ee <- q; lift (Just ee) |]-- (False, And f) ->- [| expect $(genP isE f) |]- (True, And f) ->- [| lift () <$ expect $(genP isE f) |]-- (False, Not f) ->- [| unexpect $(genP isE f) |]- (True, Not f) ->- [| lift () <$ unexpect $(genP isE f) |]-- (_, Token f) ->- [| token $(varE skip) $(varE delimiter) ( $(genP isE f) ) |]-- -- simply, ignoreing result value- (False, Named "_" f) ->- [| () <$ $(genP isE f) |]- (True, Named "_" f) ->- [| () <$ $(genP isE f) |]-- (_, Named {}) -> error "named expr must has semantic."-- (False, Choice es) ->- foldl1 (\a b -> [| $a <|> $b |]) $ map (genP isE) es- (True, Choice es) ->- [| $(foldl1 (\a b -> [| $a <|> $b |]) $ map (genP isE) es) |]-- -- Semancit Code-- -- Generates a Normal, value constructing code.- -- It cannot has anti-quotes, values dependent on anti-quotes.- (False, Semantic (Sequence es) cf) -> do- -- TODO: make it syntax-sugar- let needSt = hasPos cf || hasSpan cf- needEd = hasSpan cf- st = if needSt then [bindS (varP $ mkName stName) [| getPos |]] else []- ed = if needEd then [bindS (varP $ mkName edName) [| getPos |]] else []- doE $ st ++ genBinds 1 es ++ ed ++ [ noBindS [| return $(genCF isE cf) |] ]-- -- Generates a Exp constructing code.- -- It can contain anti-quotes.- -- Anti-quoted value must be Normal values.- (True, Semantic (Sequence es) cf) -> do- bs <- sequence $ genBinds 1 es- let vn = length $ filter isBind bs- let gcf = genCF isE (ccf vn)- doE $ map return bs ++- [ noBindS [| return $ foldl appE (return $(lift =<< gcf)) $(eQnames vn) |]]- where- ccf 0 = cf- ccf nn = [Snippet $ "\\" ++ unwords (names nn ++ qames nn) ++ " -> ("] ++ cf ++ [Snippet ")"]- eQnames nn =- listE $ [ [| lift $(varE (mkName $ var i)) |] | i <- [1..nn]] ++- [ if hasAQ i cf- then [| varE $ mkName $(varE $ mkName $ var i) |]- else [| litE $ integerL 0 |]- | i <- [1..nn]]- names nn = map var [1..nn]- qames nn = map qar [1..nn]-- _ ->- error $ "internal compile error: " ++ show e-- where- genBinds _ [] = []- genBinds ix (f:fs) = case f of- Named "_" g ->- noBindS (genP isE g) :- genBinds ix fs- Named name g ->- bindS (asP (mkName name) $ varP $ mkName (var ix)) (genP isE g) :- genBinds (ix+1) fs- _ | shouldBind f ->- bindS (varP $ mkName $ var ix) (genP isE f) :- genBinds (ix+1) fs- _ ->- noBindS (genP isE f) :- genBinds ix fs-- genRanges :: [CharRange] -> ExpQ- genRanges rs =- let c = mkName "c" in- lamE [varP c] $ foldl1 (\a b -> [| $a || $b |]) $ map (genRange c) rs-- genRange :: Name -> CharRange -> ExpQ- genRange c (CharRange l h) =- [| l <= $(varE c) && $(varE c) <= h |]- genRange c (CharOne v) =- [| $(varE c) == v |]-- genCF isE cf =- case parsed of- Left _ ->- error $ "code fragment parse error: " ++ scf- Right ret ->- return ret- where- parsed = parseExp scf- scf = concatMap toStr cf- toStr (Snippet str) = str- toStr (Argument a) = var a- toStr (AntiArgument nn)- | not isE = error "Anti-quoter is not allowed in non-AQ parser"- | otherwise = qar nn- toStr ArgPos = "(LocPos " ++ stName ++ ")"- toStr ArgSpan = "(LocSpan " ++ stName ++ " " ++ edName ++ ")"-- hasAQ x cf = not . null $ filter (isAQ x) cf where- isAQ i (AntiArgument j) = i == j- isAQ _ _ = False-- hasPos = any (==ArgPos)- hasSpan = any (==ArgSpan)-- isBind (BindS _ _) = True- isBind _ = False-- skip = mkName "skip"- delimiter = mkName "delimiter"-- var nn = "v" ++ show (nn :: Int)- qar nn = "q" ++ show (nn :: Int)- stName = "st_Pos"- edName = "ed_Pos"--parseExp' str =- case parseExp str of- Left _ ->- error $ "code fragment parse error: " ++ str- Right ret ->- return ret--parseType' typ =- case parseType typ of- Left err -> error $ "type parse error :" ++ typ ++ ", " ++ err- Right t -> case t of- -- GHC.Unit.()/GHC.Tuple.() is not a type name. Is it a bug of haskell-src-meta?- -- Use (TupleT 0) insted.- ConT con | show con == "GHC.Unit.()" ->- return $ TupleT 0- ConT con | show con == "GHC.Tuple.()" ->- return $ TupleT 0- _ ->- return t+{-# LANGUAGE TemplateHaskell, TupleSections, FlexibleContexts #-} + +module Text.Peggy.CodeGen.TH ( + genDecs, + genQQ, + ) where + +import Control.Applicative +import Control.Monad +import qualified Data.HashTable.ST.Basic as HT +import Data.List +import qualified Data.ListLike as LL +import Data.Maybe +import Data.Typeable () +import Language.Haskell.Meta +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Quote +import Text.Peggy.Prim +import Text.Peggy.Syntax +import Text.Peggy.SrcLoc +import Text.Peggy.Normalize +import Text.Peggy.LeftRec + +genQQ :: Syntax -> (String, String) -> Q [Dec] +genQQ syn (qqName, parserName) = do + sig <- sigD (mkName qqName) (conT ''QuasiQuoter) + dat <- valD (varP $ mkName qqName) (normalB con) [] + return [sig, dat] + where + con = do + e <- [| \str -> do + loc <- location + case parse $(varE $ mkName parserName) (SrcPos (loc_filename loc) 0 (fst $ loc_start loc) (snd $ loc_start loc)) str of + Left err -> error $ show err + Right a -> a + |] + u <- [| undefined |] + recConE 'QuasiQuoter [ return ('quoteExp, e) + , return ('quoteDec, u) + , return ('quotePat, u) + , return ('quoteType, u) + ] + +genDecs :: Syntax -> Q [Dec] +genDecs = generate . normalize . removeLeftRecursion + +generate :: Syntax -> Q [Dec] +generate defs = do + tblTypName <- newName "MemoTable" + tblDatName <- newName "MemoTable" + ps <- parsers tblTypName + sequence $ [ defTbl tblTypName tblDatName + , instTbl tblTypName tblDatName + ] ++ ps + where + n = length defs + + defTbl :: Name -> Name -> DecQ + defTbl tblTypName tblDatName = do + s <- newName "s" + str <- newName "str" + dataD (cxt []) tblTypName [PlainTV str, PlainTV s] [con s str] [] + where + con s str = recC tblDatName $ map toMem defs where + toMem (Definition nont typ _) = do + let tt | isExp nont = [t| ExpQ |] + | otherwise = parseType' typ + t <- [t| HT.HashTable $(varT s) Int + (Result $(varT str) $tt) |] + return (mkName $ "tbl_" ++nont, NotStrict, t) + + instTbl :: Name -> Name -> DecQ + instTbl tblTypName tblDatName = do + str <- newName "str" + instanceD (cxt []) (conT ''MemoTable `appT` (conT tblTypName `appT` varT str)) + [ valD (varP 'newTable) (normalB body) [] ] + where + body = do + names <- replicateM n (newName "t") + doE $ map (\name -> bindS (varP name) [| HT.new |]) names + ++ [ noBindS $ appsE [varE 'return, appsE $ conE tblDatName : map varE names]] + + parsers tblName = concat <$> mapM (gen tblName) defs + + isExp name = isJust $ find f defs where + f (Definition nont typ _) + | nont == name && head (words typ) == "Exp" = True + | otherwise = False + + gen tblName (Definition nont typ e) + | isExp nont = return $ + [ genSig tblName nont [t| ExpQ |] + , funD (mkName nont) + [clause [] (normalB [| memo $(varE $ mkName $ "tbl_" ++ nont) $ $(genP True e) |]) []]] + | otherwise = return $ + [ genSig tblName nont (parseType' typ) + , funD (mkName nont) + [clause [] (normalB [| memo $(varE $ mkName $ "tbl_" ++ nont) $ $(genP False e) |]) []]] + + genSig tblName name typ = do + str <- newName "str" + s <- newName "s" + sigD (mkName name) $ + forallT [PlainTV str, PlainTV s] + (cxt [classP ''LL.ListLike [varT str, conT ''Char]]) $ + conT ''Parser `appT` + (conT tblName `appT` varT str) `appT` + varT str `appT` + varT s `appT` + typ + + -- Generate Parser + genP :: Bool -> Expr -> ExpQ + genP isE e = case (isE, e) of + (False, Terminals False False str) -> + [| string str |] + (True, Terminals False False str) -> + [| lift <$> string str |] + + (False, TerminalSet rs) -> + [| satisfy $(genRanges rs) |] + (True, TerminalSet rs) -> + [| lift <$> satisfy $(genRanges rs) |] + + (False, TerminalCmp rs) -> + [| satisfy $ not . $(genRanges rs) |] + (True, TerminalCmp rs) -> + [| lift <$> (satisfy $ not . $(genRanges rs)) |] + + (False, TerminalAny) -> + [| anyChar |] + (True, TerminalAny) -> + [| lift <$> anyChar |] + + (False, NonTerminal nont) -> + if isExp nont then error $ "value cannot contain exp: " ++ nont + else [| $(varE $ mkName nont) |] + (True, NonTerminal nont) -> + if isExp nont + then [| $(varE $ mkName nont) |] + else [| lift <$> $(varE $ mkName nont) |] + + (False, Primitive name) -> + [| $(varE $ mkName name) |] + (True, Primitive name) -> + [| lift <$> $(varE $ mkName name) |] + + (False, Empty) -> + [| return () |] + (True, Empty) -> + [| lift <$> return () |] + + (False, Many f) -> + [| many $(genP isE f) |] + (True, Many f) -> + [| do eQs <- many $(genP isE f); return $ listE eQs |] + + (False, Some f) -> + [| some $(genP isE f) |] + (True, Some f) -> + [| do eQs <- some $(genP isE f); return $ listE eQs |] + + (False, Optional f) -> + [| optional $(genP isE f) |] + (True, Optional f) -> + [| do eQm <- optional $(genP isE f); case eQm of Nothing -> lift Nothing; Just q -> do ee <- q; lift (Just ee) |] + + (False, And f) -> + [| expect $(genP isE f) |] + (True, And f) -> + [| lift () <$ expect $(genP isE f) |] + + (False, Not f) -> + [| unexpect $(genP isE f) |] + (True, Not f) -> + [| lift () <$ unexpect $(genP isE f) |] + + (_, Token f) -> + [| token $(varE skip) $(varE delimiter) ( $(genP isE f) ) |] + + -- simply, ignoreing result value + (False, Named "_" f) -> + [| () <$ $(genP isE f) |] + (True, Named "_" f) -> + [| () <$ $(genP isE f) |] + + (_, Named {}) -> error "named expr must has semantic." + + (False, Choice es) -> + foldl1 (\a b -> [| $a <|> $b |]) $ map (genP isE) es + (True, Choice es) -> + [| $(foldl1 (\a b -> [| $a <|> $b |]) $ map (genP isE) es) |] + + -- Semancit Code + + -- Generates a Normal, value constructing code. + -- It cannot has anti-quotes, values dependent on anti-quotes. + (False, Semantic (Sequence es) cf) -> do + -- TODO: make it syntax-sugar + let needSt = hasPos cf || hasSpan cf + needEd = hasSpan cf + st = if needSt then [bindS (varP $ mkName stName) [| getPos |]] else [] + ed = if needEd then [bindS (varP $ mkName edName) [| getPos |]] else [] + doE $ st ++ genBinds 1 es ++ ed ++ [ noBindS [| return $(genCF isE cf) |] ] + + -- Generates a Exp constructing code. + -- It can contain anti-quotes. + -- Anti-quoted value must be Normal values. + (True, Semantic (Sequence es) cf) -> do + bs <- sequence $ genBinds 1 es + let vn = length $ filter isBind bs + let gcf = genCF isE (ccf vn) + doE $ map return bs ++ + [ noBindS [| return $ foldl appE (return $(lift =<< gcf)) $(eQnames vn) |]] + where + ccf 0 = cf + ccf nn = [Snippet $ "\\" ++ unwords (names nn ++ qames nn) ++ " -> ("] ++ cf ++ [Snippet ")"] + eQnames nn = + listE $ [ [| lift $(varE (mkName $ var i)) |] | i <- [1..nn]] ++ + [ if hasAQ i cf + then [| varE $ mkName $(varE $ mkName $ var i) |] + else [| litE $ integerL 0 |] + | i <- [1..nn]] + names nn = map var [1..nn] + qames nn = map qar [1..nn] + + _ -> + error $ "internal compile error: " ++ show e + + where + genBinds _ [] = [] + genBinds ix (f:fs) = case f of + Named "_" g -> + noBindS (genP isE g) : + genBinds ix fs + Named name g -> + bindS (asP (mkName name) $ varP $ mkName (var ix)) (genP isE g) : + genBinds (ix+1) fs + _ | shouldBind f -> + bindS (varP $ mkName $ var ix) (genP isE f) : + genBinds (ix+1) fs + _ -> + noBindS (genP isE f) : + genBinds ix fs + + genRanges :: [CharRange] -> ExpQ + genRanges rs = + let c = mkName "c" in + lamE [varP c] $ foldl1 (\a b -> [| $a || $b |]) $ map (genRange c) rs + + genRange :: Name -> CharRange -> ExpQ + genRange c (CharRange l h) = + [| l <= $(varE c) && $(varE c) <= h |] + genRange c (CharOne v) = + [| $(varE c) == v |] + + genCF isE cf = + case parsed of + Left _ -> + error $ "code fragment parse error: " ++ scf + Right ret -> + return ret + where + parsed = parseExp scf + scf = concatMap toStr cf + toStr (Snippet str) = str + toStr (Argument a) = var a + toStr (AntiArgument nn) + | not isE = error "Anti-quoter is not allowed in non-AQ parser" + | otherwise = qar nn + toStr ArgPos = "(LocPos " ++ stName ++ ")" + toStr ArgSpan = "(LocSpan " ++ stName ++ " " ++ edName ++ ")" + + hasAQ x cf = not . null $ filter (isAQ x) cf where + isAQ i (AntiArgument j) = i == j + isAQ _ _ = False + + hasPos = any (==ArgPos) + hasSpan = any (==ArgSpan) + + isBind (BindS _ _) = True + isBind _ = False + + skip = mkName "skip" + delimiter = mkName "delimiter" + + var nn = "v" ++ show (nn :: Int) + qar nn = "q" ++ show (nn :: Int) + stName = "st_Pos" + edName = "ed_Pos" + +parseExp' str = + case parseExp str of + Left _ -> + error $ "code fragment parse error: " ++ str + Right ret -> + return ret + +parseType' typ = + case parseType typ of + Left err -> error $ "type parse error :" ++ typ ++ ", " ++ err + Right t -> case t of + -- GHC.Unit.()/GHC.Tuple.() is not a type name. Is it a bug of haskell-src-meta? + -- Use (TupleT 0) insted. + ConT con | show con == "GHC.Unit.()" -> + return $ TupleT 0 + ConT con | show con == "GHC.Tuple.()" -> + return $ TupleT 0 + _ -> + return t
Text/Peggy/LeftRec.hs view
@@ -1,72 +1,72 @@-module Text.Peggy.LeftRec (- removeLeftRecursion,- ) where--import Text.Peggy.Syntax---- Remove only direct left recursion--- TODO: indirect left recursion-removeLeftRecursion :: Syntax -> Syntax-removeLeftRecursion = concatMap remove where- remove (Definition nont typ (Choice es)) | not $ null alphas =- [ Definition nont typ $ Choice- [ Semantic (Sequence $ beta : [NonTerminal rest]) betaFrag- | beta <- betas- ]- , Definition rest ("(" ++ typ ++ ") -> (" ++ typ ++")") $ Choice $- [ Sequence $ fs ++ [NonTerminal rest]- | Sequence (_: fs) <- alphas- ] ++- [ Semantic- (Sequence $ fs ++ [NonTerminal rest])- (alphaFrag cf $ length (filter hasSemantic fs) + 1)- | Semantic (Sequence (_: fs)) cf <- alphas- ] ++- [ Semantic Empty idFrag ]- ]- where- rest = nont ++ "_tail"- (alphas, betas) = span isLeftRec es- - idFrag =- [ Snippet "id"- ]- - betaFrag =- [ Argument 2- , Snippet " "- , Argument 1- ]- - alphaFrag org ano =- [ Snippet "\\v999 -> "- , Argument ano- , Snippet " ( "- ] ++- map trans org ++- [ Snippet " )" ]- - trans (Argument n)- | n == 1 = Argument 999- | otherwise = Argument (n - 1)- trans e = e-- isLeftRec (Sequence (NonTerminal nt : _))- = nt == nont- isLeftRec (Semantic e _)- = isLeftRec e- isLeftRec (Named _ e)- = isLeftRec e- isLeftRec _- = False- - hasSemantic (Terminals _ _ _) = False- hasSemantic (And _) = False- hasSemantic (Not _) = False- hasSemantic _ = True- - remove d@(Definition nont _ (NonTerminal nt))- | nont == nt = error "cannot remove left recursion"- | otherwise = [d]-- remove e = [e]+module Text.Peggy.LeftRec ( + removeLeftRecursion, + ) where + +import Text.Peggy.Syntax + +-- Remove only direct left recursion +-- TODO: indirect left recursion +removeLeftRecursion :: Syntax -> Syntax +removeLeftRecursion = concatMap remove where + remove (Definition nont typ (Choice es)) | not $ null alphas = + [ Definition nont typ $ Choice + [ Semantic (Sequence $ beta : [NonTerminal rest]) betaFrag + | beta <- betas + ] + , Definition rest ("(" ++ typ ++ ") -> (" ++ typ ++")") $ Choice $ + [ Sequence $ fs ++ [NonTerminal rest] + | Sequence (_: fs) <- alphas + ] ++ + [ Semantic + (Sequence $ fs ++ [NonTerminal rest]) + (alphaFrag cf $ length (filter hasSemantic fs) + 1) + | Semantic (Sequence (_: fs)) cf <- alphas + ] ++ + [ Semantic Empty idFrag ] + ] + where + rest = nont ++ "_tail" + (alphas, betas) = span isLeftRec es + + idFrag = + [ Snippet "id" + ] + + betaFrag = + [ Argument 2 + , Snippet " " + , Argument 1 + ] + + alphaFrag org ano = + [ Snippet "\\v999 -> " + , Argument ano + , Snippet " ( " + ] ++ + map trans org ++ + [ Snippet " )" ] + + trans (Argument n) + | n == 1 = Argument 999 + | otherwise = Argument (n - 1) + trans e = e + + isLeftRec (Sequence (NonTerminal nt : _)) + = nt == nont + isLeftRec (Semantic e _) + = isLeftRec e + isLeftRec (Named _ e) + = isLeftRec e + isLeftRec _ + = False + + hasSemantic (Terminals _ _ _) = False + hasSemantic (And _) = False + hasSemantic (Not _) = False + hasSemantic _ = True + + remove d@(Definition nont _ (NonTerminal nt)) + | nont == nt = error "cannot remove left recursion" + | otherwise = [d] + + remove e = [e]
Text/Peggy/Normalize.hs view
@@ -1,87 +1,87 @@-module Text.Peggy.Normalize (- normalize,- shouldBind,- ) where--import Data.List-import Text.Peggy.Syntax--normalize :: Syntax -> Syntax-normalize = map desugarDef . addSkipDelim--addSkipDelim :: Syntax -> Syntax-addSkipDelim defs = skp ++ dlm ++ defs- where- skp | hasSkip = []- | otherwise = [defaultSkipImpl]- dlm | hasDelim = []- | otherwise = [defaultDelimImpl]-- hasSkip = not $ null [ () | Definition nont _ _ <- defs , nont == "skip" ]- hasDelim = not $ null [ () | Definition nont _ _ <- defs , nont == "delimiter" ]- - defaultSkipImpl =- Definition "skip" "()" $ Primitive "space"- defaultDelimImpl =- Definition "delimiter" "()" $ Primitive "defaultDelimiter"--desugarDef :: Definition -> Definition-desugarDef (Definition nont typ expr) =- Definition nont typ (desugar expr)- where- desugar e = case e of- Terminals True True str ->- Token $ Terminals False False str- - Terminals {} -> e- TerminalSet {} -> e- TerminalCmp {} -> e- TerminalAny {} -> e- NonTerminal {} -> e- Primitive {} -> e- Empty -> e- - Named name f -> Named name $ desugar f- - Choice es -> Choice $ map desugar es- Many f -> Many $ desugar f- Some f -> Some $ desugar f- Optional f -> Optional $ desugar f- And f -> And $ desugar f- Not f -> Not $ desugar f- - Sequence es ->- desugar $ Semantic (Sequence es) $ defaultCF $ length $ filter shouldBind es- - Semantic (Sequence es) cf ->- Semantic (Sequence $ map desugar es) cf- Semantic f cf ->- Semantic (Sequence [desugar f]) cf- - SepBy f g ->- desugar (Choice [SepBy1 f g, Semantic Empty [Snippet "[]"]])- - SepBy1 f g ->- let f' = desugar f in- let g' = desugar g in- let g'' = desugar $ Semantic g' [Snippet "()"] in- Semantic (Sequence [f', (Many (Semantic (Sequence [g'', f']) [Argument 2]))])- [ Argument 1- , Snippet ":"- , Argument 2- ]- - Token f ->- Token $ desugar f-- defaultCF n =- [ Snippet "(" ] ++- intersperse (Snippet ",") (map Argument[1..n]) ++- [ Snippet ")" ]--shouldBind f = case f of- Terminals _ _ _ -> False- And _ -> False- Not _ -> False- Token g -> shouldBind g- _ -> True+module Text.Peggy.Normalize ( + normalize, + shouldBind, + ) where + +import Data.List +import Text.Peggy.Syntax + +normalize :: Syntax -> Syntax +normalize = map desugarDef . addSkipDelim + +addSkipDelim :: Syntax -> Syntax +addSkipDelim defs = skp ++ dlm ++ defs + where + skp | hasSkip = [] + | otherwise = [defaultSkipImpl] + dlm | hasDelim = [] + | otherwise = [defaultDelimImpl] + + hasSkip = not $ null [ () | Definition nont _ _ <- defs , nont == "skip" ] + hasDelim = not $ null [ () | Definition nont _ _ <- defs , nont == "delimiter" ] + + defaultSkipImpl = + Definition "skip" "()" $ Primitive "space" + defaultDelimImpl = + Definition "delimiter" "()" $ Primitive "defaultDelimiter" + +desugarDef :: Definition -> Definition +desugarDef (Definition nont typ expr) = + Definition nont typ (desugar expr) + where + desugar e = case e of + Terminals True True str -> + Token $ Terminals False False str + + Terminals {} -> e + TerminalSet {} -> e + TerminalCmp {} -> e + TerminalAny {} -> e + NonTerminal {} -> e + Primitive {} -> e + Empty -> e + + Named name f -> Named name $ desugar f + + Choice es -> Choice $ map desugar es + Many f -> Many $ desugar f + Some f -> Some $ desugar f + Optional f -> Optional $ desugar f + And f -> And $ desugar f + Not f -> Not $ desugar f + + Sequence es -> + desugar $ Semantic (Sequence es) $ defaultCF $ length $ filter shouldBind es + + Semantic (Sequence es) cf -> + Semantic (Sequence $ map desugar es) cf + Semantic f cf -> + Semantic (Sequence [desugar f]) cf + + SepBy f g -> + desugar (Choice [SepBy1 f g, Semantic Empty [Snippet "[]"]]) + + SepBy1 f g -> + let f' = desugar f in + let g' = desugar g in + let g'' = desugar $ Semantic g' [Snippet "()"] in + Semantic (Sequence [f', (Many (Semantic (Sequence [g'', f']) [Argument 2]))]) + [ Argument 1 + , Snippet ":" + , Argument 2 + ] + + Token f -> + Token $ desugar f + + defaultCF n = + [ Snippet "(" ] ++ + intersperse (Snippet ",") (map Argument[1..n]) ++ + [ Snippet ")" ] + +shouldBind f = case f of + Terminals _ _ _ -> False + And _ -> False + Not _ -> False + Token g -> shouldBind g + _ -> True
Text/Peggy/Parser.hs view
@@ -1,294 +1,294 @@-{-# LANGUAGE RankNTypes, FlexibleContexts #-}--module Text.Peggy.Parser (syntax) where-import Control.Applicative-import Data.ListLike.Base hiding (head)-import Data.HashTable.ST.Basic-import Numeric-import Data.Char-import Text.Peggy.Prim-import Text.Peggy.Syntax--data MemoTable_0 str_1 s_2- = MemoTable_3 {tbl_delimiter :: (HashTable s_2- Int- (Result str_1 ())),- tbl_syntax :: (HashTable s_2 Int (Result str_1 Syntax)),- tbl_definition :: (HashTable s_2 Int (Result str_1 Definition)),- tbl_expr :: (HashTable s_2 Int (Result str_1 Expr)),- tbl_choiceExpr :: (HashTable s_2 Int (Result str_1 Expr)),- tbl_semanticExpr :: (HashTable s_2 Int (Result str_1 Expr)),- tbl_sequenceExpr :: (HashTable s_2 Int (Result str_1 Expr)),- tbl_namedExpr :: (HashTable s_2 Int (Result str_1 Expr)),- tbl_suffixExpr :: (HashTable s_2 Int (Result str_1 Expr)),- tbl_suffixExpr_tail :: (HashTable s_2- Int- (Result str_1 (Expr -> Expr))),- tbl_prefixExpr :: (HashTable s_2 Int (Result str_1 Expr)),- tbl_primExpr :: (HashTable s_2 Int (Result str_1 Expr)),- tbl_charLit :: (HashTable s_2 Int (Result str_1 Char)),- tbl_escChar :: (HashTable s_2 Int (Result str_1 Char)),- tbl_range :: (HashTable s_2 Int (Result str_1 CharRange)),- tbl_rchar :: (HashTable s_2 Int (Result str_1 Char)),- tbl_haskellType :: (HashTable s_2 Int (Result str_1 TermType)),- tbl_codeFragment :: (HashTable s_2- Int- (Result str_1 CodeFragment)),- tbl_codePart :: (HashTable s_2 Int (Result str_1 CodePart)),- tbl_argument :: (HashTable s_2 Int (Result str_1 CodePart)),- tbl_digit :: (HashTable s_2 Int (Result str_1 Char)),- tbl_hexDigit :: (HashTable s_2 Int (Result str_1 Char)),- tbl_ident :: (HashTable s_2 Int (Result str_1 String)),- tbl_skip :: (HashTable s_2 Int (Result str_1 ())),- tbl_comment :: (HashTable s_2 Int (Result str_1 ())),- tbl_lineComment :: (HashTable s_2 Int (Result str_1 ())),- tbl_regionComment :: (HashTable s_2 Int (Result str_1 ()))}-instance MemoTable (MemoTable_0 str_4)- where newTable = do t_5 <- new- t_6 <- new- t_7 <- new- t_8 <- new- t_9 <- new- t_10 <- new- t_11 <- new- t_12 <- new- t_13 <- new- t_14 <- new- t_15 <- new- t_16 <- new- t_17 <- new- t_18 <- new- t_19 <- new- t_20 <- new- t_21 <- new- t_22 <- new- t_23 <- new- t_24 <- new- t_25 <- new- t_26 <- new- t_27 <- new- t_28 <- new- t_29 <- new- t_30 <- new- t_31 <- new- return (MemoTable_3 t_5 t_6 t_7 t_8 t_9 t_10 t_11 t_12 t_13 t_14 t_15 t_16 t_17 t_18 t_19 t_20 t_21 t_22 t_23 t_24 t_25 t_26 t_27 t_28 t_29 t_30 t_31)-delimiter :: forall str_32 s_33 . ListLike str_32 Char =>- Parser (MemoTable_0 str_32) str_32 s_33 ()-delimiter = memo tbl_delimiter $ defaultDelimiter-syntax :: forall str_34 s_35 . ListLike str_34 Char =>- Parser (MemoTable_0 str_34) str_34 s_35 Syntax-syntax = memo tbl_syntax $ (do v1 <- many definition- unexpect (do v1 <- many skip- v2 <- anyChar- return $ (v1, v2))- return $ (v1))-definition :: forall str_36 s_37 . ListLike str_36 Char =>- Parser (MemoTable_0 str_36) str_36 s_37 Definition-definition = memo tbl_definition $ token skip delimiter ((do v1 <- ident- token skip delimiter (string ":::")- v2 <- haskellType- token skip delimiter (string "=")- v3 <- expr- return (Definition v1 v2 (Token v3))) <|> (do v1 <- ident- token skip delimiter (string "::")- v2 <- haskellType- token skip delimiter (string "=")- v3 <- expr- return (Definition v1 v2 v3)))-expr :: forall str_38 s_39 . ListLike str_38 Char =>- Parser (MemoTable_0 str_38) str_38 s_39 Expr-expr = memo tbl_expr $ (do v1 <- choiceExpr- return $ (v1))-choiceExpr :: forall str_40 s_41 . ListLike str_40 Char =>- Parser (MemoTable_0 str_40) str_40 s_41 Expr-choiceExpr = memo tbl_choiceExpr $ (do v1 <- (do v1 <- do v1 <- semanticExpr- return $ (v1)- v2 <- many (do v1 <- do v1 <- do token skip delimiter (string "/")- return $ ()- return ()- v2 <- do v1 <- semanticExpr- return $ (v1)- return v2)- return (v1 : v2)) <|> (do v1 <- return ()- return [])- return (Choice v1))-semanticExpr :: forall str_42 s_43 . ListLike str_42 Char =>- Parser (MemoTable_0 str_42) str_42 s_43 Expr-semanticExpr = memo tbl_semanticExpr $ ((do v1 <- sequenceExpr- token skip delimiter (string "{")- v2 <- codeFragment- token skip delimiter (string "}")- return (Semantic v1 v2)) <|> (do v1 <- sequenceExpr- return $ (v1)))-sequenceExpr :: forall str_44 s_45 . ListLike str_44 Char =>- Parser (MemoTable_0 str_44) str_44 s_45 Expr-sequenceExpr = memo tbl_sequenceExpr $ (do v1 <- some (do v1 <- namedExpr- unexpect (token skip delimiter (string "::"))- unexpect (token skip delimiter (string "="))- return $ (v1))- return (Sequence v1))-namedExpr :: forall str_46 s_47 . ListLike str_46 Char =>- Parser (MemoTable_0 str_46) str_46 s_47 Expr-namedExpr = memo tbl_namedExpr $ ((do v1 <- ident- token skip delimiter (string ":")- v2 <- suffixExpr- return (Named v1 v2)) <|> (do v1 <- suffixExpr- return $ (v1)))-suffixExpr :: forall str_48 s_49 . ListLike str_48 Char =>- Parser (MemoTable_0 str_48) str_48 s_49 Expr-suffixExpr = memo tbl_suffixExpr $ (do v1 <- do v1 <- prefixExpr- return $ (v1)- v2 <- suffixExpr_tail- return (v2 v1))-suffixExpr_tail :: forall str_50 s_51 . ListLike str_50 Char =>- Parser (MemoTable_0 str_50) str_50 s_51 (Expr -> Expr)-suffixExpr_tail = memo tbl_suffixExpr_tail $ ((((do token skip delimiter (string "*")- v1 <- suffixExpr_tail- return (\v999 -> v1 (Many v999))) <|> (do token skip delimiter (string "+")- v1 <- suffixExpr_tail- return (\v999 -> v1 (Some v999)))) <|> (do token skip delimiter (string "?")- v1 <- suffixExpr_tail- return (\v999 -> v1 (Optional v999)))) <|> (do v1 <- return ()- return id))-prefixExpr :: forall str_52 s_53 . ListLike str_52 Char =>- Parser (MemoTable_0 str_52) str_52 s_53 Expr-prefixExpr = memo tbl_prefixExpr $ (((do token skip delimiter (string "&")- v1 <- primExpr- return (And v1)) <|> (do token skip delimiter (string "!")- v1 <- primExpr- return (Not v1))) <|> (do v1 <- primExpr- return $ (v1)))-primExpr :: forall str_54 s_55 . ListLike str_54 Char =>- Parser (MemoTable_0 str_54) str_54 s_55 Expr-primExpr = memo tbl_primExpr $ token skip delimiter (((((((((do string "\""- v1 <- many charLit- string "\""- return (Terminals True True v1)) <|> (do string "'"- v1 <- many charLit- string "'"- return (Terminals False False v1))) <|> (do string "[^"- v1 <- many range- string "]"- return (TerminalCmp v1))) <|> (do string "["- v1 <- many range- string "]"- return (TerminalSet v1))) <|> (do token skip delimiter (string ".")- return TerminalAny)) <|> (do v1 <- ident- return (NonTerminal v1))) <|> (do token skip delimiter (string "(")- v1 <- expr- token skip delimiter (string ",")- v2 <- expr- token skip delimiter (string ")")- return (SepBy v1 v2))) <|> (do token skip delimiter (string "(")- v1 <- expr- token skip delimiter (string ";")- v2 <- expr- token skip delimiter (string ")")- return (SepBy1 v1 v2))) <|> (do token skip delimiter (string "(")- v1 <- expr- token skip delimiter (string ")")- return $ (v1)))-charLit :: forall str_56 s_57 . ListLike str_56 Char =>- Parser (MemoTable_0 str_56) str_56 s_57 Char-charLit = memo tbl_charLit $ ((do string "\\"- v1 <- escChar- return $ (v1)) <|> (do unexpect (satisfy (\c -> (c == '\'') || (c == '"')))- v1 <- anyChar- return $ (v1)))-escChar :: forall str_58 s_59 . ListLike str_58 Char =>- Parser (MemoTable_0 str_58) str_58 s_59 Char-escChar = memo tbl_escChar $ (((((((do string "n"- return '\n') <|> (do string "r"- return '\r')) <|> (do string "t"- return '\t')) <|> (do string "\\"- return '\\')) <|> (do string "\""- return '"')) <|> (do string "'"- return '\'')) <|> (do string "x"- v1 <- hexDigit- v2 <- hexDigit- return ((chr . (fst . (head . readHex))) $ [v1,- v2])))-range :: forall str_60 s_61 . ListLike str_60 Char =>- Parser (MemoTable_0 str_60) str_60 s_61 CharRange-range = memo tbl_range $ ((do v1 <- rchar- string "-"- v2 <- rchar- return (CharRange v1 v2)) <|> (do v1 <- rchar- return (CharOne v1)))-rchar :: forall str_62 s_63 . ListLike str_62 Char =>- Parser (MemoTable_0 str_62) str_62 s_63 Char-rchar = memo tbl_rchar $ ((((((do string "\\"- v1 <- escChar- return $ (v1)) <|> (do string "\\]"- return ']')) <|> (do string "\\["- return '[')) <|> (do string "\\^"- return '^')) <|> (do string "\\-"- return '-')) <|> (do v1 <- satisfy $ (not . (\c -> c == ']'))- return $ (v1)))-haskellType :: forall str_64 s_65 . ListLike str_64 Char =>- Parser (MemoTable_0 str_64) str_64 s_65 TermType-haskellType = memo tbl_haskellType $ (do v1 <- some (satisfy $ (not . (\c -> c == '=')))- return $ (v1))-codeFragment :: forall str_66 s_67 . ListLike str_66 Char =>- Parser (MemoTable_0 str_66) str_66 s_67 CodeFragment-codeFragment = memo tbl_codeFragment $ (do v1 <- many codePart- return $ (v1))-codePart :: forall str_68 s_69 . ListLike str_68 Char =>- Parser (MemoTable_0 str_68) str_68 s_69 CodePart-codePart = memo tbl_codePart $ ((do v1 <- argument- return $ (v1)) <|> (do v1 <- some (do unexpect (string "}")- unexpect argument- v1 <- anyChar- return $ (v1))- return (Snippet v1)))-argument :: forall str_70 s_71 . ListLike str_70 Char =>- Parser (MemoTable_0 str_70) str_70 s_71 CodePart-argument = memo tbl_argument $ ((((do string "$$"- v1 <- some digit- return (AntiArgument $ read v1)) <|> (do string "$"- v1 <- some digit- return (Argument $ read v1))) <|> (do string "$"- string "p"- return ArgPos)) <|> (do string "$"- string "s"- return ArgSpan))-digit :: forall str_72 s_73 . ListLike str_72 Char =>- Parser (MemoTable_0 str_72) str_72 s_73 Char-digit = memo tbl_digit $ (do v1 <- satisfy (\c -> ('0' <= c) && (c <= '9'))- return $ (v1))-hexDigit :: forall str_74 s_75 . ListLike str_74 Char =>- Parser (MemoTable_0 str_74) str_74 s_75 Char-hexDigit = memo tbl_hexDigit $ (do v1 <- satisfy (\c -> ((('0' <= c) && (c <= '9')) || (('a' <= c) && (c <= 'f'))) || (('A' <= c) && (c <= 'F')))- return $ (v1))-ident :: forall str_76 s_77 . ListLike str_76 Char =>- Parser (MemoTable_0 str_76) str_76 s_77 String-ident = memo tbl_ident $ token skip delimiter (do v1 <- satisfy (\c -> (('a' <= c) && (c <= 'z')) || (c == '_'))- v2 <- many (satisfy (\c -> (((('0' <= c) && (c <= '9')) || (('a' <= c) && (c <= 'z'))) || (('A' <= c) && (c <= 'Z'))) || (c == '_')))- return (v1 : v2))-skip :: forall str_78 s_79 . ListLike str_78 Char =>- Parser (MemoTable_0 str_78) str_78 s_79 ()-skip = memo tbl_skip $ ((do satisfy (\c -> (((c == ' ') || (c == '\r')) || (c == '\n')) || (c == '\t'))- return $ ()) <|> (do v1 <- comment- return $ (v1)))-comment :: forall str_80 s_81 . ListLike str_80 Char =>- Parser (MemoTable_0 str_80) str_80 s_81 ()-comment = memo tbl_comment $ ((do v1 <- lineComment- return $ (v1)) <|> (do v1 <- regionComment- return $ (v1)))-lineComment :: forall str_82 s_83 . ListLike str_82 Char =>- Parser (MemoTable_0 str_82) str_82 s_83 ()-lineComment = memo tbl_lineComment $ (do string "--"- many (do unexpect (string "\n")- anyChar- return $ ())- string "\n"- return $ ())-regionComment :: forall str_84 s_85 . ListLike str_84 Char =>- Parser (MemoTable_0 str_84) str_84 s_85 ()-regionComment = memo tbl_regionComment $ (do string "{-"- many ((do v1 <- regionComment- return $ (v1)) <|> (do unexpect (string "-}")- anyChar- return $ ()))- string "-}"- return $ ())+{-# LANGUAGE RankNTypes, FlexibleContexts #-} + +module Text.Peggy.Parser (syntax) where +import Control.Applicative +import Data.ListLike.Base hiding (head) +import Data.HashTable.ST.Basic +import Numeric +import Data.Char +import Text.Peggy.Prim +import Text.Peggy.Syntax + +data MemoTable_0 str_1 s_2 + = MemoTable_3 {tbl_delimiter :: (HashTable s_2 + Int + (Result str_1 ())), + tbl_syntax :: (HashTable s_2 Int (Result str_1 Syntax)), + tbl_definition :: (HashTable s_2 Int (Result str_1 Definition)), + tbl_expr :: (HashTable s_2 Int (Result str_1 Expr)), + tbl_choiceExpr :: (HashTable s_2 Int (Result str_1 Expr)), + tbl_semanticExpr :: (HashTable s_2 Int (Result str_1 Expr)), + tbl_sequenceExpr :: (HashTable s_2 Int (Result str_1 Expr)), + tbl_namedExpr :: (HashTable s_2 Int (Result str_1 Expr)), + tbl_suffixExpr :: (HashTable s_2 Int (Result str_1 Expr)), + tbl_suffixExpr_tail :: (HashTable s_2 + Int + (Result str_1 (Expr -> Expr))), + tbl_prefixExpr :: (HashTable s_2 Int (Result str_1 Expr)), + tbl_primExpr :: (HashTable s_2 Int (Result str_1 Expr)), + tbl_charLit :: (HashTable s_2 Int (Result str_1 Char)), + tbl_escChar :: (HashTable s_2 Int (Result str_1 Char)), + tbl_range :: (HashTable s_2 Int (Result str_1 CharRange)), + tbl_rchar :: (HashTable s_2 Int (Result str_1 Char)), + tbl_haskellType :: (HashTable s_2 Int (Result str_1 TermType)), + tbl_codeFragment :: (HashTable s_2 + Int + (Result str_1 CodeFragment)), + tbl_codePart :: (HashTable s_2 Int (Result str_1 CodePart)), + tbl_argument :: (HashTable s_2 Int (Result str_1 CodePart)), + tbl_digit :: (HashTable s_2 Int (Result str_1 Char)), + tbl_hexDigit :: (HashTable s_2 Int (Result str_1 Char)), + tbl_ident :: (HashTable s_2 Int (Result str_1 String)), + tbl_skip :: (HashTable s_2 Int (Result str_1 ())), + tbl_comment :: (HashTable s_2 Int (Result str_1 ())), + tbl_lineComment :: (HashTable s_2 Int (Result str_1 ())), + tbl_regionComment :: (HashTable s_2 Int (Result str_1 ()))} +instance MemoTable (MemoTable_0 str_4) + where newTable = do t_5 <- new + t_6 <- new + t_7 <- new + t_8 <- new + t_9 <- new + t_10 <- new + t_11 <- new + t_12 <- new + t_13 <- new + t_14 <- new + t_15 <- new + t_16 <- new + t_17 <- new + t_18 <- new + t_19 <- new + t_20 <- new + t_21 <- new + t_22 <- new + t_23 <- new + t_24 <- new + t_25 <- new + t_26 <- new + t_27 <- new + t_28 <- new + t_29 <- new + t_30 <- new + t_31 <- new + return (MemoTable_3 t_5 t_6 t_7 t_8 t_9 t_10 t_11 t_12 t_13 t_14 t_15 t_16 t_17 t_18 t_19 t_20 t_21 t_22 t_23 t_24 t_25 t_26 t_27 t_28 t_29 t_30 t_31) +delimiter :: forall str_32 s_33 . ListLike str_32 Char => + Parser (MemoTable_0 str_32) str_32 s_33 () +delimiter = memo tbl_delimiter $ defaultDelimiter +syntax :: forall str_34 s_35 . ListLike str_34 Char => + Parser (MemoTable_0 str_34) str_34 s_35 Syntax +syntax = memo tbl_syntax $ (do v1 <- many definition + unexpect (do v1 <- many skip + v2 <- anyChar + return $ (v1, v2)) + return $ (v1)) +definition :: forall str_36 s_37 . ListLike str_36 Char => + Parser (MemoTable_0 str_36) str_36 s_37 Definition +definition = memo tbl_definition $ token skip delimiter ((do v1 <- ident + token skip delimiter (string ":::") + v2 <- haskellType + token skip delimiter (string "=") + v3 <- expr + return (Definition v1 v2 (Token v3))) <|> (do v1 <- ident + token skip delimiter (string "::") + v2 <- haskellType + token skip delimiter (string "=") + v3 <- expr + return (Definition v1 v2 v3))) +expr :: forall str_38 s_39 . ListLike str_38 Char => + Parser (MemoTable_0 str_38) str_38 s_39 Expr +expr = memo tbl_expr $ (do v1 <- choiceExpr + return $ (v1)) +choiceExpr :: forall str_40 s_41 . ListLike str_40 Char => + Parser (MemoTable_0 str_40) str_40 s_41 Expr +choiceExpr = memo tbl_choiceExpr $ (do v1 <- (do v1 <- do v1 <- semanticExpr + return $ (v1) + v2 <- many (do v1 <- do v1 <- do token skip delimiter (string "/") + return $ () + return () + v2 <- do v1 <- semanticExpr + return $ (v1) + return v2) + return (v1 : v2)) <|> (do v1 <- return () + return []) + return (Choice v1)) +semanticExpr :: forall str_42 s_43 . ListLike str_42 Char => + Parser (MemoTable_0 str_42) str_42 s_43 Expr +semanticExpr = memo tbl_semanticExpr $ ((do v1 <- sequenceExpr + token skip delimiter (string "{") + v2 <- codeFragment + token skip delimiter (string "}") + return (Semantic v1 v2)) <|> (do v1 <- sequenceExpr + return $ (v1))) +sequenceExpr :: forall str_44 s_45 . ListLike str_44 Char => + Parser (MemoTable_0 str_44) str_44 s_45 Expr +sequenceExpr = memo tbl_sequenceExpr $ (do v1 <- some (do v1 <- namedExpr + unexpect (token skip delimiter (string "::")) + unexpect (token skip delimiter (string "=")) + return $ (v1)) + return (Sequence v1)) +namedExpr :: forall str_46 s_47 . ListLike str_46 Char => + Parser (MemoTable_0 str_46) str_46 s_47 Expr +namedExpr = memo tbl_namedExpr $ ((do v1 <- ident + token skip delimiter (string ":") + v2 <- suffixExpr + return (Named v1 v2)) <|> (do v1 <- suffixExpr + return $ (v1))) +suffixExpr :: forall str_48 s_49 . ListLike str_48 Char => + Parser (MemoTable_0 str_48) str_48 s_49 Expr +suffixExpr = memo tbl_suffixExpr $ (do v1 <- do v1 <- prefixExpr + return $ (v1) + v2 <- suffixExpr_tail + return (v2 v1)) +suffixExpr_tail :: forall str_50 s_51 . ListLike str_50 Char => + Parser (MemoTable_0 str_50) str_50 s_51 (Expr -> Expr) +suffixExpr_tail = memo tbl_suffixExpr_tail $ ((((do token skip delimiter (string "*") + v1 <- suffixExpr_tail + return (\v999 -> v1 (Many v999))) <|> (do token skip delimiter (string "+") + v1 <- suffixExpr_tail + return (\v999 -> v1 (Some v999)))) <|> (do token skip delimiter (string "?") + v1 <- suffixExpr_tail + return (\v999 -> v1 (Optional v999)))) <|> (do v1 <- return () + return id)) +prefixExpr :: forall str_52 s_53 . ListLike str_52 Char => + Parser (MemoTable_0 str_52) str_52 s_53 Expr +prefixExpr = memo tbl_prefixExpr $ (((do token skip delimiter (string "&") + v1 <- primExpr + return (And v1)) <|> (do token skip delimiter (string "!") + v1 <- primExpr + return (Not v1))) <|> (do v1 <- primExpr + return $ (v1))) +primExpr :: forall str_54 s_55 . ListLike str_54 Char => + Parser (MemoTable_0 str_54) str_54 s_55 Expr +primExpr = memo tbl_primExpr $ token skip delimiter (((((((((do string "\"" + v1 <- many charLit + string "\"" + return (Terminals True True v1)) <|> (do string "'" + v1 <- many charLit + string "'" + return (Terminals False False v1))) <|> (do string "[^" + v1 <- many range + string "]" + return (TerminalCmp v1))) <|> (do string "[" + v1 <- many range + string "]" + return (TerminalSet v1))) <|> (do token skip delimiter (string ".") + return TerminalAny)) <|> (do v1 <- ident + return (NonTerminal v1))) <|> (do token skip delimiter (string "(") + v1 <- expr + token skip delimiter (string ",") + v2 <- expr + token skip delimiter (string ")") + return (SepBy v1 v2))) <|> (do token skip delimiter (string "(") + v1 <- expr + token skip delimiter (string ";") + v2 <- expr + token skip delimiter (string ")") + return (SepBy1 v1 v2))) <|> (do token skip delimiter (string "(") + v1 <- expr + token skip delimiter (string ")") + return $ (v1))) +charLit :: forall str_56 s_57 . ListLike str_56 Char => + Parser (MemoTable_0 str_56) str_56 s_57 Char +charLit = memo tbl_charLit $ ((do string "\\" + v1 <- escChar + return $ (v1)) <|> (do unexpect (satisfy (\c -> (c == '\'') || (c == '"'))) + v1 <- anyChar + return $ (v1))) +escChar :: forall str_58 s_59 . ListLike str_58 Char => + Parser (MemoTable_0 str_58) str_58 s_59 Char +escChar = memo tbl_escChar $ (((((((do string "n" + return '\n') <|> (do string "r" + return '\r')) <|> (do string "t" + return '\t')) <|> (do string "\\" + return '\\')) <|> (do string "\"" + return '"')) <|> (do string "'" + return '\'')) <|> (do string "x" + v1 <- hexDigit + v2 <- hexDigit + return ((chr . (fst . (head . readHex))) $ [v1, + v2]))) +range :: forall str_60 s_61 . ListLike str_60 Char => + Parser (MemoTable_0 str_60) str_60 s_61 CharRange +range = memo tbl_range $ ((do v1 <- rchar + string "-" + v2 <- rchar + return (CharRange v1 v2)) <|> (do v1 <- rchar + return (CharOne v1))) +rchar :: forall str_62 s_63 . ListLike str_62 Char => + Parser (MemoTable_0 str_62) str_62 s_63 Char +rchar = memo tbl_rchar $ ((((((do string "\\" + v1 <- escChar + return $ (v1)) <|> (do string "\\]" + return ']')) <|> (do string "\\[" + return '[')) <|> (do string "\\^" + return '^')) <|> (do string "\\-" + return '-')) <|> (do v1 <- satisfy $ (not . (\c -> c == ']')) + return $ (v1))) +haskellType :: forall str_64 s_65 . ListLike str_64 Char => + Parser (MemoTable_0 str_64) str_64 s_65 TermType +haskellType = memo tbl_haskellType $ (do v1 <- some (satisfy $ (not . (\c -> c == '='))) + return $ (v1)) +codeFragment :: forall str_66 s_67 . ListLike str_66 Char => + Parser (MemoTable_0 str_66) str_66 s_67 CodeFragment +codeFragment = memo tbl_codeFragment $ (do v1 <- many codePart + return $ (v1)) +codePart :: forall str_68 s_69 . ListLike str_68 Char => + Parser (MemoTable_0 str_68) str_68 s_69 CodePart +codePart = memo tbl_codePart $ ((do v1 <- argument + return $ (v1)) <|> (do v1 <- some (do unexpect (string "}") + unexpect argument + v1 <- anyChar + return $ (v1)) + return (Snippet v1))) +argument :: forall str_70 s_71 . ListLike str_70 Char => + Parser (MemoTable_0 str_70) str_70 s_71 CodePart +argument = memo tbl_argument $ ((((do string "$$" + v1 <- some digit + return (AntiArgument $ read v1)) <|> (do string "$" + v1 <- some digit + return (Argument $ read v1))) <|> (do string "$" + string "p" + return ArgPos)) <|> (do string "$" + string "s" + return ArgSpan)) +digit :: forall str_72 s_73 . ListLike str_72 Char => + Parser (MemoTable_0 str_72) str_72 s_73 Char +digit = memo tbl_digit $ (do v1 <- satisfy (\c -> ('0' <= c) && (c <= '9')) + return $ (v1)) +hexDigit :: forall str_74 s_75 . ListLike str_74 Char => + Parser (MemoTable_0 str_74) str_74 s_75 Char +hexDigit = memo tbl_hexDigit $ (do v1 <- satisfy (\c -> ((('0' <= c) && (c <= '9')) || (('a' <= c) && (c <= 'f'))) || (('A' <= c) && (c <= 'F'))) + return $ (v1)) +ident :: forall str_76 s_77 . ListLike str_76 Char => + Parser (MemoTable_0 str_76) str_76 s_77 String +ident = memo tbl_ident $ token skip delimiter (do v1 <- satisfy (\c -> (('a' <= c) && (c <= 'z')) || (c == '_')) + v2 <- many (satisfy (\c -> (((('0' <= c) && (c <= '9')) || (('a' <= c) && (c <= 'z'))) || (('A' <= c) && (c <= 'Z'))) || (c == '_'))) + return (v1 : v2)) +skip :: forall str_78 s_79 . ListLike str_78 Char => + Parser (MemoTable_0 str_78) str_78 s_79 () +skip = memo tbl_skip $ ((do satisfy (\c -> (((c == ' ') || (c == '\r')) || (c == '\n')) || (c == '\t')) + return $ ()) <|> (do v1 <- comment + return $ (v1))) +comment :: forall str_80 s_81 . ListLike str_80 Char => + Parser (MemoTable_0 str_80) str_80 s_81 () +comment = memo tbl_comment $ ((do v1 <- lineComment + return $ (v1)) <|> (do v1 <- regionComment + return $ (v1))) +lineComment :: forall str_82 s_83 . ListLike str_82 Char => + Parser (MemoTable_0 str_82) str_82 s_83 () +lineComment = memo tbl_lineComment $ (do string "--" + many (do unexpect (string "\n") + anyChar + return $ ()) + string "\n" + return $ ()) +regionComment :: forall str_84 s_85 . ListLike str_84 Char => + Parser (MemoTable_0 str_84) str_84 s_85 () +regionComment = memo tbl_regionComment $ (do string "{-" + many ((do v1 <- regionComment + return $ (v1)) <|> (do unexpect (string "-}") + anyChar + return $ ())) + string "-}" + return $ ())
Text/Peggy/Prim.hs view
@@ -1,244 +1,244 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, RankNTypes #-}---- |--- Module : Text.Peggy.Prim--- Copyright : (c) Hideyuki Tanaka 2011--- License : BSD-style------ Maintainer : tanaka.hideyuki@gmail.com--- Stability : experimental--- Portability : portable------ The monadic parser type and combinators to construct--- packrat parsers for code generator.-----module Text.Peggy.Prim (- -- * Parsing functions- parse,- parseString,- parseFile,- - -- * The parser type- Parser(..),- -- * The (internal) result type- Result(..),- -- * The error type- ParseError(..),- -- * The cache type- MemoTable(..),- - -- * Memoising combinator- memo,- - -- * Position functions- getPos,- setPos,- - -- * Combinators- anyChar,- satisfy,- char,- string,- - expect,- unexpect,- - -- * Utiligy- space,- defaultDelimiter,- token,- ) where--import Control.Applicative-import Control.Monad.ST-import Control.Monad.Error-import Data.Char-import Data.HashTable.ST.Basic as HT-import qualified Data.ListLike as LL--import Text.Peggy.SrcLoc---- | Parsing function-parse :: MemoTable tbl- => (forall s . Parser tbl str s a) -- ^ parser- -> SrcPos -- ^ input information- -> str -- ^ input string- -> Either ParseError a -- ^ result-parse p pos str = runST $ do- tbl <- newTable- res <- unParser p tbl pos ' ' str- case res of- Parsed _ _ _ ret -> return $ Right ret- Failed err -> return $ Left err---- | Parsing function with only input name-parseString :: MemoTable tbl- => (forall s . Parser tbl str s a) -- ^ parser- -> String -- ^ input name- -> str -- ^ input string- -> Either ParseError a -- ^ result-parseString p inputName str =- parse p (SrcPos inputName 0 1 1) str---- | Parse from file-parseFile :: MemoTable tbl- => (forall s . Parser tbl String s a) -- ^ parser- -> FilePath -- ^ input filename- -> IO (Either ParseError a) -- ^ result-parseFile p fp =- parse p (SrcPos fp 0 1 1) <$> readFile fp------newtype Parser tbl str s a- = Parser { unParser :: tbl s -> SrcPos -> Char -> str -> ST s (Result str a) }--data Result str a- = Parsed SrcPos Char str a- | Failed ParseError--data ParseError- = ParseError SrcLoc String- deriving (Show)--instance Error ParseError--nullError :: ParseError-nullError = ParseError (LocPos $ SrcPos "" 0 1 1) ""--errMerge :: ParseError -> ParseError -> ParseError-errMerge e1@(ParseError loc1 msg1) e2@(ParseError loc2 msg2)- | loc1 >= loc2 = e1- | otherwise = e2--class MemoTable tbl where- newTable :: ST s (tbl s)--instance Monad (Parser tbl str s) where- return v = Parser $ \_ pos p s -> return $ Parsed pos p s v- p >>= f = Parser $ \tbl pos prev s -> do- res <- unParser p tbl pos prev s- case res of- Parsed qos q t x ->- unParser (f x) tbl qos q t- Failed err ->- return $ Failed err--instance Functor (Parser tbl str s) where- fmap f p = return . f =<< p--instance Applicative (Parser tbl str s) where- pure = return- p <*> q = do- f <- p- x <- q- return $ f x--instance MonadError ParseError (Parser tbl str s) where- throwError err = Parser $ \_ _ _ _ -> return $ Failed err- catchError p h = Parser $ \tbl pos prev s -> do- res <- unParser p tbl pos prev s- case res of- Parsed {} -> return res- Failed err -> unParser (h err) tbl pos prev s--instance Alternative (Parser tbl str s) where- empty = throwError nullError- p <|> q =- catchError p $ \perr ->- catchError q $ \qerr ->- throwError $ perr `errMerge` qerr--memo :: (tbl s -> HT.HashTable s Int (Result str a))- -> Parser tbl str s a - -> Parser tbl str s a-memo ft p = Parser $ \tbl pos@(SrcPos _ n _ _) prev s -> do- cache <- HT.lookup (ft tbl) n- case cache of- Just v -> return v- Nothing -> do- v <- unParser p tbl pos prev s- HT.insert (ft tbl) n v- return v--getPos :: Parser tbl str s SrcPos-getPos = Parser $ \_ pos prev str -> return $ Parsed pos prev str pos--setPos :: SrcPos -> Parser tbl str s ()-setPos pos = Parser $ \_ _ prev str -> return $ Parsed pos prev str ()--parseError :: String -> Parser tbl str s a-parseError msg =- throwError =<< ParseError . LocPos <$> getPos <*> pure msg--anyChar :: LL.ListLike str Char => Parser tbl str s Char-anyChar = Parser $ \_ pos _ str ->- if LL.null str- then return $ Failed nullError- else do- let c = LL.head str- cs = LL.tail str- return $ Parsed (pos `advance` c) c cs c--satisfy :: LL.ListLike str Char => (Char -> Bool) -> Parser tbl str s Char-satisfy p = do- c <- anyChar- when (not $ p c) $ throwError nullError- return c--char :: LL.ListLike str Char => Char -> Parser tbl str s Char-char c = satisfy (==c) <|> parseError ("expect " ++ show c)--string :: LL.ListLike str Char => String -> Parser tbl str s String-string str = mapM char str <|> parseError ("expect " ++ show str)--expect :: LL.ListLike str Char => Parser tbl str s a -> Parser tbl str s ()-expect p = do- b <- test p- when (not b) $ parseError "unexpected input"--unexpect :: LL.ListLike str Char => Parser tbl str s a -> Parser tbl str s ()-unexpect p = do- b <- test p- when b $ parseError "unexpected input"--test :: LL.ListLike str Char => Parser tbl str s a -> Parser tbl str s Bool-test p = Parser $ \tbl pos prev str -> do- res <- unParser p tbl pos prev str- return $ case res of- Parsed _ _ _ _ -> Parsed pos prev str True- Failed _ -> Parsed pos prev str False--space :: LL.ListLike str Char => Parser tbl str s ()-space = () <$ satisfy isSpace--defaultDelimiter :: LL.ListLike str Char => Parser tbl str s ()-defaultDelimiter = () <$ satisfy (\c -> isPunctuation c || c == '+')--getPrevChar :: LL.ListLike str Char => Parser tbl str s Char-getPrevChar = Parser $ \_ pos prev str ->- return $ Parsed pos prev str prev --token :: LL.ListLike str Char- => Parser tbl str s ()- -> Parser tbl str s ()- -> Parser tbl str s a- -> Parser tbl str s a-token sp del p = do- many sp- ret <- p- prev <- getPrevChar- sp <|> expect del <|> unexpect (satisfy $ check prev)- many sp- return ret- where- check pr cr- | isAlnum' pr && isAlnum' cr = True -- error "alnum"- | isDigit pr && isDigit cr = True -- error "digit"- | isGlyph pr && isGlyph cr = True -- error ("glyph " ++ show pr ++ ", " ++ show cr)- | otherwise = False- - isAlnum' c = isAlpha' c || isDigit c- isAlpha' c = isAlpha c || c == '_'- isGlyph c = isPrint c && not (isAlpha' c) && not (isDigit c)+{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, RankNTypes #-} + +-- | +-- Module : Text.Peggy.Prim +-- Copyright : (c) Hideyuki Tanaka 2011 +-- License : BSD-style +-- +-- Maintainer : tanaka.hideyuki@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- The monadic parser type and combinators to construct +-- packrat parsers for code generator. +-- + +module Text.Peggy.Prim ( + -- * Parsing functions + parse, + parseString, + parseFile, + + -- * The parser type + Parser(..), + -- * The (internal) result type + Result(..), + -- * The error type + ParseError(..), + -- * The cache type + MemoTable(..), + + -- * Memoising combinator + memo, + + -- * Position functions + getPos, + setPos, + + -- * Combinators + anyChar, + satisfy, + char, + string, + + expect, + unexpect, + + -- * Utiligy + space, + defaultDelimiter, + token, + ) where + +import Control.Applicative +import Control.Monad.ST +import Control.Monad.Error +import Data.Char +import Data.HashTable.ST.Basic as HT +import qualified Data.ListLike as LL + +import Text.Peggy.SrcLoc + +-- | Parsing function +parse :: MemoTable tbl + => (forall s . Parser tbl str s a) -- ^ parser + -> SrcPos -- ^ input information + -> str -- ^ input string + -> Either ParseError a -- ^ result +parse p pos str = runST $ do + tbl <- newTable + res <- unParser p tbl pos ' ' str + case res of + Parsed _ _ _ ret -> return $ Right ret + Failed err -> return $ Left err + +-- | Parsing function with only input name +parseString :: MemoTable tbl + => (forall s . Parser tbl str s a) -- ^ parser + -> String -- ^ input name + -> str -- ^ input string + -> Either ParseError a -- ^ result +parseString p inputName str = + parse p (SrcPos inputName 0 1 1) str + +-- | Parse from file +parseFile :: MemoTable tbl + => (forall s . Parser tbl String s a) -- ^ parser + -> FilePath -- ^ input filename + -> IO (Either ParseError a) -- ^ result +parseFile p fp = + parse p (SrcPos fp 0 1 1) <$> readFile fp + +-- + +newtype Parser tbl str s a + = Parser { unParser :: tbl s -> SrcPos -> Char -> str -> ST s (Result str a) } + +data Result str a + = Parsed SrcPos Char str a + | Failed ParseError + +data ParseError + = ParseError SrcLoc String + deriving (Show) + +instance Error ParseError + +nullError :: ParseError +nullError = ParseError (LocPos $ SrcPos "" 0 1 1) "" + +errMerge :: ParseError -> ParseError -> ParseError +errMerge e1@(ParseError loc1 msg1) e2@(ParseError loc2 msg2) + | loc1 >= loc2 = e1 + | otherwise = e2 + +class MemoTable tbl where + newTable :: ST s (tbl s) + +instance Monad (Parser tbl str s) where + return v = Parser $ \_ pos p s -> return $ Parsed pos p s v + p >>= f = Parser $ \tbl pos prev s -> do + res <- unParser p tbl pos prev s + case res of + Parsed qos q t x -> + unParser (f x) tbl qos q t + Failed err -> + return $ Failed err + +instance Functor (Parser tbl str s) where + fmap f p = return . f =<< p + +instance Applicative (Parser tbl str s) where + pure = return + p <*> q = do + f <- p + x <- q + return $ f x + +instance MonadError ParseError (Parser tbl str s) where + throwError err = Parser $ \_ _ _ _ -> return $ Failed err + catchError p h = Parser $ \tbl pos prev s -> do + res <- unParser p tbl pos prev s + case res of + Parsed {} -> return res + Failed err -> unParser (h err) tbl pos prev s + +instance Alternative (Parser tbl str s) where + empty = throwError nullError + p <|> q = + catchError p $ \perr -> + catchError q $ \qerr -> + throwError $ perr `errMerge` qerr + +memo :: (tbl s -> HT.HashTable s Int (Result str a)) + -> Parser tbl str s a + -> Parser tbl str s a +memo ft p = Parser $ \tbl pos@(SrcPos _ n _ _) prev s -> do + cache <- HT.lookup (ft tbl) n + case cache of + Just v -> return v + Nothing -> do + v <- unParser p tbl pos prev s + HT.insert (ft tbl) n v + return v + +getPos :: Parser tbl str s SrcPos +getPos = Parser $ \_ pos prev str -> return $ Parsed pos prev str pos + +setPos :: SrcPos -> Parser tbl str s () +setPos pos = Parser $ \_ _ prev str -> return $ Parsed pos prev str () + +parseError :: String -> Parser tbl str s a +parseError msg = + throwError =<< ParseError . LocPos <$> getPos <*> pure msg + +anyChar :: LL.ListLike str Char => Parser tbl str s Char +anyChar = Parser $ \_ pos _ str -> + if LL.null str + then return $ Failed nullError + else do + let c = LL.head str + cs = LL.tail str + return $ Parsed (pos `advance` c) c cs c + +satisfy :: LL.ListLike str Char => (Char -> Bool) -> Parser tbl str s Char +satisfy p = do + c <- anyChar + when (not $ p c) $ throwError nullError + return c + +char :: LL.ListLike str Char => Char -> Parser tbl str s Char +char c = satisfy (==c) <|> parseError ("expect " ++ show c) + +string :: LL.ListLike str Char => String -> Parser tbl str s String +string str = mapM char str <|> parseError ("expect " ++ show str) + +expect :: LL.ListLike str Char => Parser tbl str s a -> Parser tbl str s () +expect p = do + b <- test p + when (not b) $ parseError "unexpected input" + +unexpect :: LL.ListLike str Char => Parser tbl str s a -> Parser tbl str s () +unexpect p = do + b <- test p + when b $ parseError "unexpected input" + +test :: LL.ListLike str Char => Parser tbl str s a -> Parser tbl str s Bool +test p = Parser $ \tbl pos prev str -> do + res <- unParser p tbl pos prev str + return $ case res of + Parsed _ _ _ _ -> Parsed pos prev str True + Failed _ -> Parsed pos prev str False + +space :: LL.ListLike str Char => Parser tbl str s () +space = () <$ satisfy isSpace + +defaultDelimiter :: LL.ListLike str Char => Parser tbl str s () +defaultDelimiter = () <$ satisfy (\c -> isPunctuation c || c == '+') + +getPrevChar :: LL.ListLike str Char => Parser tbl str s Char +getPrevChar = Parser $ \_ pos prev str -> + return $ Parsed pos prev str prev + +token :: LL.ListLike str Char + => Parser tbl str s () + -> Parser tbl str s () + -> Parser tbl str s a + -> Parser tbl str s a +token sp del p = do + many sp + ret <- p + prev <- getPrevChar + sp <|> expect del <|> unexpect (satisfy $ check prev) + many sp + return ret + where + check pr cr + | isAlnum' pr && isAlnum' cr = True -- error "alnum" + | isDigit pr && isDigit cr = True -- error "digit" + | isGlyph pr && isGlyph cr = True -- error ("glyph " ++ show pr ++ ", " ++ show cr) + | otherwise = False + + isAlnum' c = isAlpha' c || isDigit c + isAlpha' c = isAlpha c || c == '_' + isGlyph c = isPrint c && not (isAlpha' c) && not (isDigit c)
Text/Peggy/Quote.hs view
@@ -1,134 +1,134 @@-{-# LANGUAGE RankNTypes #-}---- |--- Module : Text.Peggy.Quote--- Copyright : (c) Hideyuki Tanaka 2011--- License : BSD-style------ Maintainer : tanaka.hideyuki@gmail.com--- Stability : experimental--- Portability : portable------ The quasi-quoters of peggy syntax.-----module Text.Peggy.Quote (- -- * Quasiquoter- peggy,- peggyFile,- - -- * Parser and Quasiquoter generating function- genParser,- ) where--import Language.Haskell.TH-import Language.Haskell.TH.Quote--import Text.Peggy.Parser-import Text.Peggy.Prim-import Text.Peggy.Syntax-import Text.Peggy.SrcLoc-import Text.Peggy.CodeGen.TH---- | quasi-quoter for peggy syntax--- When it is used at top-level of source code,--- definitions of parsers are generated.------ > {-# LANGUAGE TemplateHaskell, QuasiQuotes, FlexibleContexts #-}--- > import Text.Peggy--- > --- > [peggy|--- > foo :: [Int]--- > = num*--- > num ::: Int--- > = [0-9]+ { read $1 }--- > |]--- > --- > main :: IO ()--- > main = print . parseString foo "<stdin>" =<< getContents------ When it is used as expression,--- the result value is 'Syntax'.------ > main = print [peggy|--- > num :: Int--- > = [0-9]+ { read $1 }--- > |]------ The result is:------ > $ runhaskell Test.hs--- > [Definition "num" "Int\n " (Choice [Semantic (Sequence [Some (TerminalSet [CharRange '0' '9'])]) [Snippet "read ",Argument 1,Snippet " "]])]----peggy :: QuasiQuoter-peggy = QuasiQuoter { quoteDec = qDecs, quoteExp = qExp, quotePat = undefined, quoteType = undefined }---- | Parse peggy syntax from File--- Parse a peggy syntax file and return a 'Syntax' as a result value.------ > $ cat test.peggy--- > num :: Int--- > = [0-9]+ { return $1 }------ > main = print $(peggyFile "test.peggy")------ The result is:------ > [Definition "num" "Int\n " (Choice [Semantic (Sequence [Some (TerminalSet [CharRange '0' '9'])]) [Snippet "read ",Argument 1,Snippet " "]])]----peggyFile :: FilePath -> Q Exp-peggyFile filename = do- res <- runIO $ parseFile syntax filename- case res of- Left err -> error $ show err- Right syn -> dataToExpQ (const Nothing) syn--qDecs :: String -> Q [Dec]-qDecs txt = do- loc <- location- genDecs $ parseSyntax (locToPos loc) txt--qExp :: String -> Q Exp-qExp txt = do- loc <- location- dataToExpQ (const Nothing) $ parseSyntax (locToPos loc) txt---- | Generates parsers and quasi-quoters.--- First argument is a list of names of quasi-quoter you want to define.--- For example:--- --- > genParser [("fooqq", "foo")] [peggy|--- > foo :: [Int]--- > = num*--- > num ::: Int--- > = [0-9]+ { read $1 }--- > |]------ this code defines parsers named 'foo', 'num' and--- quasi-quoter named 'fooqq'.------ It can use it as follow:------ > main :: IO ()--- > main = print [fooqq| 1 2 3 4 5 |]----genParser :: [(String, String)] -- ^ a list of pair of name of- -- quasi-quoter and its start nonterminal- -> Syntax -- ^ syntax- -> Q [Dec] -- ^ definitions of parsers and quasi-quoters-genParser qqs syn = do- qq <- mapM (genQQ syn) qqs- dec <- genDecs syn- return $ concat qq ++ dec------parseSyntax :: SrcPos -> String -> Syntax-parseSyntax pos txt =- case parse syntax pos txt of- Left err -> error $ "peggy syntax-error: " ++ show err- Right defs -> defs--locToPos :: Loc -> SrcPos-locToPos loc =- SrcPos (loc_filename loc) 0 (fst $ loc_start loc) (snd $ loc_start loc)+{-# LANGUAGE RankNTypes #-} + +-- | +-- Module : Text.Peggy.Quote +-- Copyright : (c) Hideyuki Tanaka 2011 +-- License : BSD-style +-- +-- Maintainer : tanaka.hideyuki@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- The quasi-quoters of peggy syntax. +-- + +module Text.Peggy.Quote ( + -- * Quasiquoter + peggy, + peggyFile, + + -- * Parser and Quasiquoter generating function + genParser, + ) where + +import Language.Haskell.TH +import Language.Haskell.TH.Quote + +import Text.Peggy.Parser +import Text.Peggy.Prim +import Text.Peggy.Syntax +import Text.Peggy.SrcLoc +import Text.Peggy.CodeGen.TH + +-- | quasi-quoter for peggy syntax +-- When it is used at top-level of source code, +-- definitions of parsers are generated. +-- +-- > {-# LANGUAGE TemplateHaskell, QuasiQuotes, FlexibleContexts #-} +-- > import Text.Peggy +-- > +-- > [peggy| +-- > foo :: [Int] +-- > = num* +-- > num ::: Int +-- > = [0-9]+ { read $1 } +-- > |] +-- > +-- > main :: IO () +-- > main = print . parseString foo "<stdin>" =<< getContents +-- +-- When it is used as expression, +-- the result value is 'Syntax'. +-- +-- > main = print [peggy| +-- > num :: Int +-- > = [0-9]+ { read $1 } +-- > |] +-- +-- The result is: +-- +-- > $ runhaskell Test.hs +-- > [Definition "num" "Int\n " (Choice [Semantic (Sequence [Some (TerminalSet [CharRange '0' '9'])]) [Snippet "read ",Argument 1,Snippet " "]])] +-- +peggy :: QuasiQuoter +peggy = QuasiQuoter { quoteDec = qDecs, quoteExp = qExp, quotePat = undefined, quoteType = undefined } + +-- | Parse peggy syntax from File +-- Parse a peggy syntax file and return a 'Syntax' as a result value. +-- +-- > $ cat test.peggy +-- > num :: Int +-- > = [0-9]+ { return $1 } +-- +-- > main = print $(peggyFile "test.peggy") +-- +-- The result is: +-- +-- > [Definition "num" "Int\n " (Choice [Semantic (Sequence [Some (TerminalSet [CharRange '0' '9'])]) [Snippet "read ",Argument 1,Snippet " "]])] +-- +peggyFile :: FilePath -> Q Exp +peggyFile filename = do + res <- runIO $ parseFile syntax filename + case res of + Left err -> error $ show err + Right syn -> dataToExpQ (const Nothing) syn + +qDecs :: String -> Q [Dec] +qDecs txt = do + loc <- location + genDecs $ parseSyntax (locToPos loc) txt + +qExp :: String -> Q Exp +qExp txt = do + loc <- location + dataToExpQ (const Nothing) $ parseSyntax (locToPos loc) txt + +-- | Generates parsers and quasi-quoters. +-- First argument is a list of names of quasi-quoter you want to define. +-- For example: +-- +-- > genParser [("fooqq", "foo")] [peggy| +-- > foo :: [Int] +-- > = num* +-- > num ::: Int +-- > = [0-9]+ { read $1 } +-- > |] +-- +-- this code defines parsers named 'foo', 'num' and +-- quasi-quoter named 'fooqq'. +-- +-- It can use it as follow: +-- +-- > main :: IO () +-- > main = print [fooqq| 1 2 3 4 5 |] +-- +genParser :: [(String, String)] -- ^ a list of pair of name of + -- quasi-quoter and its start nonterminal + -> Syntax -- ^ syntax + -> Q [Dec] -- ^ definitions of parsers and quasi-quoters +genParser qqs syn = do + qq <- mapM (genQQ syn) qqs + dec <- genDecs syn + return $ concat qq ++ dec + +-- + +parseSyntax :: SrcPos -> String -> Syntax +parseSyntax pos txt = + case parse syntax pos txt of + Left err -> error $ "peggy syntax-error: " ++ show err + Right defs -> defs + +locToPos :: Loc -> SrcPos +locToPos loc = + SrcPos (loc_filename loc) 0 (fst $ loc_start loc) (snd $ loc_start loc)
Text/Peggy/SrcLoc.hs view
@@ -1,34 +1,34 @@-{-# LANGUAGE DeriveDataTypeable #-}--module Text.Peggy.SrcLoc (- SrcLoc(..),- SrcPos(..),- - advance,- ) where--import Data.Data--data SrcLoc- = LocPos !SrcPos- | LocSpan !SrcPos !SrcPos- deriving (Show, Eq, Ord, Typeable, Data)--data SrcPos =- SrcPos- { locFile :: !FilePath- , locAbs :: {-# UNPACK #-} !Int- , locLine :: {-# UNPACK #-} !Int- , locCol :: {-# UNPACK #-} !Int- }- deriving (Show, Eq, Ord, Typeable, Data)--tabWidth :: Int-tabWidth = 8--advance :: SrcPos -> Char -> SrcPos-advance (SrcPos f a l c) x =- case x of- '\t' -> SrcPos f (a + 1) l ((c - 1 + tabWidth - 1) `div` tabWidth * tabWidth + 1)- '\n' -> SrcPos f (a + 1) (l + 1) 1- _ -> SrcPos f (a + 1) l (c + 1)+{-# LANGUAGE DeriveDataTypeable #-} + +module Text.Peggy.SrcLoc ( + SrcLoc(..), + SrcPos(..), + + advance, + ) where + +import Data.Data + +data SrcLoc + = LocPos !SrcPos + | LocSpan !SrcPos !SrcPos + deriving (Show, Eq, Ord, Typeable, Data) + +data SrcPos = + SrcPos + { locFile :: !FilePath + , locAbs :: {-# UNPACK #-} !Int + , locLine :: {-# UNPACK #-} !Int + , locCol :: {-# UNPACK #-} !Int + } + deriving (Show, Eq, Ord, Typeable, Data) + +tabWidth :: Int +tabWidth = 8 + +advance :: SrcPos -> Char -> SrcPos +advance (SrcPos f a l c) x = + case x of + '\t' -> SrcPos f (a + 1) l ((c - 1 + tabWidth - 1) `div` tabWidth * tabWidth + 1) + '\n' -> SrcPos f (a + 1) (l + 1) 1 + _ -> SrcPos f (a + 1) l (c + 1)
Text/Peggy/Syntax.hs view
@@ -1,64 +1,64 @@-{-# LANGUAGE DeriveDataTypeable #-}--module Text.Peggy.Syntax (- Syntax,- Definition(..),- Expr(..),- CharRange(..),- CodeFragment,- CodePart(..),- Identifier,- TermType,- ) where--import Data.Data--type Syntax = [Definition]--data Definition- = Definition Identifier TermType Expr- deriving (Show, Eq, Typeable, Data)--data Expr- = Terminals Bool Bool String- | TerminalSet [CharRange]- | TerminalCmp [CharRange]- | TerminalAny- | NonTerminal Identifier- | Primitive Identifier- | Empty- - | Named Identifier Expr- - | Sequence [Expr]- | Choice [Expr]- | Many Expr- | Some Expr- | Optional Expr- | And Expr- | Not Expr- - | SepBy Expr Expr- | SepBy1 Expr Expr- | Token Expr- - | Semantic Expr CodeFragment- deriving (Show, Eq, Typeable, Data)--data CharRange- = CharRange Char Char- | CharOne Char- deriving (Show, Eq, Typeable, Data)--type CodeFragment = [CodePart]--data CodePart- = Snippet String- | Argument Int- | AntiArgument Int- | ArgPos- | ArgSpan- deriving (Show, Eq, Typeable, Data)--type Identifier = String-type TermType = String+{-# LANGUAGE DeriveDataTypeable #-} + +module Text.Peggy.Syntax ( + Syntax, + Definition(..), + Expr(..), + CharRange(..), + CodeFragment, + CodePart(..), + Identifier, + TermType, + ) where + +import Data.Data + +type Syntax = [Definition] + +data Definition + = Definition Identifier TermType Expr + deriving (Show, Eq, Typeable, Data) + +data Expr + = Terminals Bool Bool String + | TerminalSet [CharRange] + | TerminalCmp [CharRange] + | TerminalAny + | NonTerminal Identifier + | Primitive Identifier + | Empty + + | Named Identifier Expr + + | Sequence [Expr] + | Choice [Expr] + | Many Expr + | Some Expr + | Optional Expr + | And Expr + | Not Expr + + | SepBy Expr Expr + | SepBy1 Expr Expr + | Token Expr + + | Semantic Expr CodeFragment + deriving (Show, Eq, Typeable, Data) + +data CharRange + = CharRange Char Char + | CharOne Char + deriving (Show, Eq, Typeable, Data) + +type CodeFragment = [CodePart] + +data CodePart + = Snippet String + | Argument Int + | AntiArgument Int + | ArgPos + | ArgSpan + deriving (Show, Eq, Typeable, Data) + +type Identifier = String +type TermType = String
bootstrap/Bootstrap.hs view
@@ -1,39 +1,39 @@-{-# LANGUAGE TemplateHaskell, QuasiQuotes, FlexibleContexts #-}--import Data.Char-import Numeric-import Language.Haskell.TH-import Language.Haskell.Meta.Utils--import qualified Stage2--import Text.Peggy.Prim-import Text.Peggy.Quote-import Text.Peggy.CodeGen.TH-import Text.Peggy.Syntax-import Text.Peggy.SrcLoc--header :: String-header =- unlines- [ "{-# LANGUAGE RankNTypes, FlexibleContexts #-}"- , ""- , "module Text.Peggy.Parser (syntax) where"- , "import Control.Applicative"- , "import Data.ListLike.Base hiding (head)"- , "import Data.HashTable.ST.Basic"- , "import Numeric"- , "import Data.Char"- , "import Text.Peggy.Prim"- , "import Text.Peggy.Syntax"- ]--main :: IO ()-main = do- res <- parseFile Stage2.syntax "./peggy.peggy"- case res of- Left err -> error $ show err- Right defs -> do- code <- runQ $ genDecs defs- putStrLn header- putStrLn $ pp code+{-# LANGUAGE TemplateHaskell, QuasiQuotes, FlexibleContexts #-} + +import Data.Char +import Numeric +import Language.Haskell.TH +import Language.Haskell.Meta.Utils + +import qualified Stage2 + +import Text.Peggy.Prim +import Text.Peggy.Quote +import Text.Peggy.CodeGen.TH +import Text.Peggy.Syntax +import Text.Peggy.SrcLoc + +header :: String +header = + unlines + [ "{-# LANGUAGE RankNTypes, FlexibleContexts #-}" + , "" + , "module Text.Peggy.Parser (syntax) where" + , "import Control.Applicative" + , "import Data.ListLike.Base hiding (head)" + , "import Data.HashTable.ST.Basic" + , "import Numeric" + , "import Data.Char" + , "import Text.Peggy.Prim" + , "import Text.Peggy.Syntax" + ] + +main :: IO () +main = do + res <- parseFile Stage2.syntax "./peggy.peggy" + case res of + Left err -> error $ show err + Right defs -> do + code <- runQ $ genDecs defs + putStrLn header + putStrLn $ pp code
bootstrap/README.md view
@@ -1,10 +1,10 @@-# Bootstrap Instructions #--# Pre-requirement--Previous version of peggy (>= 0.2.0.1) required.--# Bootstrap-- $ cd bootstrap- $ runhaskell Bootstrap.hs > ../Text/Peggy/Parser.hs+# Bootstrap Instructions # + +# Pre-requirement + +Previous version of peggy (>= 0.2.0.1) required. + +# Bootstrap + + $ cd bootstrap + $ runhaskell Bootstrap.hs > ../Text/Peggy/Parser.hs
bootstrap/Stage1.hs view
@@ -1,10 +1,10 @@-{-# LANGUAGE TemplateHaskell, QuasiQuotes, FlexibleContexts #-}--module Stage1 where--import Data.Char-import Language.Haskell.TH.Quote-import Numeric-import Text.Peggy--genParser [] $(peggyFile "peggy.peggy")+{-# LANGUAGE TemplateHaskell, QuasiQuotes, FlexibleContexts #-} + +module Stage1 where + +import Data.Char +import Language.Haskell.TH.Quote +import Numeric +import Text.Peggy + +genParser [] $(peggyFile "peggy.peggy")
bootstrap/Stage2.hs view
@@ -1,13 +1,13 @@-{-# LANGUAGE TemplateHaskell, QuasiQuotes, FlexibleContexts #-}--module Stage2 where--import qualified Stage1--import Data.Char-import Numeric-import Language.Haskell.TH-import Language.Haskell.TH.Quote-import Text.Peggy--genParser [] $(runIO (parseFile Stage1.syntax "peggy.peggy") >>= \res -> case res of Left err -> error $ show err; Right syn -> dataToExpQ (const Nothing) syn)+{-# LANGUAGE TemplateHaskell, QuasiQuotes, FlexibleContexts #-} + +module Stage2 where + +import qualified Stage1 + +import Data.Char +import Numeric +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import Text.Peggy + +genParser [] $(runIO (parseFile Stage1.syntax "peggy.peggy") >>= \res -> case res of Left err -> error $ show err; Right syn -> dataToExpQ (const Nothing) syn)
bootstrap/peggy.peggy view
@@ -1,102 +1,102 @@--- A Parser for peggy itself.--syntax :: Syntax- = definition* !(skip* .)--definition ::: Definition- = ident ":::" haskellType "=" expr { Definition $1 $2 (Token $3) }- / ident "::" haskellType "=" expr { Definition $1 $2 $3 }--expr :: Expr- = choiceExpr--choiceExpr :: Expr- = (semanticExpr, "/") { Choice $1 }--semanticExpr :: Expr- = sequenceExpr "{" codeFragment "}" { Semantic $1 $2 }- / sequenceExpr--sequenceExpr :: Expr- = (namedExpr !"::" !"=")+ { Sequence $1 }--namedExpr :: Expr- = ident ":" suffixExpr { Named $1 $2 }- / suffixExpr--suffixExpr :: Expr- = suffixExpr "*" { Many $1 }- / suffixExpr "+" { Some $1 }- / suffixExpr "?" { Optional $1 }- / prefixExpr--prefixExpr :: Expr- = "&" primExpr { And $1 }- / "!" primExpr { Not $1 }- / primExpr--primExpr ::: Expr- = '\"' charLit* '\"' { Terminals True True $1 }- / '\'' charLit* '\'' { Terminals False False $1 }- / '[^' range* ']' { TerminalCmp $1 }- / '[' range* ']' { TerminalSet $1 }- / "." { TerminalAny }- / ident { NonTerminal $1 }- / "(" expr "," expr ")" { SepBy $1 $2 }- / "(" expr ";" expr ")" { SepBy1 $1 $2 }- / "(" expr ")"--charLit :: Char- = '\\' escChar- / ![\'\"] .--escChar :: Char- = 'n' { '\n' }- / 'r' { '\r' }- / 't' { '\t' }- / '\\' { '\\' }- / '\"' { '\"' }- / '\'' { '\'' }- / 'x' hexDigit hexDigit { chr . fst . head . readHex $ [$1, $2] }--range :: CharRange- = rchar '-' rchar { CharRange $1 $2 }- / rchar { CharOne $1 }--rchar :: Char- = '\\' escChar- / '\\]' {']'} / '\\[' { '[' } / '\\^' { '^' } / '\\-' { '-' }- / [^\]]--haskellType :: TermType- = [^=]+--codeFragment :: CodeFragment- = codePart*--codePart :: CodePart- = argument- / (!'}' !argument .)+ { Snippet $1 }--argument :: CodePart- = '$$' digit+ { AntiArgument $ read $1 }- / '$' digit+ { Argument $ read $1 }- / '$' 'p' { ArgPos }- / '$' 's' { ArgSpan }--digit :: Char = [0-9] -hexDigit :: Char = [0-9a-fA-F]--ident ::: String = [a-z_] [0-9a-zA-Z_]* { $1 : $2 }--skip :: ()- = _:[ \r\n\t] / comment--comment :: ()- = lineComment / regionComment--lineComment :: ()- = '--' _:(!'\n' _:.)* '\n'--regionComment :: ()- = '{-' _:(regionComment / !'-}' _:.)* '-}'+-- A Parser for peggy itself. + +syntax :: Syntax + = definition* !(skip* .) + +definition ::: Definition + = ident ":::" haskellType "=" expr { Definition $1 $2 (Token $3) } + / ident "::" haskellType "=" expr { Definition $1 $2 $3 } + +expr :: Expr + = choiceExpr + +choiceExpr :: Expr + = (semanticExpr, "/") { Choice $1 } + +semanticExpr :: Expr + = sequenceExpr "{" codeFragment "}" { Semantic $1 $2 } + / sequenceExpr + +sequenceExpr :: Expr + = (namedExpr !"::" !"=")+ { Sequence $1 } + +namedExpr :: Expr + = ident ":" suffixExpr { Named $1 $2 } + / suffixExpr + +suffixExpr :: Expr + = suffixExpr "*" { Many $1 } + / suffixExpr "+" { Some $1 } + / suffixExpr "?" { Optional $1 } + / prefixExpr + +prefixExpr :: Expr + = "&" primExpr { And $1 } + / "!" primExpr { Not $1 } + / primExpr + +primExpr ::: Expr + = '\"' charLit* '\"' { Terminals True True $1 } + / '\'' charLit* '\'' { Terminals False False $1 } + / '[^' range* ']' { TerminalCmp $1 } + / '[' range* ']' { TerminalSet $1 } + / "." { TerminalAny } + / ident { NonTerminal $1 } + / "(" expr "," expr ")" { SepBy $1 $2 } + / "(" expr ";" expr ")" { SepBy1 $1 $2 } + / "(" expr ")" + +charLit :: Char + = '\\' escChar + / ![\'\"] . + +escChar :: Char + = 'n' { '\n' } + / 'r' { '\r' } + / 't' { '\t' } + / '\\' { '\\' } + / '\"' { '\"' } + / '\'' { '\'' } + / 'x' hexDigit hexDigit { chr . fst . head . readHex $ [$1, $2] } + +range :: CharRange + = rchar '-' rchar { CharRange $1 $2 } + / rchar { CharOne $1 } + +rchar :: Char + = '\\' escChar + / '\\]' {']'} / '\\[' { '[' } / '\\^' { '^' } / '\\-' { '-' } + / [^\]] + +haskellType :: TermType + = [^=]+ + +codeFragment :: CodeFragment + = codePart* + +codePart :: CodePart + = argument + / (!'}' !argument .)+ { Snippet $1 } + +argument :: CodePart + = '$$' digit+ { AntiArgument $ read $1 } + / '$' digit+ { Argument $ read $1 } + / '$' 'p' { ArgPos } + / '$' 's' { ArgSpan } + +digit :: Char = [0-9] +hexDigit :: Char = [0-9a-fA-F] + +ident ::: String = [a-z_] [0-9a-zA-Z_]* { $1 : $2 } + +skip :: () + = _:[ \r\n\t] / comment + +comment :: () + = lineComment / regionComment + +lineComment :: () + = '--' _:(!'\n' _:.)* '\n' + +regionComment :: () + = '{-' _:(regionComment / !'-}' _:.)* '-}'
example/Main.hs view
@@ -1,31 +1,31 @@-{-# LANGUAGE TemplateHaskell, QuasiQuotes, FlexibleContexts #-}--module Main (main) where--import Text.Peggy--genParser [] [peggy|--- Simple Arithmetic Expression Parser--top :: Double = expr--expr :: Double- = expr "+" fact { $1 + $2 }- / expr "-" fact { $1 - $2 }- / fact--fact :: Double- = fact "*" term { $1 * $2 }- / fact "/" term { $1 / $2 }- / term--term :: Double- = "(" expr ")"- / number--number ::: Double- = [1-9] [0-9]* { read ($1 : $2) }-|]--main :: IO ()-main = print . parseString top "<stdin>" =<< getContents+{-# LANGUAGE TemplateHaskell, QuasiQuotes, FlexibleContexts #-} + +module Main (main) where + +import Text.Peggy + +genParser [] [peggy| +-- Simple Arithmetic Expression Parser + +top :: Double = expr + +expr :: Double + = expr "+" fact { $1 + $2 } + / expr "-" fact { $1 - $2 } + / fact + +fact :: Double + = fact "*" term { $1 * $2 } + / fact "/" term { $1 / $2 } + / term + +term :: Double + = "(" expr ")" + / number + +number ::: Double + = [1-9] [0-9]* { read ($1 : $2) } +|] + +main :: IO () +main = print . parseString top "<stdin>" =<< getContents
peggy.cabal view
@@ -1,62 +1,62 @@-Name: peggy-Version: 0.3.1-Synopsis: The Parser Generator for Haskell--Description:-- The Parser Generator for Haskell- <http://tanakh.github.com/Peggy>---Homepage: http://tanakh.github.com/Peggy-License: BSD3-License-file: LICENSE-Author: Hideyuki Tanaka-Maintainer: Hideyuki Tanaka <tanaka.hideyuki@gmail.com>-Copyright: Copyright (c)2011, Hideyuki Tanaka-Category: Language-Build-type: Simple-Cabal-version: >=1.8--Extra-source-files: README.md- bootstrap/README.md- bootstrap/Stage1.hs- bootstrap/Stage2.hs- bootstrap/Bootstrap.hs- bootstrap/peggy.peggy--flag build-example- default: False--Source-repository head- Type: git- Location: git://github.com/tanakh/Peggy.git--Library- Exposed-modules: Text.Peggy- , Text.Peggy.CodeGen.TH- , Text.Peggy.LeftRec- , Text.Peggy.Normalize- , Text.Peggy.Parser- , Text.Peggy.Prim- , Text.Peggy.Quote- , Text.Peggy.SrcLoc- , Text.Peggy.Syntax- - Build-depends: base == 4.*- , mtl == 2.0.*- , ListLike == 3.1.*- , hashtables == 1.0.*- , monad-control == 0.3.*- , template-haskell >= 2.5 && < 2.8- , haskell-src-meta == 0.5.*- -Executable peggy-example- Hs-source-dirs: example- Main-is: Main.hs-- Build-depends: base == 4.*- , peggy-- if !flag(build-example)- Buildable: False+Name: peggy +Version: 0.3.1.1 +Synopsis: The Parser Generator for Haskell + +Description: + + The Parser Generator for Haskell + <http://tanakh.github.com/Peggy> + + +Homepage: http://tanakh.github.com/Peggy +License: BSD3 +License-file: LICENSE +Author: Hideyuki Tanaka +Maintainer: Hideyuki Tanaka <tanaka.hideyuki@gmail.com> +Copyright: Copyright (c)2011, Hideyuki Tanaka +Category: Language +Build-type: Simple +Cabal-version: >=1.8 + +Extra-source-files: README.md + bootstrap/README.md + bootstrap/Stage1.hs + bootstrap/Stage2.hs + bootstrap/Bootstrap.hs + bootstrap/peggy.peggy + +flag build-example + default: False + +Source-repository head + Type: git + Location: git://github.com/tanakh/Peggy.git + +Library + Exposed-modules: Text.Peggy + , Text.Peggy.CodeGen.TH + , Text.Peggy.LeftRec + , Text.Peggy.Normalize + , Text.Peggy.Parser + , Text.Peggy.Prim + , Text.Peggy.Quote + , Text.Peggy.SrcLoc + , Text.Peggy.Syntax + + Build-depends: base == 4.* + , mtl >= 2.0 + , ListLike == 3.1.* + , hashtables == 1.0.* + , monad-control == 0.3.* + , template-haskell >= 2.5 && < 2.8 + , haskell-src-meta == 0.5.* + +Executable peggy-example + Hs-source-dirs: example + Main-is: Main.hs + + Build-depends: base == 4.* + , peggy + + if !flag(build-example) + Buildable: False