diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -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 "" 0 1 1) =<< getContents +main = print . parseString top "" =<< 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 @@ -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 diff --git a/Text/Peggy/Parser.hs b/Text/Peggy/Parser.hs --- a/Text/Peggy/Parser.hs +++ b/Text/Peggy/Parser.hs @@ -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 ()) diff --git a/Text/Peggy/Quote.hs b/Text/Peggy/Quote.hs --- a/Text/Peggy/Quote.hs +++ b/Text/Peggy/Quote.hs @@ -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) diff --git a/Text/Peggy/Syntax.hs b/Text/Peggy/Syntax.hs --- a/Text/Peggy/Syntax.hs +++ b/Text/Peggy/Syntax.hs @@ -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 diff --git a/bootstrup/Bootstrup.hs b/bootstrup/Bootstrup.hs new file mode 100644 --- /dev/null +++ b/bootstrup/Bootstrup.hs @@ -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 diff --git a/bootstrup/README.md b/bootstrup/README.md new file mode 100644 --- /dev/null +++ b/bootstrup/README.md @@ -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 diff --git a/bootstrup/Stage1.hs b/bootstrup/Stage1.hs new file mode 100644 --- /dev/null +++ b/bootstrup/Stage1.hs @@ -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") diff --git a/bootstrup/Stage2.hs b/bootstrup/Stage2.hs new file mode 100644 --- /dev/null +++ b/bootstrup/Stage2.hs @@ -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) diff --git a/bootstrup/peggy.peggy b/bootstrup/peggy.peggy new file mode 100644 --- /dev/null +++ b/bootstrup/peggy.peggy @@ -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 / !'-}' . { () } )* '-}' { () } diff --git a/peggy.cabal b/peggy.cabal --- a/peggy.cabal +++ b/peggy.cabal @@ -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