peggy 0.1.3 → 0.2.0
raw patch · 11 files changed
+474/−179 lines, 11 filesdep −parsec
Dependencies removed: parsec
Files
- Main.hs +4/−5
- Text/Peggy/CodeGen/TH.hs +12/−9
- Text/Peggy/Parser.hs +270/−150
- Text/Peggy/Quote.hs +11/−8
- Text/Peggy/Syntax.hs +4/−4
- bootstrup/Bootstrup.hs +39/−0
- bootstrup/README.md +10/−0
- bootstrup/Stage1.hs +10/−0
- bootstrup/Stage2.hs +13/−0
- bootstrup/peggy.peggy +95/−0
- peggy.cabal +6/−3
Main.hs view
@@ -1,14 +1,13 @@-{-# Language TemplateHaskell, QuasiQuotes #-}-{-# Language FlexibleContexts #-}+{-# Language TemplateHaskell, QuasiQuotes, FlexibleContexts #-} module Main (main) where import Text.Peggy -genParser [("qqexpr", "top")] [peggy|+genParser [] [peggy| -- Simple Arithmetic Expression Parser -top :: Double = expr !.+top :: Double = expr expr :: Double = expr "+" fact { $1 + $2 }@@ -29,4 +28,4 @@ |] main :: IO ()-main = print . parse top (SrcPos "<stdin>" 0 1 1) =<< getContents+main = print . parseString top "<stdin>" =<< getContents
Text/Peggy/CodeGen/TH.hs view
@@ -45,32 +45,35 @@ generate :: Syntax -> Q [Dec] generate defs = do- tblName <- newName "MemoTable"- ps <- parsers tblName- sequence $ [defTbl tblName, instTbl tblName] ++ ps+ tblTypName <- newName "MemoTable"+ tblDatName <- newName "MemoTable"+ ps <- parsers tblTypName+ sequence $ [ defTbl tblTypName tblDatName+ , instTbl tblTypName tblDatName+ ] ++ ps where n = length defs - defTbl tblName = do+ defTbl tblTypName tblDatName = do s <- newName "s" str <- newName "str"- dataD (cxt []) tblName [PlainTV str, PlainTV s] [con s str] []+ dataD (cxt []) tblTypName [PlainTV str, PlainTV s] [con s str] [] where- con s str = recC tblName $ map toMem defs where+ con s str = recC tblDatName $ map toMem defs where toMem (Definition nont typ _) = do t <- [t| HT.HashTable $(varT s) Int (Result $(varT str) $(parseType' typ)) |] return (mkName $ "tbl_" ++nont, NotStrict, t) - instTbl tblName = do+ instTbl tblTypName tblDatName = do str <- newName "str"- instanceD (cxt []) (conT ''MemoTable `appT` (conT tblName `appT` varT 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 tblName : map varE names]]+ ++ [ noBindS $ appsE [varE 'return, appsE $ conE tblDatName : map varE names]] parsers tblName = concat <$> mapM (gen tblName) defs
Text/Peggy/Parser.hs view
@@ -1,154 +1,274 @@-module Text.Peggy.Parser (- syntax,- ) where-+{-# Language RankNTypes #-}+{-# Language FlexibleContexts #-}+module Text.Peggy.Parser (syntax) where import Control.Applicative-import Data.Char+import Data.ListLike.Base hiding (head)+import Data.HashTable.ST.Basic import Numeric-import Text.Parsec hiding ((<|>), many)-import Text.Parsec.String-+import Data.Char+import Text.Peggy.Prim import Text.Peggy.Syntax -syntax :: Parser Syntax-syntax = many definition <* skips <* eof--definition :: Parser Definition-definition =- try (Definition <$> identifier <* symbol ":::" <*> haskellType <* symbol "=" <*> (Token <$> expr)) <|>- (Definition <$> identifier <* symbol "::" <*> haskellType <* symbol "=" <*> expr)- <?> "definition"--expr :: Parser Expr-expr = choiceExpr- -choiceExpr :: Parser Expr-choiceExpr = sepBy1 semanticExpr (symbol "/") >>= \es -> case es of- [e] -> pure e- _ -> pure $ Choice es- <?> "choice expr"--semanticExpr :: Parser Expr-semanticExpr = sequenceExpr >>= \e ->- option e $- Semantic e <$> (symbol "{" *> codeFragment <* symbol "}")--sequenceExpr :: Parser Expr-sequenceExpr = some (try (namedExpr <* notFollowedBy (symbol "::" <|> symbol "="))) >>= \es -> case es of- [e] -> pure e- _ -> pure $ Sequence es--namedExpr :: Parser Expr-namedExpr =- try (Named <$> identifier <* symbol ":" <*> suffixExpr) <|>- suffixExpr--suffixExpr :: Parser Expr-suffixExpr = prefixExpr >>= go where- go e = option e (symbol "*" *> go (Many e) <|>- symbol "+" *> go (Some e) <|>- symbol "?" *> go (Optional e))--prefixExpr :: Parser Expr-prefixExpr =- (And <$ symbol "?" <*> primExpr) <|>- (Not <$ symbol "!" <*> primExpr) <|>- primExpr--primExpr :: Parser Expr-primExpr =- terminals <|>- (TerminalCmp <$> set "[^") <|>- (TerminalSet <$> set "[") <|>- (TerminalAny <$ symbol ".") <|>- (NonTerminal <$> identifier) <|>- try (SepBy <$ symbol "(" <*> expr <* symbol "," <*> expr <* symbol ")") <|>- try (SepBy1 <$ symbol "(" <*> expr <* symbol ";" <*> expr <* symbol ")") <|>- symbol "(" *> expr <* symbol ")"- <?> "primitive expression"--terminals :: Parser Expr-terminals = lexeme (do- b <- oneOf "\"\'"- s <- many charLit- e <- oneOf "\"\'"- return $ Terminals (b=='\"') (e=='\"') s)- <?> "terminals"--charLit :: Parser Char-charLit = escaped <|> noneOf "\"\'" where- escaped = char '\\' >> escChar--escChar :: Parser Char-escChar =- ('\n' <$ char 'n' ) <|>- ('\r' <$ char 'r' ) <|>- ('\t' <$ char 't' ) <|>- ('\\' <$ char '\\') <|>- ('\"' <$ char '\"') <|>- ('\'' <$ char '\'') <|>- (chr . fst . head . readHex <$ char 'x' <*> count 2 hexDigit)--set :: String -> Parser [CharRange]-set st = lexeme $ string st *> many range <* char ']'--range :: Parser CharRange-range =- try (CharRange <$> rchar <* char '-' <*> rchar) <|>- (CharOne <$> rchar)- where- rchar = escaped <|> noneOf "]"- escaped =- char '\\' >>- (escChar <|> - (']' <$ char ']') <|>- ('^' <$ char '^') <|>- ('-' <$ char '-'))--haskellType :: Parser HaskellType-haskellType = some (noneOf "=")- <?> "type signature"--codeFragment :: Parser CodeFragment-codeFragment = many codePart- <?> "code fragment"--codePart :: Parser CodePart-codePart =- try argument <|>- Snippet <$> some (try (notFollowedBy argument >> noneOf "}"))--argument :: Parser CodePart-argument = try $ Argument <$ char '$' <*> number where- number = read <$> some digit------identifier :: Parser String-identifier =- lexeme ((:) <$> startChar <*> many subsequentChar)- <?> "identifier" - where- startChar = char '_' <|> letter- subsequentChar = startChar <|> digit--symbol :: String -> Parser String-symbol s = lexeme (string s)- <?> "symbol: " ++ s--lexeme :: Parser a -> Parser a-lexeme p = try $ skips *> p--skips :: Parser ()-skips = () <$ many ((() <$ space) <|> comment)--comment :: Parser ()-comment = lineComment <|> regionComment- <?> "comment"--lineComment :: Parser ()-lineComment = () <$ try (string "--") <* manyTill anyChar (char '\n')--regionComment :: Parser ()-regionComment = () <$ try (string "{-") <* com <* string "-}" where- com = () <$ many (regionComment <|> (notFollowedBy (string "-}") <* anyChar))+data MemoTable_0 str_1 s_2+ = MemoTable_0 {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_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 HaskellType)),+ 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_3)+ where newTable = do t_4 <- new+ 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+ return (MemoTable_0 t_4 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)+syntax :: forall str_29 s_30 . ListLike str_29 Char =>+ Parser (MemoTable_0 str_29) str_29 s_30 Syntax+syntax = memo tbl_syntax $ (do v1 <- many definition+ unexpect (do v1 <- many skip+ v2 <- anyChar+ return $ (v1, v2))+ return $ (v1))+definition :: forall str_31 s_32 . ListLike str_31 Char =>+ Parser (MemoTable_0 str_31) str_31 s_32 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_33 s_34 . ListLike str_33 Char =>+ Parser (MemoTable_0 str_33) str_33 s_34 Expr+expr = memo tbl_expr $ (do v1 <- choiceExpr+ return $ (v1))+choiceExpr :: forall str_35 s_36 . ListLike str_35 Char =>+ Parser (MemoTable_0 str_35) str_35 s_36 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+ return $ ()+ return ()+ v2 <- do v1 <- semanticExpr+ return $ (v1)+ return v2)+ return (v1 : v2)) <|> (do v1 <- return ()+ return [])+ return (Choice v1))+semanticExpr :: forall str_37 s_38 . ListLike str_37 Char =>+ Parser (MemoTable_0 str_37) str_37 s_38 Expr+semanticExpr = memo tbl_semanticExpr $ ((do v1 <- sequenceExpr+ (many skip *> string "{") <* many skip+ v2 <- codeFragment+ (many skip *> string "}") <* many skip+ return (Semantic v1 v2)) <|> (do v1 <- sequenceExpr+ return $ (v1)))+sequenceExpr :: forall str_39 s_40 . ListLike str_39 Char =>+ Parser (MemoTable_0 str_39) str_39 s_40 Expr+sequenceExpr = memo tbl_sequenceExpr $ (do v1 <- some (do v1 <- suffixExpr+ unexpect ((many skip *> string "::") <* many skip)+ unexpect ((many skip *> string "=") <* many skip)+ return $ (v1))+ return (Sequence v1))+suffixExpr :: forall str_41 s_42 . ListLike str_41 Char =>+ Parser (MemoTable_0 str_41) str_41 s_42 Expr+suffixExpr = memo tbl_suffixExpr $ (do v1 <- do v1 <- prefixExpr+ return $ (v1)+ v2 <- suffixExpr_tail+ return (v2 v1))+suffixExpr_tail :: forall str_43 s_44 . ListLike str_43 Char =>+ Parser (MemoTable_0 str_43) str_43 s_44 (Expr -> Expr)+suffixExpr_tail = memo tbl_suffixExpr_tail $ ((((do (many skip *> string "*") <* many skip+ v1 <- suffixExpr_tail+ return (\v999 -> v1 (Many v999))) <|> (do (many skip *> string "+") <* many skip+ v1 <- suffixExpr_tail+ return (\v999 -> v1 (Some v999)))) <|> (do (many skip *> string "?") <* many skip+ v1 <- suffixExpr_tail+ return (\v999 -> v1 (Optional v999)))) <|> (do v1 <- return ()+ return id))+prefixExpr :: forall str_45 s_46 . ListLike str_45 Char =>+ Parser (MemoTable_0 str_45) str_45 s_46 Expr+prefixExpr = memo tbl_prefixExpr $ (((do (many skip *> string "&") <* many skip+ v1 <- primExpr+ return (And v1)) <|> (do (many skip *> string "!") <* many skip+ v1 <- primExpr+ return (Not v1))) <|> (do v1 <- primExpr+ return $ (v1)))+primExpr :: forall str_47 s_48 . ListLike str_47 Char =>+ Parser (MemoTable_0 str_47) str_47 s_48 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_49 s_50 . ListLike str_49 Char =>+ Parser (MemoTable_0 str_49) str_49 s_50 Char+charLit = memo tbl_charLit $ ((do string "\\"+ v1 <- escChar+ return $ (v1)) <|> (do unexpect (satisfy (\c -> (c == '\'') || (c == '"')))+ v1 <- anyChar+ return $ (v1)))+escChar :: forall str_51 s_52 . ListLike str_51 Char =>+ Parser (MemoTable_0 str_51) str_51 s_52 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_53 s_54 . ListLike str_53 Char =>+ Parser (MemoTable_0 str_53) str_53 s_54 CharRange+range = memo tbl_range $ ((do v1 <- rchar+ string "-"+ v2 <- rchar+ return (CharRange v1 v2)) <|> (do v1 <- rchar+ return (CharOne v1)))+rchar :: forall str_55 s_56 . ListLike str_55 Char =>+ Parser (MemoTable_0 str_55) str_55 s_56 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_57 s_58 . ListLike str_57 Char =>+ Parser (MemoTable_0 str_57) str_57 s_58 HaskellType+haskellType = memo tbl_haskellType $ (do v1 <- some (satisfy $ (not . (\c -> c == '=')))+ return $ (v1))+codeFragment :: forall str_59 s_60 . ListLike str_59 Char =>+ Parser (MemoTable_0 str_59) str_59 s_60 CodeFragment+codeFragment = memo tbl_codeFragment $ (do v1 <- many codePart+ return $ (v1))+codePart :: forall str_61 s_62 . ListLike str_61 Char =>+ Parser (MemoTable_0 str_61) str_61 s_62 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_63 s_64 . ListLike str_63 Char =>+ Parser (MemoTable_0 str_63) str_63 s_64 CodePart+argument = memo tbl_argument $ (do string "$"+ v1 <- some digit+ return (Argument $ read v1))+digit :: forall str_65 s_66 . ListLike str_65 Char =>+ Parser (MemoTable_0 str_65) str_65 s_66 Char+digit = memo tbl_digit $ (do v1 <- satisfy (\c -> ('0' <= c) && (c <= '9'))+ return $ (v1))+hexDigit :: forall str_67 s_68 . ListLike str_67 Char =>+ Parser (MemoTable_0 str_67) str_67 s_68 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_69 s_70 . ListLike str_69 Char =>+ Parser (MemoTable_0 str_69) str_69 s_70 String+ident = memo tbl_ident $ ((many skip *> (do v1 <- satisfy (\c -> ((('a' <= c) && (c <= 'z')) || (('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))) <* many skip)+skip :: forall str_71 s_72 . ListLike str_71 Char =>+ Parser (MemoTable_0 str_71) str_71 s_72 ()+skip = memo tbl_skip $ ((do v1 <- satisfy (\c -> (((c == ' ') || (c == '\r')) || (c == '\n')) || (c == '\t'))+ return ()) <|> (do v1 <- comment+ return $ (v1)))+comment :: forall str_73 s_74 . ListLike str_73 Char =>+ Parser (MemoTable_0 str_73) str_73 s_74 ()+comment = memo tbl_comment $ ((do v1 <- lineComment+ return $ (v1)) <|> (do v1 <- regionComment+ return $ (v1)))+lineComment :: forall str_75 s_76 . ListLike str_75 Char =>+ Parser (MemoTable_0 str_75) str_75 s_76 ()+lineComment = memo tbl_lineComment $ (do string "--"+ v1 <- many (do unexpect (string "\n")+ v1 <- anyChar+ return $ (v1))+ string "\n"+ return ())+regionComment :: forall str_77 s_78 . ListLike str_77 Char =>+ Parser (MemoTable_0 str_77) str_77 s_78 ()+regionComment = memo tbl_regionComment $ (do string "{-"+ v1 <- many ((do v1 <- regionComment+ return $ (v1)) <|> (do unexpect (string "-}")+ v1 <- anyChar+ return ()))+ string "-}"+ return ())
Text/Peggy/Quote.hs view
@@ -9,10 +9,9 @@ import Language.Haskell.TH import Language.Haskell.TH.Quote-import Text.Parsec-import Text.Parsec.Pos import Text.Peggy.Parser+import Text.Peggy.Prim import Text.Peggy.Syntax import Text.Peggy.SrcLoc import Text.Peggy.CodeGen.TH@@ -22,20 +21,20 @@ peggyFile :: FilePath -> Q Exp peggyFile filename = do- txt <- runIO $ readFile filename- case parse syntax filename txt of+ 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 (SrcPos (loc_filename loc) 0 (fst $ loc_start loc) (snd $ loc_start loc)) txt+ genDecs $ parseSyntax (locToPos loc) txt qExp :: String -> Q Exp qExp txt = do loc <- location- dataToExpQ (const Nothing) $ parseSyntax (SrcPos (loc_filename loc) 0 (fst $ loc_start loc) (snd $ loc_start loc)) txt+ dataToExpQ (const Nothing) $ parseSyntax (locToPos loc) txt genParser :: [(String, String)] -> Syntax -> Q [Dec] genParser qqs syn = do@@ -46,7 +45,11 @@ -- parseSyntax :: SrcPos -> String -> Syntax-parseSyntax (SrcPos fname _ lno cno) txt =- case parse (setPosition (newPos fname lno cno) >> syntax) fname txt of+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/Syntax.hs view
@@ -17,7 +17,7 @@ data Definition = Definition Identifier HaskellType Expr- deriving (Show, Typeable, Data)+ deriving (Show, Eq, Typeable, Data) data Expr = Terminals Bool Bool String@@ -43,19 +43,19 @@ | Token Expr | Semantic Expr CodeFragment- deriving (Show, Typeable, Data)+ deriving (Show, Eq, Typeable, Data) data CharRange = CharRange Char Char | CharOne Char- deriving (Show, Typeable, Data)+ deriving (Show, Eq, Typeable, Data) type CodeFragment = [CodePart] data CodePart = Snippet String | Argument Int- deriving (Show, Typeable, Data)+ deriving (Show, Eq, Typeable, Data) type Identifier = String type HaskellType = String
+ bootstrup/Bootstrup.hs view
@@ -0,0 +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 #-}"+ , "{-# Language 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
+ bootstrup/README.md view
@@ -0,0 +1,10 @@+# Bootstrup Instructions #++# Pre-requirement++Previous version of peggy (>= 0.1.3) required.++# Bootstrup++ $ cd bootstrup+ $ runhaskell Bootstrup.hs > ../Text/Peggy/Parser.hs
+ bootstrup/Stage1.hs view
@@ -0,0 +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")
+ bootstrup/Stage2.hs view
@@ -0,0 +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)
+ bootstrup/peggy.peggy view
@@ -0,0 +1,95 @@+-- 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+ = (suffixExpr !"::" !"=")+ { Sequence $1 }++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 :: HaskellType+ = [^=]+++codeFragment :: CodeFragment+ = codePart*++codePart :: CodePart+ = argument+ / (!'}' !argument .)+ { Snippet $1 }++argument :: CodePart+ = '$' digit+ { Argument $ read $1 }++digit :: Char = [0-9] +hexDigit :: Char = [0-9a-fA-F]++ident ::: String = [a-zA-Z_] [0-9a-zA-Z_]* { $1 : $2 }++skip :: ()+ = [ \r\n\t] { () } / comment++comment :: ()+ = lineComment / regionComment++lineComment :: ()+ = '--' (!'\n' .)* '\n' { () }++regionComment :: ()+ = '{-' (regionComment / !'-}' . { () } )* '-}' { () }
peggy.cabal view
@@ -1,5 +1,5 @@ Name: peggy-Version: 0.1.3+Version: 0.2.0 Synopsis: The Parser Generator for Haskell Description: The Parser Generator for Haskell@@ -14,6 +14,11 @@ Build-type: Simple Extra-source-files: README.md+ bootstrup/README.md+ bootstrup/Stage1.hs+ bootstrup/Stage2.hs+ bootstrup/Bootstrup.hs+ bootstrup/peggy.peggy Cabal-version: >=1.8 @@ -33,7 +38,6 @@ , ListLike >= 3.1 && < 3.2 , hashtables >= 1.0 && < 1.1 , monad-control >= 0.2 && < 0.3- , parsec >= 3.1 && < 3.2 , template-haskell >= 2.5 && < 2.7 , haskell-src-meta >= 0.5 && < 0.6 @@ -47,7 +51,6 @@ , ListLike >= 3.1 && < 3.2 , hashtables >= 1.0 && < 1.1 , monad-control >= 0.2 && < 0.3- , parsec >= 3.1 && < 3.2 , template-haskell >= 2.5 && < 2.7 , haskell-src-meta >= 0.5 && < 0.6