diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -1,4 +1,4 @@ -{-# Language TemplateHaskell, QuasiQuotes, FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell, QuasiQuotes, FlexibleContexts #-} module Main (main) where diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 +~~~ diff --git a/Text/Peggy/CodeGen/TH.hs b/Text/Peggy/CodeGen/TH.hs --- a/Text/Peggy/CodeGen/TH.hs +++ b/Text/Peggy/CodeGen/TH.hs @@ -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 diff --git a/Text/Peggy/Normalize.hs b/Text/Peggy/Normalize.hs --- a/Text/Peggy/Normalize.hs +++ b/Text/Peggy/Normalize.hs @@ -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 diff --git a/Text/Peggy/Parser.hs b/Text/Peggy/Parser.hs --- a/Text/Peggy/Parser.hs +++ b/Text/Peggy/Parser.hs @@ -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 $ ()) diff --git a/Text/Peggy/Prim.hs b/Text/Peggy/Prim.hs --- a/Text/Peggy/Prim.hs +++ b/Text/Peggy/Prim.hs @@ -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 diff --git a/Text/Peggy/Quote.hs b/Text/Peggy/Quote.hs --- a/Text/Peggy/Quote.hs +++ b/Text/Peggy/Quote.hs @@ -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 -- diff --git a/Text/Peggy/SrcLoc.hs b/Text/Peggy/SrcLoc.hs --- a/Text/Peggy/SrcLoc.hs +++ b/Text/Peggy/SrcLoc.hs @@ -1,4 +1,4 @@ -{-# Language DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable #-} module Text.Peggy.SrcLoc ( SrcLoc(..), diff --git a/Text/Peggy/Syntax.hs b/Text/Peggy/Syntax.hs --- a/Text/Peggy/Syntax.hs +++ b/Text/Peggy/Syntax.hs @@ -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) diff --git a/bootstrap/Bootstrap.hs b/bootstrap/Bootstrap.hs --- a/bootstrap/Bootstrap.hs +++ b/bootstrap/Bootstrap.hs @@ -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)" diff --git a/bootstrap/Stage1.hs b/bootstrap/Stage1.hs --- a/bootstrap/Stage1.hs +++ b/bootstrap/Stage1.hs @@ -1,4 +1,4 @@ -{-# Language TemplateHaskell, QuasiQuotes, FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell, QuasiQuotes, FlexibleContexts #-} module Stage1 where diff --git a/bootstrap/Stage2.hs b/bootstrap/Stage2.hs --- a/bootstrap/Stage2.hs +++ b/bootstrap/Stage2.hs @@ -1,4 +1,4 @@ -{-# Language TemplateHaskell, QuasiQuotes, FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell, QuasiQuotes, FlexibleContexts #-} module Stage2 where diff --git a/bootstrap/peggy.peggy b/bootstrap/peggy.peggy --- a/bootstrap/peggy.peggy +++ b/bootstrap/peggy.peggy @@ -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 / !'-}' _:.)* '-}' diff --git a/peggy.cabal b/peggy.cabal --- a/peggy.cabal +++ b/peggy.cabal @@ -1,5 +1,5 @@ Name: peggy -Version: 0.2.1 +Version: 0.3.0 Synopsis: The Parser Generator for Haskell Description: