packages feed

peggy (empty) → 0.1.0

raw patch · 15 files changed

+1111/−0 lines, 15 filesdep +ListLikedep +basedep +hashtablessetup-changed

Dependencies added: ListLike, base, hashtables, haskell-src-meta, monad-control, mtl, parsec, template-haskell

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2011, Hideyuki Tanaka++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Hideyuki Tanaka nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Main.hs view
@@ -0,0 +1,32 @@+{-# Language QuasiQuotes #-}+{-# Language FlexibleContexts #-}++module Main (main) where++import Text.Peggy++[peggy|+-- Simple Arithmetic Expression Parser++top :: Double = expr !.++expr :: Double+  = expr "+" fact { $1 + $2 }+  / expr "-" fact { $1 - $2 }+  / fact++fact :: Double+  = fact "*" term { $1 * $2 }+  / fact "/" term { $1 / $2 }+  / term++term :: Double+  = "(" expr ")"+  / number++number ::: Double+  = [1-9] [0-9]* { read ($1 : $2) }+|]++main :: IO ()+main = print . parse top =<< getContents
+ README.md view
@@ -0,0 +1,67 @@+# Peggy: A Parser Generator of Parsing Expression Grammer (PEG) #++# About++This is an yet another parser generator of Parsing Expression Grammer (PEG) which is:++* Simple+* Concise+* Fast+* Modern++# Usage++You can find a recent stable release in Hackage DB.+You can install this as following instruction:++    $ cabal update+    $ cabal install Peggy++# Why should you use Peggy?++Haskell has commonly used parser generators, one of them are Alex/Happy.+But I think Alex/Happy are not good in these points:++* Generates regacy codes++Alex uses only too basic libraries.+It does not use monad-transformers, iteratee, ListLike, Text, and so on.++* Tradisional Regexp/CFG based parser++Parsec has no good error recovery.++unnun, kannun...++...++# Quick Start++Here is an example of parsing arithmetic expressions.++    {-# QuasiQuotes #-}+    {-# Language FlexibleContexts #-}+    +    import Text.Peggy+    +    [peggy|+    exp :: Double+      = exp "+" fact  { $1 + $2 }+      / exp "-" fact  { $1 - $2 }+      / fact+    fact :: Double+      = fact "*" term { $1 * $2 }+      / fact "/" term { $1 / $2 }+      / term+    term :: Double+      = "(" exp ")"+      / number+    number ::: Double+      = ([1-9][0-9]*) { read $1 }+    |]+    +    main :: IO ()+    main =+      print . parse exp =<< getContents++...
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Text/Peggy.hs view
@@ -0,0 +1,9 @@+module Text.Peggy (+  module Text.Peggy.PrimST,+  module Text.Peggy.SrcLoc,+  module Text.Peggy.Quote,+  ) where++import Text.Peggy.PrimST+import Text.Peggy.SrcLoc+import Text.Peggy.Quote
+ Text/Peggy/CodeGen/TH.hs view
@@ -0,0 +1,184 @@+{-# Language TemplateHaskell #-}+{-# Language TupleSections #-}+{-# Language FlexibleContexts #-}++module Text.Peggy.CodeGen.TH (+  genCode,+  removeLeftRecursion,+  ) where++import Control.Applicative+import Control.Monad+import qualified Data.HashTable.ST.Basic as HT+import qualified Data.ListLike as LL+import Language.Haskell.Meta+import Language.Haskell.TH+import Text.Peggy.PrimST+import Text.Peggy.Syntax+import Text.Peggy.SrcLoc+import Text.Peggy.Normalize+import Text.Peggy.LeftRec++genCode :: Syntax -> Q [Dec]+genCode = generate . removeLeftRecursion . normalize++generate :: Syntax -> Q [Dec]+generate defs = do+  tblName <- newName "MemoTable"+  ps <- parsers tblName+  sequence $ [defTbl tblName, instTbl tblName] ++ ps+  where+  n = length defs+  +  defTbl tblName = do+    s <- newName "s"+    str <- newName "str"+    dataD (cxt []) tblName [PlainTV str, PlainTV s] [con s str] []+    where+      con s str = recC tblName $ 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+    str <- newName "str"+    instanceD (cxt []) (conT ''MemoTable `appT` (conT tblName `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]]++  parsers tblName = concat <$> mapM (gen tblName) defs+  +  gen tblName (Definition nont typ e) = do+    str <- newName "str"+    s <- newName "s"+    return $+      [ sigD (mkName nont) $+        forallT [PlainTV str, PlainTV s]+                (cxt [classP ''LL.ListLike [varT str, conT ''Char]]) $+        conT ''Parser `appT`+        (conT tblName `appT` varT str) `appT`+        varT str `appT`+        varT s `appT`+        parseType' typ+      , funD (mkName nont)+        [clause [] (normalB [| memo $(varE $ mkName $ "tbl_" ++ nont) $ $(genP e) |]) []]]+  +  genP e = case e of+    Terminals False False str ->+      [| string str |]+    Terminals True  False str ->+      [| many $(varE skip) *> string str |]+    Terminals False True  str ->+      [| string str <* many $(varE skip) |]+    Terminals True True  str ->+      [| many $(varE skip) *> string str <* many $(varE skip) |]++    TerminalSet rs ->+      [| satisfy $(genRanges rs) |]+    TerminalCmp rs ->+      [| satisfy $ not . $(genRanges rs) |]+    TerminalAny ->+      [| anyChar |]+    NonTerminal nont ->+      [| $(varE $ mkName nont) |]+    Primitive name ->+      [| $(varE $ mkName name) |]+    Empty ->+      [| return () |]++    Semantic (Sequence es) cf ->+      doE $ genBinds 1 es ++ [ noBindS [| return $(genCF cf) |] ]+    Semantic f cf ->+      genP (Semantic (Sequence [f]) cf)++    Sequence es -> do+      binds <- sequence $ genBinds 1 es+      let vn = length $ filter isBind binds+      doE $ do+        map return binds +++          [ noBindS [| return $ $(tupE $ map (varE .mkName  . var) [1..vn]) |] ]++    Choice es ->+      foldl1 (\a b -> [| $a <|> $b |]) $ map genP es++    Many f ->+      [| many $(genP f) |]+    Some f ->+      [| some $(genP f) |]+    Optional f ->+      [| optional $(genP f) |]+    And f ->+      [| expect $(genP f) |]+    Not f ->+      [| unexpect $(genP f) |]++    Token f ->+      [| many $(varE skip) *> $(genP f) <* many $(varE skip) |]++    -- these are removed normalized phase+    SepBy  {} -> error "internal desugar error"+    SepBy1 {} -> error "internal desugar error"++    Named {} -> error "named expr must has semantic."++    where+      skip = mkName "skip"++      genBinds _ [] = []+      genBinds ix (f:fs) = case f of+        Named name g ->+          bindS (asP (mkName name) $ varP $ mkName (var ix)) (genP g) :+          genBinds (ix+1) fs+        _ | shouldBind f ->+          bindS (varP $ mkName $ var ix) (genP f) :+          genBinds (ix+1) fs+        _ ->+          noBindS (genP f) :+          genBinds ix fs++      shouldBind f = case f of+        Terminals _ _ _ -> False+        And _ -> False+        Not _ -> False+        _ -> True++      isBind (BindS _ _) = True+      isBind _ = False+  +  genRanges rs =+    let c = mkName "c" in+    lamE [varP c] $ foldl1 (\a b -> [| $a || $b |]) $ map (genRange c) rs+  genRange c (CharRange l h) =+    [| l <= $(varE c) && $(varE c) <= h |]+  genRange c (CharOne v) =+    [| $(varE c) == v |]++  genCF cf =+    case parsed of+      Left _ ->+        error $ "code fragment parse error: " ++ scf+      Right ret ->+        return ret+    where+    parsed = parseExp scf+    scf = concatMap toStr cf+    toStr (Snippet str) = str+    toStr (Argument n)  = var n++  var n = "v" ++ show (n :: Int)++parseType' typ =+  case parseType typ of+    Left err -> error $ "type parse error :" ++ typ ++ ", " ++ err+    Right t -> case t of+      -- GHC.Unit.() is not a type name. Is it a bug of haskell-src-meta?+      -- Use (TupleT 0) insted.+      ConT con | show con == "GHC.Unit.()" ->+        return $ TupleT 0+      _ ->+        return t
+ Text/Peggy/LeftRec.hs view
@@ -0,0 +1,72 @@+module Text.Peggy.LeftRec (+  removeLeftRecursion,+  ) where++import Text.Peggy.Syntax++-- Remove only direct left recursion+-- TODO: indirect left recursion+removeLeftRecursion :: Syntax -> Syntax+removeLeftRecursion = concatMap remove where+  remove (Definition nont typ (Choice es)) | not $ null alphas =+    [ Definition nont typ $ Choice+      [ Semantic (Sequence $ beta : [NonTerminal rest]) betaFrag+      | beta <- betas+      ]+    , Definition rest ("(" ++ typ ++ ") -> (" ++ typ ++")") $ Choice $+      [ Sequence $ fs ++ [NonTerminal rest]+      | Sequence (_: fs) <- alphas+      ] +++      [ Semantic+        (Sequence $ fs ++ [NonTerminal rest])+        (alphaFrag cf $ length (filter hasSemantic fs) + 1)+      | Semantic (Sequence (_: fs)) cf <- alphas+      ] +++      [ Semantic Empty idFrag ]+    ]+    where+      rest = nont ++ "_tail"+      (alphas, betas) = span isLeftRec es+      +      idFrag =+        [ Snippet "id"+        ]+        +      betaFrag =+        [ Argument 2+        , Snippet " "+        , Argument 1+        ]+      +      alphaFrag org ano =+        [ Snippet "\\v999 -> "+        , Argument ano+        , Snippet " ( "+        ] +++        map trans org +++        [ Snippet " )" ]+      +      trans (Argument n)+        | n == 1 = Argument 999+        | otherwise = Argument (n - 1)+      trans e = e++      isLeftRec (Sequence (NonTerminal nt : _))+        = nt == nont+      isLeftRec (Semantic e _)+        = isLeftRec e+      isLeftRec (Named _ e)+        = isLeftRec e+      isLeftRec _+        = False+      +      hasSemantic (Terminals _ _ _) = False+      hasSemantic (And           _) = False+      hasSemantic (Not           _) = False+      hasSemantic _                 = True+  +  remove d@(Definition nont _ (NonTerminal nt))+    | nont == nt = error "cannot remove left recursion"+    | otherwise = [d]++  remove e = [e]
+ Text/Peggy/Normalize.hs view
@@ -0,0 +1,59 @@+module Text.Peggy.Normalize (+  normalize,+  ) where++import Text.Peggy.Syntax++normalize :: Syntax -> Syntax+normalize = map desugarDef . addSkip++addSkip :: Syntax -> Syntax+addSkip defs+  | hasSkip = defs+  | otherwise = defaultSkipImpl : defs+  where+    hasSkip = not $ null [ () | Definition nont _ _ <- defs , nont == "skip" ]+    +    defaultSkipImpl =+      Definition "skip" "()" $ Primitive "space"++desugarDef :: Definition -> Definition+desugarDef (Definition nont typ expr) =+  Definition nont typ (desugar expr)+  where+    desugar e = case e of+      Terminals {}-> e+      TerminalSet {} -> e+      TerminalCmp {} -> e+      TerminalAny {} -> e+      NonTerminal {} -> e+      Primitive {} -> e+      Empty -> e+      +      Named name f -> Named name $ desugar f+      +      Sequence es -> Sequence $ map desugar es+      Choice es -> Choice $ map desugar es+      Many f -> Many $ desugar f+      Some f -> Some $ desugar f+      Optional f -> Optional $ desugar f+      And f -> And $ desugar f+      Not f -> Not $ desugar f+      +      Semantic f cf -> Semantic (desugar f) cf+      +      SepBy f g ->+        desugar (Choice [SepBy1 f g, Semantic Empty [Snippet "[]"]])+        +      SepBy1 f g ->+        let f' = desugar f in+        let g' = desugar g in+        let g'' = Semantic g' [Snippet "()"] in+        Semantic (Sequence [f', (Many (Semantic (Sequence [g'', f']) [Argument 2]))])+        [ Argument 1+        , Snippet ":"+        , Argument 2+        ]+      +      Token f ->+        Token $ desugar f
+ Text/Peggy/Parser.hs view
@@ -0,0 +1,154 @@+module Text.Peggy.Parser (+  syntax,+  ) where++import Control.Applicative+import Data.Char+import Numeric+import Text.Parsec hiding ((<|>), many)+import Text.Parsec.String++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))
+ Text/Peggy/Prim.hs view
@@ -0,0 +1,177 @@+{-# Language GeneralizedNewtypeDeriving #-}+{-# Language MultiParamTypeClasses #-}++module Text.Peggy.Prim (+  Parser(..),+  ParseError(..),+  Result(..),+  Derivs(..),+  runParser,+  +  getPos,+  parseError,+  backtrack,+  annot,+  +  anyChar,+  satisfy,+  char,+  string,+  empty,+  (<|>),+  many,+  some,+  optional,+  expect,+  unexpect,+  +  space,+  ) where++import Control.Applicative+import Control.Monad.State+import Control.Monad.Error+import Data.Char++import Text.Peggy.SrcLoc++newtype Parser d a+  = Parser+    { -- annotation :: String+      unParser :: d -> Result d a+    }++data ParseError = ParseError SrcLoc String+  deriving (Show)++nullError :: ParseError+nullError = ParseError (LocPos (SrcPos "" 0 1 1)) ""++data Result d a+  = Parsed d a+  | Failed ParseError++instance Show a => Show (Result d a) where+  show (Parsed _ a) = "Parsed " ++ show a+  show (Failed err) = "Failed (" ++ show err ++ ")"++class Derivs d where+  dvPos  :: d -> SrcPos+  dvChar :: d -> Result d Char+  parse  :: SrcPos -> String -> d++runParser :: Derivs d => Parser d a -> String -> String -> Result d a+runParser p sourceName source =+  unParser p $ parse (SrcPos sourceName 0 1 1) source++instance Functor (Parser d) where+  fmap f (Parser p) = Parser $ \d ->+    case p d of+      Parsed e a ->+        Parsed e (f a)+      Failed err ->+        Failed err++instance Applicative (Parser d) where+  pure a = Parser $ \d -> Parsed d a+  +  Parser p <*> Parser q = Parser $ \d ->+    case p d of+      Parsed e g ->+        case q e of+          Parsed f a ->+            Parsed f (g a)+          Failed err ->+            Failed err+      Failed err ->+        Failed err++instance Monad (Parser d) where+  return = pure+  +  Parser p >>= f = Parser $ \d -> +    case p d of+      Parsed e a ->+        unParser (f a) e+      Failed err ->+        Failed err++instance Derivs d => Alternative (Parser d) where+  empty =+    Parser $ \d -> Failed (ParseError (LocPos $ dvPos d) "")+  Parser p <|> Parser q =+    Parser $ \d -> +    case p d of+      Parsed e a ->+        Parsed e a+      Failed _ ->+        q d++instance MonadError ParseError (Parser d) where+  throwError e = Parser $ \_ ->+    Failed e+  catchError (Parser p) h = Parser $ \d ->+    case p d of+      Parsed e a ->+        Parsed e a+      Failed err ->+        unParser (h err) d++--++backtrack :: Derivs d => Parser d a -> Parser d a+backtrack (Parser p) = Parser $ \d ->+  case p d of+    Parsed _ r ->+      Parsed d r+    Failed e ->+      Failed e++annot :: Derivs d => String -> Parser d a -> Parser d a+annot ann p = p -- Parser ann (unParser p)++getPos :: Derivs d => Parser d SrcPos+getPos = Parser $ \d ->+  Parsed d (dvPos d)++parseError :: Derivs d => String -> Parser d a+parseError msg = do+  pos <- getPos+  throwError $ ParseError (LocPos pos) msg++-----++anyChar :: Derivs d => Parser d Char+anyChar = Parser dvChar++satisfy :: Derivs d => (Char -> Bool) -> Parser d Char+satisfy p = do+  c <- anyChar+  when (not $ p c) $+    throwError nullError+  return c++char :: Derivs d => Char -> Parser d Char+char c = annot (show c) $+  satisfy (== c)+  `catchError` +  (const $ parseError $ "expect " ++ show c)++string :: Derivs d => String -> Parser d String+string str = annot (show str) $+  mapM char str+  `catchError`+  (const $ parseError $ "expect " ++ show str)++expect :: Derivs d => Parser d a -> Parser d ()+expect p = backtrack $ () <$ p++unexpect :: Derivs d => Parser d a -> Parser d ()+unexpect p = backtrack $ do+  b <- catchError (True <$ p) (\_ -> pure False)+  when b $ parseError $ "unexpect " -- ++ annotation p++-----++space :: Derivs d => Parser d ()+space = () <$ satisfy isSpace
+ Text/Peggy/PrimST.hs view
@@ -0,0 +1,154 @@+{-# Language MultiParamTypeClasses #-}+{-# Language FlexibleContexts #-}+{-# Language RankNTypes #-}++module Text.Peggy.PrimST (+  Parser(..),+  Result(..),+  ParseError(..),+  MemoTable(..),+  +  memo,+  parse,+  +  anyChar,+  satisfy,+  char,+  string,+  +  expect,+  unexpect,+  +  space,+  ) where++import Control.Applicative+import Control.Monad.ST+import Control.Monad.Error+import Data.Char+import Data.HashTable.ST.Basic as HT+import qualified Data.ListLike as LL++import Text.Peggy.SrcLoc++newtype Parser tbl str s a+  = Parser { unParser :: tbl s -> SrcPos -> str -> ST s (Result str a) }++data Result str a+  = Parsed SrcPos str a+  | Failed ParseError++data ParseError+  = ParseError SrcLoc String+  deriving (Show)++instance Error ParseError++nullError :: ParseError+nullError = ParseError (LocPos $ SrcPos "" 0 1 1) ""++class MemoTable tbl where+  newTable :: ST s (tbl s)++instance Monad (Parser tbl str s) where+  return v = Parser $ \_ pos s -> return $ Parsed pos s v+  p >>= f = Parser $ \tbl pos s -> do+    res <- unParser p tbl pos s+    case res of+      Parsed qos t x ->+        unParser (f x) tbl qos t+      Failed err ->+        return $ Failed err++instance Functor (Parser tbl str s) where+  fmap f p = return . f =<< p++instance Applicative (Parser tbl str s) where+  pure = return+  p <*> q = do+    f <- p+    x <- q+    return $ f x++instance MonadError ParseError (Parser tbl str s) where+  throwError err = Parser $ \_ _ _ -> return $ Failed err+  catchError p h = Parser $ \tbl pos s -> do+    res <- unParser p tbl pos s+    case res of+      Parsed {} -> return res+      Failed err -> unParser (h err) tbl pos s++instance Alternative (Parser tbl str s) where+  empty = throwError nullError+  p <|> q = catchError p (const q)++memo :: (tbl s -> HT.HashTable s Int (Result str a))+        -> Parser tbl str s a +        -> Parser tbl str s a+memo ft p = Parser $ \tbl pos@(SrcPos _ n _ _) s -> do+  cache <- HT.lookup (ft tbl) n+  case cache of+    Just v -> return v+    Nothing -> do+      v <- unParser p tbl pos s+      HT.insert (ft tbl) n v+      return v++parse :: MemoTable tbl+         => (forall s . Parser tbl str s a)+         -> str+         -> Either ParseError a+parse p str = runST $ do+  tbl <- newTable+  res <- unParser p tbl (SrcPos "<input>" 0 1 1) str+  case res of+    Parsed _ _ ret -> return $ Right ret+    Failed err -> return $ Left err++getPos :: Parser tbl str s SrcPos+getPos = Parser $ \_ pos str -> return $ Parsed pos str pos++parseError :: String -> Parser tbl str s a+parseError msg =+  throwError =<< ParseError . LocPos <$> getPos <*> pure msg++anyChar :: LL.ListLike str Char => Parser tbl str s Char+anyChar = Parser $ \_ pos str ->+  if LL.null str+  then return $ Failed nullError+  else do+    let c  = LL.head str+        cs = LL.tail str+    return $ Parsed (pos `advance` c) cs c++satisfy :: LL.ListLike str Char => (Char -> Bool) -> Parser tbl str s Char+satisfy p = do+  c <- anyChar+  when (not $ p c) $ parseError "unexpected input"+  return c++char :: LL.ListLike str Char => Char -> Parser tbl str s Char+char c = satisfy (==c) <|> parseError ("expect " ++ show c)++string :: LL.ListLike str Char => String -> Parser tbl str s String+string str = mapM char str <|> parseError ("expect " ++ show str)++expect :: LL.ListLike str Char => Parser tbl str s a -> Parser tbl str s ()+expect p = do+  b <- test p+  when (not b) $ parseError "unexpected input"++unexpect :: LL.ListLike str Char => Parser tbl str s a -> Parser tbl str s ()+unexpect p = do+  b <- test p+  when b $ parseError "unexpected input"++test :: LL.ListLike str Char => Parser tbl str s a -> Parser tbl str s Bool+test p = Parser $ \tbl pos str -> do+  res <- unParser p tbl pos str+  return $ case res of+    Parsed _ _ _ -> Parsed pos str True+    Failed _ -> Parsed pos str False++space :: LL.ListLike str Char => Parser tbl str s ()+space = () <$ satisfy isSpace
+ Text/Peggy/Quote.hs view
@@ -0,0 +1,27 @@+module Text.Peggy.Quote (+  peggy,+  peggy_f,+  ) where++import Language.Haskell.TH+import Language.Haskell.TH.Quote+import Text.Parsec+import Text.Parsec.Pos++import Text.Peggy.Parser+import Text.Peggy.CodeGen.TH++peggy :: QuasiQuoter+peggy = QuasiQuoter { quoteDec = quote, quoteExp = undefined, quotePat = undefined, quoteType = undefined }++peggy_f :: QuasiQuoter+peggy_f = quoteFile peggy++quote :: String -> Q [Dec]+quote txt = do+  loc <- location+  case parse (setPosition (initPos loc) >> syntax) (loc_filename loc) txt of+    Left err -> error $ "peggy syntax-error: " ++ show err+    Right defs -> genCode defs+  where+    initPos loc = newPos (loc_filename loc) (fst $ loc_start loc) (snd $ loc_start loc)
+ Text/Peggy/SrcLoc.hs view
@@ -0,0 +1,30 @@+module Text.Peggy.SrcLoc (+  SrcLoc(..),+  SrcPos(..),+  +  advance,+  ) where++data SrcLoc+  = LocPos  !SrcPos+  | LocSpan !SrcPos !SrcPos+  deriving (Show)++data SrcPos =+  SrcPos+  { locFile :: !FilePath+  , locAbs  :: {-# UNPACK #-} !Int+  , locLine :: {-# UNPACK #-} !Int+  , locCol  :: {-# UNPACK #-} !Int+  }+  deriving (Show)++tabWidth :: Int+tabWidth = 8++advance :: SrcPos -> Char -> SrcPos+advance (SrcPos f a l c) x =+  case x of+    '\t' -> SrcPos f (a + 1) l ((c - 1 + tabWidth - 1) `div` tabWidth * tabWidth + 1)+    '\n' -> SrcPos f (a + 1) (l + 1) 1+    _    -> SrcPos f (a + 1) l (c + 1)
+ Text/Peggy/Syntax.hs view
@@ -0,0 +1,57 @@+module Text.Peggy.Syntax (+  Syntax,+  Definition(..),+  Expr(..),+  CharRange(..),+  CodeFragment,+  CodePart(..),+  Identifier,+  HaskellType,+  ) where++type Syntax = [Definition]++data Definition+  = Definition Identifier HaskellType Expr+  deriving (Show)++data Expr+  = Terminals Bool Bool String+  | TerminalSet [CharRange]+  | TerminalCmp [CharRange]+  | TerminalAny+  | NonTerminal Identifier+  | Primitive Identifier+  | Empty+    +  | Named Identifier Expr+  +  | Sequence [Expr]+  | Choice   [Expr]+  | Many     Expr+  | Some     Expr+  | Optional Expr+  | And      Expr+  | Not      Expr+    +  | SepBy  Expr Expr+  | SepBy1 Expr Expr+  | Token  Expr+    +  | Semantic Expr CodeFragment+  deriving (Show)++data CharRange+  = CharRange Char Char+  | CharOne Char+  deriving (Show)++type CodeFragment = [CodePart]++data CodePart+  = Snippet String+  | Argument Int+  deriving (Show)++type Identifier = String+type HaskellType = String
+ peggy.cabal view
@@ -0,0 +1,57 @@+Name:                peggy+Version:             0.1.0+Synopsis:            The Parser Generator for Haskell++Description:         The Parser Generator for Haskell++Homepage:            http://github.com/tanakh/peggy+License:             BSD3+License-file:        LICENSE+Author:              Hideyuki Tanaka+Maintainer:          Hideyuki Tanaka <tanaka.hideyuki@gmail.com>+Copyright:           Copyright (c)2011, Hideyuki Tanaka+Category:            Language+Build-type:          Simple++Extra-source-files:  README.md++Cabal-version:       >=1.8++Library+  Exposed-modules:     Text.Peggy+                     , Text.Peggy.CodeGen.TH+                     , Text.Peggy.LeftRec+                     , Text.Peggy.Normalize+                     , Text.Peggy.Parser+                     , Text.Peggy.Prim+                     , Text.Peggy.PrimST+                     , Text.Peggy.Quote+                     , Text.Peggy.SrcLoc+                     , Text.Peggy.Syntax+  +  Build-depends:       base >= 4 && < 5+                     , mtl >= 2.0 && < 2.1+                     , 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+  +  -- Other-modules:       +  +Executable peggy+  Main-is:             Main.hs++  Build-depends:       base >= 4 && < 5+                     , mtl >= 2.0 && < 2.1+                     , 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++Source-repository head+  Type:              git+  Location:          git://github.com/tanakh/Peggy.git