peggy 0.2.0.1 → 0.2.1

raw patch · 8 files changed

+97/−43 lines, 8 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Text/Peggy/CodeGen/TH.hs +17/−9
• Text/Peggy/Normalize.hs +12/−6
• Text/Peggy/Parser.hs +7/−3
• Text/Peggy/Prim.hs +55/−23
• Text/Peggy/Syntax.hs +2/−0
• bootstrap/README.md +1/−1
• bootstrap/peggy.peggy +2/−0
• peggy.cabal +1/−1

@@ -95,12 +95,8 @@   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) |]+      genP (Token (Terminals False False str))      TerminalSet rs ->       [| satisfy $(genRanges rs) |]@@ -115,8 +111,12 @@     Empty ->       [| return () |] -    Semantic (Sequence es) cf ->-      doE $ genBinds 1 es ++ [ noBindS [| return $(genCF cf) |] ]+    Semantic (Sequence es) cf -> do+      let needSt = hasPos cf || hasSpan cf+          needEd = hasSpan cf+          st = if needSt then [bindS (varP $ mkName stName) [| getPos |]] else []+          ed = if needEd then [bindS (varP $ mkName edName) [| getPos |]] else []+      doE $ st ++ genBinds 1 es ++ ed ++ [ noBindS [| return $(genCF cf) |] ]     Semantic f cf ->       genP (Semantic (Sequence [f]) cf) @@ -142,7 +142,7 @@       [| unexpect $(genP f) |]      Token f ->-      [| many $(varE skip) *> $(genP f) <* many $(varE skip) |]+      [| token $(varE skip) $(varE delimiter) ( $(genP f) ) |]      -- these are removed normalized phase     SepBy  {} -> error "internal desugar error"@@ -152,6 +152,7 @@      where       skip = mkName "skip"+      delimiter = mkName "delimiter"        genBinds _ [] = []       genBinds ix (f:fs) = case f of@@ -192,9 +193,16 @@     parsed = parseExp scf     scf = concatMap toStr cf     toStr (Snippet str) = str-    toStr (Argument n)  = var n+    toStr (Argument a)  = var a+    toStr ArgPos = "(LocPos " ++ stName ++ ")"+    toStr ArgSpan = "(LocSpan " ++ stName ++ " " ++ edName ++ ")" +  hasPos  = any (==ArgPos)+  hasSpan = any (==ArgSpan)+   var n = "v" ++ show (n :: Int)+  stName = "st_Pos"+  edName = "ed_Pos"  parseType' typ =   case parseType typ of

@@ -5,24 +5,30 @@ import Text.Peggy.Syntax  normalize :: Syntax -> Syntax-normalize = map desugarDef . addSkip+normalize = map desugarDef . addSkipDelim -addSkip :: Syntax -> Syntax-addSkip defs-  | hasSkip = defs-  | otherwise = defaultSkipImpl : defs+addSkipDelim :: Syntax -> Syntax+addSkipDelim defs = skp ++ dlm ++ defs   where+    skp | hasSkip = []+        | otherwise = [defaultSkipImpl]+    dlm | hasDelim = []+        | otherwise = [defaultDelimImpl]+     hasSkip = not $ null [ () | Definition nont _ _ <- defs , nont == "skip" ]+    hasDelim = not $ null [ () | Definition nont _ _ <- defs , nont == "delimiter" ]          defaultSkipImpl =       Definition "skip" "()" $ Primitive "space"+    defaultDelimImpl =+      Definition "delimiter" "()" $ Primitive "defaultDelimiter"  desugarDef :: Definition -> Definition desugarDef (Definition nont typ expr) =   Definition nont typ (desugar expr)   where     desugar e = case e of-      Terminals {}-> e+      Terminals {} -> e       TerminalSet {} -> e       TerminalCmp {} -> e       TerminalAny {} -> e

@@ -229,9 +229,13 @@                                                            return (Snippet v1))) 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))+argument = memo tbl_argument $ (((do string "$"+                                     v1 <- some digit+                                     return (Argument $ read v1)) <|> (do string "$"+                                                                          string "p"+                                                                          return ArgPos)) <|> (do string "$"+                                                                                                  string "s"+                                                                                                  return ArgSpan)) 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'))

@@ -48,6 +48,8 @@      -- * Utiligy   space,+  defaultDelimiter,+  token,   ) where  import Control.Applicative@@ -67,9 +69,9 @@          -> Either ParseError a             -- ^ result parse p pos str = runST $ do   tbl <- newTable-  res <- unParser p tbl pos str+  res <- unParser p tbl pos ' ' str   case res of-    Parsed _ _ ret -> return $ Right ret+    Parsed _ _ _ ret -> return $ Right ret     Failed err -> return $ Left err  -- | Parsing function with only input name@@ -92,10 +94,10 @@ --  newtype Parser tbl str s a-  = Parser { unParser :: tbl s -> SrcPos -> str -> ST s (Result str a) }+  = Parser { unParser :: tbl s -> SrcPos -> Char -> str -> ST s (Result str a) }  data Result str a-  = Parsed SrcPos str a+  = Parsed SrcPos Char str a   | Failed ParseError  data ParseError@@ -116,12 +118,12 @@   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+  return v = Parser $ \_ pos p s -> return $ Parsed pos p s v+  p >>= f = Parser $ \tbl pos prev s -> do+    res <- unParser p tbl pos prev s     case res of-      Parsed qos t x ->-        unParser (f x) tbl qos t+      Parsed qos q t x ->+        unParser (f x) tbl qos q t       Failed err ->         return $ Failed err @@ -136,12 +138,12 @@     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+  throwError err = Parser $ \_ _ _ _ -> return $ Failed err+  catchError p h = Parser $ \tbl pos prev s -> do+    res <- unParser p tbl pos prev s     case res of       Parsed {} -> return res-      Failed err -> unParser (h err) tbl pos s+      Failed err -> unParser (h err) tbl pos prev s  instance Alternative (Parser tbl str s) where   empty = throwError nullError@@ -153,33 +155,33 @@ 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+memo ft p = Parser $ \tbl pos@(SrcPos _ n _ _) prev s -> do   cache <- HT.lookup (ft tbl) n   case cache of     Just v -> return v     Nothing -> do-      v <- unParser p tbl pos s+      v <- unParser p tbl pos prev s       HT.insert (ft tbl) n v       return v  getPos :: Parser tbl str s SrcPos-getPos = Parser $ \_ pos str -> return $ Parsed pos str pos+getPos = Parser $ \_ pos prev str -> return $ Parsed pos prev str pos  setPos :: SrcPos -> Parser tbl str s ()-setPos pos = Parser $ \_ _ str -> return $ Parsed pos str ()+setPos pos = Parser $ \_ _ prev str -> return $ Parsed pos prev str ()  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 ->+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+    return $ Parsed (pos `advance` c) c cs c  satisfy :: LL.ListLike str Char => (Char -> Bool) -> Parser tbl str s Char satisfy p = do@@ -204,11 +206,41 @@   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+test p = Parser $ \tbl pos prev str -> do+  res <- unParser p tbl pos prev str   return $ case res of-    Parsed _ _ _ -> Parsed pos str True-    Failed _ -> Parsed pos str False+    Parsed _ _ _ _ -> Parsed pos prev str True+    Failed _ -> Parsed pos prev str False  space :: LL.ListLike str Char => Parser tbl str s () space = () <$ satisfy isSpace++defaultDelimiter :: LL.ListLike str Char => Parser tbl str s ()+defaultDelimiter = () <$ satisfy isPunctuation++getPrevChar :: LL.ListLike str Char => Parser tbl str s Char+getPrevChar = Parser $ \_ pos prev str ->+  return $ Parsed pos prev str prev  ++token :: LL.ListLike str Char+         => Parser tbl str s ()+         -> Parser tbl str s ()+         -> Parser tbl str s a+         -> Parser tbl str s a+token sp del p = do+  many sp+  ret <- p+  prev <- getPrevChar+  sp <|> del <|> unexpect (satisfy $ check prev)+  many sp+  return ret+  where+    check pr cr+      | isAlnum' pr && isAlnum' cr = True +      | isDigit pr && isDigit cr = True+      | isGlyph pr && isGlyph cr = True+      | otherwise = False+    +    isAlnum' c = isAlpha' c || isDigit c+    isAlpha' c = isAlpha c || c == '_'+    isGlyph c = isPrint c && not (isAlpha' c) && not (isDigit c)

@@ -55,6 +55,8 @@ data CodePart   = Snippet String   | Argument Int+  | ArgPos+  | ArgSpan   deriving (Show, Eq, Typeable, Data)  type Identifier = String

@@ -2,7 +2,7 @@  # Pre-requirement -Previous version of peggy (>= 0.1.3) required.+Previous version of peggy (>= 0.2.0.1) required.  # Bootstrap 

@@ -76,6 +76,8 @@  argument :: CodePart   = '$' digit+ { Argument $ read $1 }+  / '$' 'p'    { ArgPos  }+  / '$' 's'    { ArgSpan }  digit    :: Char = [0-9]  hexDigit :: Char = [0-9a-fA-F]

@@ -1,5 +1,5 @@ Name:                peggy-Version:             0.2.0.1+Version:             0.2.1 Synopsis:            The Parser Generator for Haskell  Description: