peggy 0.3.1.1 → 0.3.2
raw patch · 19 files changed
+1619/−1619 lines, 19 filesdep ~haskell-src-metadep ~template-haskellsetup-changedPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: haskell-src-meta, template-haskell
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.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.2+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.9+ , 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