Permalink
Browse files

Merge branch 'bootstrup'

  • Loading branch information...
tanakh committed Sep 25, 2011
2 parents 61cc653 + 8d56d12 commit 4def43b15a8cf41367f20ca7f8e74a1b9058f835
Showing with 456 additions and 167 deletions.
  1. +4 −5 Main.hs
  2. +270 −150 Text/Peggy/Parser.hs
  3. +11 −8 Text/Peggy/Quote.hs
  4. +4 −4 Text/Peggy/Syntax.hs
  5. +39 −0 bootstrup/Bootstrup.hs
  6. +10 −0 bootstrup/README.md
  7. +10 −0 bootstrup/Stage1.hs
  8. +13 −0 bootstrup/Stage2.hs
  9. +95 −0 bootstrup/peggy.peggy
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 @@ number ::: Double
|]
main :: IO ()
-main = print . parse top (SrcPos "<stdin>" 0 1 1) =<< getContents
+main = print . parseString top "<stdin>" =<< getContents
View

Large diffs are not rendered by default.

Oops, something went wrong.
View
@@ -9,10 +9,9 @@ module Text.Peggy.Quote (
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 @@ peggy = QuasiQuoter { quoteDec = qDecs, quoteExp = qExp, quotePat = undefined, q
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 @@ genParser qqs syn = do
--
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)
View
@@ -17,7 +17,7 @@ type Syntax = [Definition]
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 @@ data Expr
| 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
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
View
@@ -0,0 +1,10 @@
+# Bootstrup Instructions #
+
+# Pre-requirement
+
+Previous version of peggy (>= 0.1.1) required.
+
+# Bootstrup
+
+ $ cd bootstrup
+ $ runhaskell Bootstrup.hs > ../Text/Peggy/Parser.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")
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)
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 / !'-}' . { () } )* '-}' { () }

0 comments on commit 4def43b

Please sign in to comment.