peggy 0.2.1 → 0.3.0
raw patch · 14 files changed
+401/−268 lines, 14 files
Files
- Main.hs +1/−1
- README.md +29/−27
- Text/Peggy/CodeGen/TH.hs +169/−80
- Text/Peggy/Normalize.hs +25/−3
- Text/Peggy/Parser.hs +144/−128
- Text/Peggy/Prim.hs +6/−8
- Text/Peggy/Quote.hs +5/−5
- Text/Peggy/SrcLoc.hs +1/−1
- Text/Peggy/Syntax.hs +2/−1
- bootstrap/Bootstrap.hs +3/−3
- bootstrap/Stage1.hs +1/−1
- bootstrap/Stage2.hs +1/−1
- bootstrap/peggy.peggy +13/−8
- peggy.cabal +1/−1
Main.hs view
@@ -1,4 +1,4 @@-{-# Language TemplateHaskell, QuasiQuotes, FlexibleContexts #-}+{-# LANGUAGE TemplateHaskell, QuasiQuotes, FlexibleContexts #-} module Main (main) where
README.md view
@@ -14,8 +14,10 @@ You can find a recent stable release in Hackage DB. You can install this as following instruction: - $ cabal update- $ cabal install Peggy+~~~ {.bash}+$ cabal update+$ cabal install Peggy+~~~ # Why should you use Peggy? @@ -39,29 +41,29 @@ Here is an example of parsing arithmetic expressions. - {-# 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+~~~ {.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+~~~
Text/Peggy/CodeGen/TH.hs view
@@ -1,6 +1,4 @@-{-# Language TemplateHaskell #-}-{-# Language TupleSections #-}-{-# Language FlexibleContexts #-}+{-# LANGUAGE TemplateHaskell, TupleSections, FlexibleContexts #-} module Text.Peggy.CodeGen.TH ( genDecs,@@ -10,9 +8,13 @@ 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@@ -31,7 +33,7 @@ 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 -> dataToExpQ (const Nothing) a + Right a -> a |] u <- [| undefined |] recConE 'QuasiQuoter [ return ('quoteExp, e)@@ -41,7 +43,7 @@ ] genDecs :: Syntax -> Q [Dec]-genDecs = generate . removeLeftRecursion . normalize+genDecs = generate . normalize . removeLeftRecursion generate :: Syntax -> Q [Dec] generate defs = do@@ -54,6 +56,7 @@ where n = length defs + defTbl :: Name -> Name -> DecQ defTbl tblTypName tblDatName = do s <- newName "s" str <- newName "str"@@ -61,10 +64,13 @@ 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) $(parseType' typ)) |]+ (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))@@ -76,105 +82,167 @@ ++ [ 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) = do- str <- newName "str"- s <- newName "s"- return $- [ sigD (mkName nont) $- 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`- parseType' typ- , funD (mkName nont)- [clause [] (normalB [| memo $(varE $ mkName $ "tbl_" ++ nont) $ $(genP e) |]) []]]+ 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) |]) []]] - genP e = case e of- Terminals False False str ->+ 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 isE e = case (isE, e) of+ (False, Terminals False False str) -> [| string str |]- Terminals True True str ->- genP (Token (Terminals False False str))+ (True, Terminals False False str) ->+ [| lift <$> string str |] - TerminalSet rs ->+ (False, TerminalSet rs) -> [| satisfy $(genRanges rs) |]- TerminalCmp rs ->+ (True, TerminalSet rs) ->+ [| lift <$> satisfy $(genRanges rs) |]++ (False, TerminalCmp rs) -> [| satisfy $ not . $(genRanges rs) |]- TerminalAny ->+ (True, TerminalCmp rs) ->+ [| lift <$> (satisfy $ not . $(genRanges rs)) |]++ (False, TerminalAny) -> [| anyChar |]- NonTerminal nont ->- [| $(varE $ mkName nont) |]- Primitive name ->+ (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) |]- Empty ->+ (True, Primitive name) ->+ [| lift <$> $(varE $ mkName name) |]++ (False, Empty) -> [| return () |]+ (True, Empty) ->+ [| lift <$> return () |] - Semantic (Sequence es) cf -> do- 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 cf) |] ]- Semantic f cf ->- genP (Semantic (Sequence [f]) cf)+ (False, Many f) ->+ [| many $(genP isE f) |]+ (True, Many f) ->+ [| do eQs <- many $(genP isE f); return $ listE eQs |] - Sequence es -> do- binds <- sequence $ genBinds 1 es- let vn = length $ filter isBind binds- doE $ do- map return binds ++- [ noBindS [| return $ $(tupE $ map (varE .mkName . var) [1..vn]) |] ]+ (False, Some f) ->+ [| some $(genP isE f) |]+ (True, Some f) ->+ [| do eQs <- some $(genP isE f); return $ listE eQs |] - Choice es ->- foldl1 (\a b -> [| $a <|> $b |]) $ map genP es+ (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) |] - Many f ->- [| many $(genP f) |]- Some f ->- [| some $(genP f) |]- Optional f ->- [| optional $(genP f) |]- And f ->- [| expect $(genP f) |]- Not f ->- [| unexpect $(genP f) |]+ (False, And f) ->+ [| expect $(genP isE f) |]+ (True, And f) ->+ [| lift () <$ expect $(genP isE f) |] - Token f ->- [| token $(varE skip) $(varE delimiter) ( $(genP f) ) |]+ (False, Not f) ->+ [| unexpect $(genP isE f) |]+ (True, Not f) ->+ [| lift () <$ unexpect $(genP isE f) |] - -- these are removed normalized phase- SepBy {} -> error "internal desugar error"- SepBy1 {} -> error "internal desugar error"+ (_, Token f) ->+ [| token $(varE skip) $(varE delimiter) ( $(genP isE f) ) |] - Named {} -> error "named expr must has semantic."+ -- simply, ignoreing result value+ (False, Named "_" f) ->+ [| () <$ $(genP isE f) |]+ (True, Named "_" f) ->+ [| () <$ $(genP isE f) |] - where- skip = mkName "skip"- delimiter = mkName "delimiter"+ (_, 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 g) :+ bindS (asP (mkName name) $ varP $ mkName (var ix)) (genP isE g) : genBinds (ix+1) fs _ | shouldBind f ->- bindS (varP $ mkName $ var ix) (genP f) :+ bindS (varP $ mkName $ var ix) (genP isE f) : genBinds (ix+1) fs _ ->- noBindS (genP f) :+ noBindS (genP isE f) : genBinds ix fs - shouldBind f = case f of- Terminals _ _ _ -> False- And _ -> False- Not _ -> False- _ -> True-- isBind (BindS _ _) = True- isBind _ = False- genRanges rs = let c = mkName "c" in lamE [varP c] $ foldl1 (\a b -> [| $a || $b |]) $ map (genRange c) rs@@ -183,7 +251,7 @@ genRange c (CharOne v) = [| $(varE c) == v |] - genCF cf =+ genCF isE cf = case parsed of Left _ -> error $ "code fragment parse error: " ++ scf@@ -194,15 +262,36 @@ 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) - var n = "v" ++ show (n :: Int)+ 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
Text/Peggy/Normalize.hs view
@@ -1,7 +1,9 @@ module Text.Peggy.Normalize ( normalize,+ shouldBind, ) where +import Data.List import Text.Peggy.Syntax normalize :: Syntax -> Syntax@@ -28,6 +30,9 @@ 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@@ -38,7 +43,6 @@ Named name f -> Named name $ desugar f - Sequence es -> Sequence $ map desugar es Choice es -> Choice $ map desugar es Many f -> Many $ desugar f Some f -> Some $ desugar f@@ -46,15 +50,21 @@ And f -> And $ desugar f Not f -> Not $ desugar f - Semantic f cf -> Semantic (desugar f) cf+ 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'' = Semantic g' [Snippet "()"] in+ let g'' = desugar $ Semantic g' [Snippet "()"] in Semantic (Sequence [f', (Many (Semantic (Sequence [g'', f']) [Argument 2]))]) [ Argument 1 , Snippet ":"@@ -63,3 +73,15 @@ 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,5 +1,5 @@-{-# Language RankNTypes #-}-{-# Language FlexibleContexts #-}+{-# LANGUAGE RankNTypes, FlexibleContexts #-}+ module Text.Peggy.Parser (syntax) where import Control.Applicative import Data.ListLike.Base hiding (head)@@ -10,14 +10,16 @@ import Text.Peggy.Syntax data MemoTable_0 str_1 s_2- = MemoTable_3 {tbl_syntax :: (HashTable s_2- Int- (Result str_1 Syntax)),+ = 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@@ -67,36 +69,41 @@ t_27 <- new t_28 <- new t_29 <- 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)-syntax :: forall str_30 s_31 . ListLike str_30 Char =>- Parser (MemoTable_0 str_30) str_30 s_31 Syntax+ 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_32 s_33 . ListLike str_32 Char =>- Parser (MemoTable_0 str_32) str_32 s_33 Definition-definition = memo tbl_definition $ ((many skip *> ((do v1 <- ident- (many skip *> string ":::") <* many skip- v2 <- haskellType- (many skip *> string "=") <* many skip- v3 <- expr- return (Definition v1 v2 (Token v3))) <|> (do v1 <- ident- (many skip *> string "::") <* many skip- v2 <- haskellType- (many skip *> string "=") <* many skip- v3 <- expr- return (Definition v1 v2 v3)))) <* many skip)-expr :: forall str_34 s_35 . ListLike str_34 Char =>- Parser (MemoTable_0 str_34) str_34 s_35 Expr+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_36 s_37 . ListLike str_36 Char =>- Parser (MemoTable_0 str_36) str_36 s_37 Expr+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 (many skip *> string "/") <* many skip+ v2 <- many (do v1 <- do v1 <- do token skip delimiter (string "/") return $ () return () v2 <- do v1 <- semanticExpr@@ -105,84 +112,91 @@ return (v1 : v2)) <|> (do v1 <- return () return []) return (Choice v1))-semanticExpr :: forall str_38 s_39 . ListLike str_38 Char =>- Parser (MemoTable_0 str_38) str_38 s_39 Expr+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- (many skip *> string "{") <* many skip+ token skip delimiter (string "{") v2 <- codeFragment- (many skip *> string "}") <* many skip+ token skip delimiter (string "}") return (Semantic v1 v2)) <|> (do v1 <- sequenceExpr return $ (v1)))-sequenceExpr :: forall str_40 s_41 . ListLike str_40 Char =>- Parser (MemoTable_0 str_40) str_40 s_41 Expr-sequenceExpr = memo tbl_sequenceExpr $ (do v1 <- some (do v1 <- suffixExpr- unexpect ((many skip *> string "::") <* many skip)- unexpect ((many skip *> string "=") <* many skip)+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))-suffixExpr :: forall str_42 s_43 . ListLike str_42 Char =>- Parser (MemoTable_0 str_42) str_42 s_43 Expr+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_44 s_45 . ListLike str_44 Char =>- Parser (MemoTable_0 str_44) str_44 s_45 (Expr -> Expr)-suffixExpr_tail = memo tbl_suffixExpr_tail $ ((((do (many skip *> string "*") <* many skip+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 (many skip *> string "+") <* many skip+ return (\v999 -> v1 (Many v999))) <|> (do token skip delimiter (string "+") v1 <- suffixExpr_tail- return (\v999 -> v1 (Some v999)))) <|> (do (many skip *> string "?") <* many skip+ 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_46 s_47 . ListLike str_46 Char =>- Parser (MemoTable_0 str_46) str_46 s_47 Expr-prefixExpr = memo tbl_prefixExpr $ (((do (many skip *> string "&") <* many skip+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 (many skip *> string "!") <* many skip+ return (And v1)) <|> (do token skip delimiter (string "!") v1 <- primExpr return (Not v1))) <|> (do v1 <- primExpr return $ (v1)))-primExpr :: forall str_48 s_49 . ListLike str_48 Char =>- Parser (MemoTable_0 str_48) str_48 s_49 Expr-primExpr = memo tbl_primExpr $ ((many skip *> (((((((((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 (many skip *> string ".") <* many skip- return TerminalAny)) <|> (do v1 <- ident- return (NonTerminal v1))) <|> (do (many skip *> string "(") <* many skip- v1 <- expr- (many skip *> string ",") <* many skip- v2 <- expr- (many skip *> string ")") <* many skip- return (SepBy v1 v2))) <|> (do (many skip *> string "(") <* many skip- v1 <- expr- (many skip *> string ";") <* many skip- v2 <- expr- (many skip *> string ")") <* many skip- return (SepBy1 v1 v2))) <|> (do (many skip *> string "(") <* many skip- v1 <- expr- (many skip *> string ")") <* many skip- return $ (v1)))) <* many skip)-charLit :: forall str_50 s_51 . ListLike str_50 Char =>- Parser (MemoTable_0 str_50) str_50 s_51 Char+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_52 s_53 . ListLike str_52 Char =>- Parser (MemoTable_0 str_52) str_52 s_53 Char+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"@@ -194,15 +208,15 @@ v2 <- hexDigit return ((chr . (fst . (head . readHex))) $ [v1, v2])))-range :: forall str_54 s_55 . ListLike str_54 Char =>- Parser (MemoTable_0 str_54) str_54 s_55 CharRange+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_56 s_57 . ListLike str_56 Char =>- Parser (MemoTable_0 str_56) str_56 s_57 Char+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 "\\]"@@ -211,68 +225,70 @@ return '^')) <|> (do string "\\-" return '-')) <|> (do v1 <- satisfy $ (not . (\c -> c == ']')) return $ (v1)))-haskellType :: forall str_58 s_59 . ListLike str_58 Char =>- Parser (MemoTable_0 str_58) str_58 s_59 TermType+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_60 s_61 . ListLike str_60 Char =>- Parser (MemoTable_0 str_60) str_60 s_61 CodeFragment+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_62 s_63 . ListLike str_62 Char =>- Parser (MemoTable_0 str_62) str_62 s_63 CodePart+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_64 s_65 . ListLike str_64 Char =>- Parser (MemoTable_0 str_64) str_64 s_65 CodePart-argument = memo tbl_argument $ (((do string "$"- v1 <- some digit- return (Argument $ read v1)) <|> (do string "$"- string "p"- return ArgPos)) <|> (do string "$"- string "s"- return ArgSpan))-digit :: forall str_66 s_67 . ListLike str_66 Char =>- Parser (MemoTable_0 str_66) str_66 s_67 Char+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_68 s_69 . ListLike str_68 Char =>- Parser (MemoTable_0 str_68) str_68 s_69 Char+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_70 s_71 . ListLike str_70 Char =>- Parser (MemoTable_0 str_70) str_70 s_71 String-ident = memo tbl_ident $ ((many skip *> (do v1 <- satisfy (\c -> ('a' <= c) && (c <= 'z'))- v2 <- many (satisfy (\c -> (((('0' <= c) && (c <= '9')) || (('a' <= c) && (c <= 'z'))) || (('A' <= c) && (c <= 'Z'))) || (c == '_')))- return (v1 : v2))) <* many skip)-skip :: forall str_72 s_73 . ListLike str_72 Char =>- Parser (MemoTable_0 str_72) str_72 s_73 ()-skip = memo tbl_skip $ ((do v1 <- satisfy (\c -> (((c == ' ') || (c == '\r')) || (c == '\n')) || (c == '\t'))- return ()) <|> (do v1 <- comment- return $ (v1)))-comment :: forall str_74 s_75 . ListLike str_74 Char =>- Parser (MemoTable_0 str_74) str_74 s_75 ()+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_76 s_77 . ListLike str_76 Char =>- Parser (MemoTable_0 str_76) str_76 s_77 ()+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 "--"- v1 <- many (do unexpect (string "\n")- v1 <- anyChar- return $ (v1))+ many (do unexpect (string "\n")+ anyChar+ return $ ()) string "\n"- return ())-regionComment :: forall str_78 s_79 . ListLike str_78 Char =>- Parser (MemoTable_0 str_78) str_78 s_79 ()+ 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 "{-"- v1 <- many ((do v1 <- regionComment- return $ (v1)) <|> (do unexpect (string "-}")- v1 <- anyChar- return ()))+ many ((do v1 <- regionComment+ return $ (v1)) <|> (do unexpect (string "-}")+ anyChar+ return $ ())) string "-}"- return ())+ return $ ())
Text/Peggy/Prim.hs view
@@ -1,6 +1,4 @@-{-# Language MultiParamTypeClasses #-}-{-# Language FlexibleContexts #-}-{-# Language RankNTypes #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, RankNTypes #-} -- | -- Module : Text.Peggy.Prim@@ -216,7 +214,7 @@ space = () <$ satisfy isSpace defaultDelimiter :: LL.ListLike str Char => Parser tbl str s ()-defaultDelimiter = () <$ satisfy isPunctuation+defaultDelimiter = () <$ satisfy (\c -> isPunctuation c || c == '+') getPrevChar :: LL.ListLike str Char => Parser tbl str s Char getPrevChar = Parser $ \_ pos prev str ->@@ -231,14 +229,14 @@ many sp ret <- p prev <- getPrevChar- sp <|> del <|> unexpect (satisfy $ check prev)+ sp <|> expect del <|> unexpect (satisfy $ check prev) many sp return ret where check pr cr- | isAlnum' pr && isAlnum' cr = True - | isDigit pr && isDigit cr = True- | isGlyph pr && isGlyph cr = True+ | 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
Text/Peggy/Quote.hs view
@@ -1,4 +1,4 @@-{-# Language RankNTypes #-}+{-# LANGUAGE RankNTypes #-} -- | -- Module : Text.Peggy.Quote@@ -13,11 +13,11 @@ -- module Text.Peggy.Quote (- -- * Quasi Quoters+ -- * Quasiquoter peggy, peggyFile, - -- * Parser and Quasi-quoter generating function+ -- * Parser and Quasiquoter generating function genParser, ) where @@ -117,8 +117,8 @@ -> Syntax -- ^ syntax -> Q [Dec] -- ^ definitions of parsers and quasi-quoters genParser qqs syn = do- qq <- mapM (genQQ syn) qqs- dec <- genDecs syn+ qq <- mapM (genQQ syn) qqs+ dec <- genDecs syn return $ concat qq ++ dec --
Text/Peggy/SrcLoc.hs view
@@ -1,4 +1,4 @@-{-# Language DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable #-} module Text.Peggy.SrcLoc ( SrcLoc(..),
Text/Peggy/Syntax.hs view
@@ -1,4 +1,4 @@-{-# Language DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable #-} module Text.Peggy.Syntax ( Syntax,@@ -55,6 +55,7 @@ data CodePart = Snippet String | Argument Int+ | AntiArgument Int | ArgPos | ArgSpan deriving (Show, Eq, Typeable, Data)
bootstrap/Bootstrap.hs view
@@ -1,4 +1,4 @@-{-# Language TemplateHaskell, QuasiQuotes, FlexibleContexts #-}+{-# LANGUAGE TemplateHaskell, QuasiQuotes, FlexibleContexts #-} import Data.Char import Numeric@@ -16,8 +16,8 @@ header :: String header = unlines- [ "{-# Language RankNTypes #-}"- , "{-# Language FlexibleContexts #-}"+ [ "{-# LANGUAGE RankNTypes, FlexibleContexts #-}"+ , "" , "module Text.Peggy.Parser (syntax) where" , "import Control.Applicative" , "import Data.ListLike.Base hiding (head)"
bootstrap/Stage1.hs view
@@ -1,4 +1,4 @@-{-# Language TemplateHaskell, QuasiQuotes, FlexibleContexts #-}+{-# LANGUAGE TemplateHaskell, QuasiQuotes, FlexibleContexts #-} module Stage1 where
bootstrap/Stage2.hs view
@@ -1,4 +1,4 @@-{-# Language TemplateHaskell, QuasiQuotes, FlexibleContexts #-}+{-# LANGUAGE TemplateHaskell, QuasiQuotes, FlexibleContexts #-} module Stage2 where
bootstrap/peggy.peggy view
@@ -18,8 +18,12 @@ / sequenceExpr sequenceExpr :: Expr- = (suffixExpr !"::" !"=")+ { Sequence $1 }+ = (namedExpr !"::" !"=")+ { Sequence $1 } +namedExpr :: Expr+ = ident ":" suffixExpr { Named $1 $2 }+ / suffixExpr+ suffixExpr :: Expr = suffixExpr "*" { Many $1 } / suffixExpr "+" { Some $1 }@@ -75,23 +79,24 @@ / (!'}' !argument .)+ { Snippet $1 } argument :: CodePart- = '$' digit+ { Argument $ read $1 }- / '$' 'p' { ArgPos }- / '$' 's' { ArgSpan }+ = '$$' 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 }+ident ::: String = [a-z_] [0-9a-zA-Z_]* { $1 : $2 } skip :: ()- = [ \r\n\t] { () } / comment+ = _:[ \r\n\t] / comment comment :: () = lineComment / regionComment lineComment :: ()- = '--' (!'\n' .)* '\n' { () }+ = '--' _:(!'\n' _:.)* '\n' regionComment :: ()- = '{-' (regionComment / !'-}' . { () } )* '-}' { () }+ = '{-' _:(regionComment / !'-}' _:.)* '-}'
peggy.cabal view
@@ -1,5 +1,5 @@ Name: peggy-Version: 0.2.1+Version: 0.3.0 Synopsis: The Parser Generator for Haskell Description: