diff --git a/Text/Peggy/Parser.hs b/Text/Peggy/Parser.hs --- a/Text/Peggy/Parser.hs +++ b/Text/Peggy/Parser.hs @@ -10,7 +10,7 @@ import Text.Peggy.Syntax data MemoTable_0 str_1 s_2 - = MemoTable_0 {tbl_syntax :: (HashTable s_2 + = MemoTable_3 {tbl_syntax :: (HashTable s_2 Int (Result str_1 Syntax)), tbl_definition :: (HashTable s_2 Int (Result str_1 Definition)), @@ -28,7 +28,7 @@ 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_haskellType :: (HashTable s_2 Int (Result str_1 TermType)), tbl_codeFragment :: (HashTable s_2 Int (Result str_1 CodeFragment)), @@ -41,9 +41,8 @@ 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 +instance MemoTable (MemoTable_0 str_4) + where newTable = do t_5 <- new t_6 <- new t_7 <- new t_8 <- new @@ -67,16 +66,17 @@ 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 + 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 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 :: 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 @@ -88,12 +88,12 @@ (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 :: forall str_34 s_35 . ListLike str_34 Char => + Parser (MemoTable_0 str_34) str_34 s_35 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 :: forall str_36 s_37 . ListLike str_36 Char => + Parser (MemoTable_0 str_36) str_36 s_37 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 @@ -105,29 +105,29 @@ 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 :: forall str_38 s_39 . ListLike str_38 Char => + Parser (MemoTable_0 str_38) str_38 s_39 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 :: 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) 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 :: forall str_42 s_43 . ListLike str_42 Char => + Parser (MemoTable_0 str_42) str_42 s_43 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 :: 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 v1 <- suffixExpr_tail return (\v999 -> v1 (Many v999))) <|> (do (many skip *> string "+") <* many skip @@ -136,16 +136,16 @@ 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 :: 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 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 :: 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 "\"" @@ -174,15 +174,15 @@ 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 :: forall str_50 s_51 . ListLike str_50 Char => + Parser (MemoTable_0 str_50) str_50 s_51 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 :: forall str_52 s_53 . ListLike str_52 Char => + Parser (MemoTable_0 str_52) str_52 s_53 Char escChar = memo tbl_escChar $ (((((((do string "n" return '\n') <|> (do string "r" return '\r')) <|> (do string "t" @@ -194,15 +194,15 @@ 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 :: forall str_54 s_55 . ListLike str_54 Char => + Parser (MemoTable_0 str_54) str_54 s_55 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 :: forall str_56 s_57 . ListLike str_56 Char => + Parser (MemoTable_0 str_56) str_56 s_57 Char rchar = memo tbl_rchar $ ((((((do string "\\" v1 <- escChar return $ (v1)) <|> (do string "\\]" @@ -211,60 +211,60 @@ 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 :: forall str_58 s_59 . ListLike str_58 Char => + Parser (MemoTable_0 str_58) str_58 s_59 TermType 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 :: forall str_60 s_61 . ListLike str_60 Char => + Parser (MemoTable_0 str_60) str_60 s_61 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 :: forall str_62 s_63 . ListLike str_62 Char => + Parser (MemoTable_0 str_62) str_62 s_63 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 :: 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)) -digit :: forall str_65 s_66 . ListLike str_65 Char => - Parser (MemoTable_0 str_65) str_65 s_66 Char +digit :: forall str_66 s_67 . ListLike str_66 Char => + Parser (MemoTable_0 str_66) str_66 s_67 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 :: forall str_68 s_69 . ListLike str_68 Char => + Parser (MemoTable_0 str_68) str_68 s_69 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 == '_')) +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_71 s_72 . ListLike str_71 Char => - Parser (MemoTable_0 str_71) str_71 s_72 () +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_73 s_74 . ListLike str_73 Char => - Parser (MemoTable_0 str_73) str_73 s_74 () +comment :: forall str_74 s_75 . ListLike str_74 Char => + Parser (MemoTable_0 str_74) str_74 s_75 () 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 :: forall str_76 s_77 . ListLike str_76 Char => + Parser (MemoTable_0 str_76) str_76 s_77 () 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 :: forall str_78 s_79 . ListLike str_78 Char => + Parser (MemoTable_0 str_78) str_78 s_79 () regionComment = memo tbl_regionComment $ (do string "{-" v1 <- many ((do v1 <- regionComment return $ (v1)) <|> (do unexpect (string "-}") diff --git a/Text/Peggy/Prim.hs b/Text/Peggy/Prim.hs --- a/Text/Peggy/Prim.hs +++ b/Text/Peggy/Prim.hs @@ -2,21 +2,42 @@ {-# Language FlexibleContexts #-} {-# Language RankNTypes #-} +-- | +-- Module : Text.Peggy.Prim +-- Copyright : (c) Hideyuki Tanaka 2011 +-- License : BSD-style +-- +-- Maintainer : tanaka.hideyuki@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- The monadic parser type and combinators to construct +-- packrat parsers for code generator. +-- + module Text.Peggy.Prim ( + -- * Parsing functions + parse, + parseString, + parseFile, + + -- * The parser type Parser(..), + -- * The (internal) result type Result(..), + -- * The error type ParseError(..), + -- * The cache type MemoTable(..), - parse, - parseString, - parseFile, - + -- * Memoising combinator memo, + -- * Position functions getPos, setPos, + -- * Combinators anyChar, satisfy, char, @@ -25,6 +46,7 @@ expect, unexpect, + -- * Utiligy space, ) where @@ -37,6 +59,38 @@ import Text.Peggy.SrcLoc +-- | Parsing function +parse :: MemoTable tbl + => (forall s . Parser tbl str s a) -- ^ parser + -> SrcPos -- ^ input information + -> str -- ^ input string + -> Either ParseError a -- ^ result +parse p pos str = runST $ do + tbl <- newTable + res <- unParser p tbl pos str + case res of + Parsed _ _ ret -> return $ Right ret + Failed err -> return $ Left err + +-- | Parsing function with only input name +parseString :: MemoTable tbl + => (forall s . Parser tbl str s a) -- ^ parser + -> String -- ^ input name + -> str -- ^ input string + -> Either ParseError a -- ^ result +parseString p inputName str = + parse p (SrcPos inputName 0 1 1) str + +-- | Parse from file +parseFile :: MemoTable tbl + => (forall s . Parser tbl String s a) -- ^ parser + -> FilePath -- ^ input filename + -> IO (Either ParseError a) -- ^ result +parseFile p fp = + parse p (SrcPos fp 0 1 1) <$> readFile fp + +-- + newtype Parser tbl str s a = Parser { unParser :: tbl s -> SrcPos -> str -> ST s (Result str a) } @@ -107,33 +161,6 @@ v <- unParser p tbl pos s HT.insert (ft tbl) n v return v - -parse :: MemoTable tbl - => (forall s . Parser tbl str s a) - -> SrcPos - -> str - -> Either ParseError a -parse p pos str = runST $ do - tbl <- newTable - res <- unParser p tbl pos str - case res of - Parsed _ _ ret -> return $ Right ret - Failed err -> return $ Left err - -parseString :: MemoTable tbl - => (forall s . Parser tbl str s a) - -> String - -> str - -> Either ParseError a -parseString p inputName str = - parse p (SrcPos inputName 0 1 1) str - -parseFile :: MemoTable tbl - => (forall s . Parser tbl String s a) - -> FilePath - -> IO (Either ParseError a) -parseFile p fp = - parse p (SrcPos fp 0 1 1) <$> readFile fp getPos :: Parser tbl str s SrcPos getPos = Parser $ \_ pos str -> return $ Parsed pos str pos diff --git a/Text/Peggy/Quote.hs b/Text/Peggy/Quote.hs --- a/Text/Peggy/Quote.hs +++ b/Text/Peggy/Quote.hs @@ -1,9 +1,23 @@ {-# Language RankNTypes #-} +-- | +-- Module : Text.Peggy.Quote +-- Copyright : (c) Hideyuki Tanaka 2011 +-- License : BSD-style +-- +-- Maintainer : tanaka.hideyuki@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- The quasi-quoters of peggy syntax. +-- + module Text.Peggy.Quote ( + -- * Quasi Quoters peggy, peggyFile, + -- * Parser and Quasi-quoter generating function genParser, ) where @@ -16,9 +30,52 @@ import Text.Peggy.SrcLoc import Text.Peggy.CodeGen.TH +-- | quasi-quoter for peggy syntax +-- When it is used at top-level of source code, +-- definitions of parsers are generated. +-- +-- > {-# LANGUAGE TemplateHaskell, QuasiQuotes, FlexibleContexts #-} +-- > import Text.Peggy +-- > +-- > [peggy| +-- > foo :: [Int] +-- > = num* +-- > num ::: Int +-- > = [0-9]+ { read $1 } +-- > |] +-- > +-- > main :: IO () +-- > main = print . parseString foo "" =<< getContents +-- +-- When it is used as expression, +-- the result value is 'Syntax'. +-- +-- > main = print [peggy| +-- > num :: Int +-- > = [0-9]+ { read $1 } +-- > |] +-- +-- The result is: +-- +-- > $ runhaskell Test.hs +-- > [Definition "num" "Int\n " (Choice [Semantic (Sequence [Some (TerminalSet [CharRange '0' '9'])]) [Snippet "read ",Argument 1,Snippet " "]])] +-- peggy :: QuasiQuoter peggy = QuasiQuoter { quoteDec = qDecs, quoteExp = qExp, quotePat = undefined, quoteType = undefined } +-- | Parse peggy syntax from File +-- Parse a peggy syntax file and return a 'Syntax' as a result value. +-- +-- > $ cat test.peggy +-- > num :: Int +-- > = [0-9]+ { return $1 } +-- +-- > main = print $(peggyFile "test.peggy") +-- +-- The result is: +-- +-- > [Definition "num" "Int\n " (Choice [Semantic (Sequence [Some (TerminalSet [CharRange '0' '9'])]) [Snippet "read ",Argument 1,Snippet " "]])] +-- peggyFile :: FilePath -> Q Exp peggyFile filename = do res <- runIO $ parseFile syntax filename @@ -36,7 +93,29 @@ loc <- location dataToExpQ (const Nothing) $ parseSyntax (locToPos loc) txt -genParser :: [(String, String)] -> Syntax -> Q [Dec] +-- | Generates parsers and quasi-quoters. +-- First argument is a list of names of quasi-quoter you want to define. +-- For example: +-- +-- > genParser [("fooqq", "foo")] [peggy| +-- > foo :: [Int] +-- > = num* +-- > num ::: Int +-- > = [0-9]+ { read $1 } +-- > |] +-- +-- this code defines parsers named 'foo', 'num' and +-- quasi-quoter named 'fooqq'. +-- +-- It can use it as follow: +-- +-- > main :: IO () +-- > main = print [fooqq| 1 2 3 4 5 |] +-- +genParser :: [(String, String)] -- ^ a list of pair of name of + -- quasi-quoter and its start nonterminal + -> Syntax -- ^ syntax + -> Q [Dec] -- ^ definitions of parsers and quasi-quoters genParser qqs syn = do qq <- mapM (genQQ syn) qqs dec <- genDecs syn diff --git a/Text/Peggy/Syntax.hs b/Text/Peggy/Syntax.hs --- a/Text/Peggy/Syntax.hs +++ b/Text/Peggy/Syntax.hs @@ -8,7 +8,7 @@ CodeFragment, CodePart(..), Identifier, - HaskellType, + TermType, ) where import Data.Data @@ -16,7 +16,7 @@ type Syntax = [Definition] data Definition - = Definition Identifier HaskellType Expr + = Definition Identifier TermType Expr deriving (Show, Eq, Typeable, Data) data Expr @@ -58,4 +58,4 @@ deriving (Show, Eq, Typeable, Data) type Identifier = String -type HaskellType = String +type TermType = String diff --git a/bootstrap/Bootstrap.hs b/bootstrap/Bootstrap.hs new file mode 100644 --- /dev/null +++ b/bootstrap/Bootstrap.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/bootstrap/README.md b/bootstrap/README.md new file mode 100644 --- /dev/null +++ b/bootstrap/README.md @@ -0,0 +1,10 @@ +# Bootstrap Instructions # + +# Pre-requirement + +Previous version of peggy (>= 0.1.3) required. + +# Bootstrap + + $ cd bootstrap + $ runhaskell Bootstrap.hs > ../Text/Peggy/Parser.hs diff --git a/bootstrap/Stage1.hs b/bootstrap/Stage1.hs new file mode 100644 --- /dev/null +++ b/bootstrap/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/bootstrap/Stage2.hs b/bootstrap/Stage2.hs new file mode 100644 --- /dev/null +++ b/bootstrap/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/bootstrap/peggy.peggy b/bootstrap/peggy.peggy new file mode 100644 --- /dev/null +++ b/bootstrap/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 :: TermType + = [^=]+ + +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-z] [0-9a-zA-Z_]* { $1 : $2 } + +skip :: () + = [ \r\n\t] { () } / comment + +comment :: () + = lineComment / regionComment + +lineComment :: () + = '--' (!'\n' .)* '\n' { () } + +regionComment :: () + = '{-' (regionComment / !'-}' . { () } )* '-}' { () } diff --git a/bootstrup/Bootstrup.hs b/bootstrup/Bootstrup.hs deleted file mode 100644 --- a/bootstrup/Bootstrup.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/bootstrup/README.md +++ /dev/null @@ -1,10 +0,0 @@ -# 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 deleted file mode 100644 --- a/bootstrup/Stage1.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/bootstrup/Stage2.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/bootstrup/peggy.peggy +++ /dev/null @@ -1,95 +0,0 @@ --- 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,10 +1,14 @@ Name: peggy -Version: 0.2.0 +Version: 0.2.0.1 Synopsis: The Parser Generator for Haskell -Description: The Parser Generator for Haskell +Description: -Homepage: http://github.com/tanakh/peggy + The Parser Generator for Haskell + + + +Homepage: http://tanakh.github.com/Peggy License: BSD3 License-file: LICENSE Author: Hideyuki Tanaka @@ -14,11 +18,11 @@ Build-type: Simple Extra-source-files: README.md - bootstrup/README.md - bootstrup/Stage1.hs - bootstrup/Stage2.hs - bootstrup/Bootstrup.hs - bootstrup/peggy.peggy + bootstrap/README.md + bootstrap/Stage1.hs + bootstrap/Stage2.hs + bootstrap/Bootstrap.hs + bootstrap/peggy.peggy Cabal-version: >=1.8