Merge branch 'bootstrup'

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 @@ number ::: Double
 |]
 
 main :: IO ()
-main = print . parse top (SrcPos "<stdin>" 0 1 1) =<< getContents
+main = print . parseString top "<stdin>" =<< getContents

Text/Peggy/Quote.hs

@@ -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)

Text/Peggy/Syntax.hs

@@ -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

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

bootstrup/README.md

@@ -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

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")

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)

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 / !'-}' . { () } )* '-}' { () }