diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,30 +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. +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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,69 +1,69 @@ -# 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: - -~~~ {.bash} -$ 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. - -~~~ {.haskell} -{-# 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 -~~~ +# 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: + +~~~ {.bash} +$ 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. + +~~~ {.haskell} +{-# 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 +~~~ diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple +main = defaultMain diff --git a/Text/Peggy.hs b/Text/Peggy.hs --- a/Text/Peggy.hs +++ b/Text/Peggy.hs @@ -1,11 +1,11 @@ -module Text.Peggy ( - module Text.Peggy.Prim, - module Text.Peggy.SrcLoc, - module Text.Peggy.Syntax, - module Text.Peggy.Quote, - ) where - -import Text.Peggy.Prim -import Text.Peggy.SrcLoc -import Text.Peggy.Syntax -import Text.Peggy.Quote +module Text.Peggy ( + module Text.Peggy.Prim, + module Text.Peggy.SrcLoc, + module Text.Peggy.Syntax, + module Text.Peggy.Quote, + ) where + +import Text.Peggy.Prim +import Text.Peggy.SrcLoc +import Text.Peggy.Syntax +import Text.Peggy.Quote diff --git a/Text/Peggy/CodeGen/TH.hs b/Text/Peggy/CodeGen/TH.hs --- a/Text/Peggy/CodeGen/TH.hs +++ b/Text/Peggy/CodeGen/TH.hs @@ -1,311 +1,311 @@ -{-# LANGUAGE TemplateHaskell, TupleSections, FlexibleContexts #-} - -module Text.Peggy.CodeGen.TH ( - genDecs, - genQQ, - ) where - -import Control.Applicative -import Control.Monad -import qualified Data.HashTable.ST.Basic as HT -import Data.List -import qualified Data.ListLike as LL -import Data.Maybe -import Data.Typeable () -import Language.Haskell.Meta -import Language.Haskell.TH -import Language.Haskell.TH.Syntax -import Language.Haskell.TH.Quote -import Text.Peggy.Prim -import Text.Peggy.Syntax -import Text.Peggy.SrcLoc -import Text.Peggy.Normalize -import Text.Peggy.LeftRec - -genQQ :: Syntax -> (String, String) -> Q [Dec] -genQQ syn (qqName, parserName) = do - sig <- sigD (mkName qqName) (conT ''QuasiQuoter) - dat <- valD (varP $ mkName qqName) (normalB con) [] - return [sig, dat] - where - con = do - e <- [| \str -> do - loc <- location - case parse $(varE $ mkName parserName) (SrcPos (loc_filename loc) 0 (fst $ loc_start loc) (snd $ loc_start loc)) str of - Left err -> error $ show err - Right a -> a - |] - u <- [| undefined |] - recConE 'QuasiQuoter [ return ('quoteExp, e) - , return ('quoteDec, u) - , return ('quotePat, u) - , return ('quoteType, u) - ] - -genDecs :: Syntax -> Q [Dec] -genDecs = generate . normalize . removeLeftRecursion - -generate :: Syntax -> Q [Dec] -generate defs = do - tblTypName <- newName "MemoTable" - tblDatName <- newName "MemoTable" - ps <- parsers tblTypName - sequence $ [ defTbl tblTypName tblDatName - , instTbl tblTypName tblDatName - ] ++ ps - where - n = length defs - - defTbl :: Name -> Name -> DecQ - defTbl tblTypName tblDatName = do - s <- newName "s" - str <- newName "str" - dataD (cxt []) tblTypName [PlainTV str, PlainTV s] [con s str] [] - where - con s str = recC tblDatName $ map toMem defs where - toMem (Definition nont typ _) = do - let tt | isExp nont = [t| ExpQ |] - | otherwise = parseType' typ - t <- [t| HT.HashTable $(varT s) Int - (Result $(varT str) $tt) |] - return (mkName $ "tbl_" ++nont, NotStrict, t) - - instTbl :: Name -> Name -> DecQ - instTbl tblTypName tblDatName = do - str <- newName "str" - instanceD (cxt []) (conT ''MemoTable `appT` (conT tblTypName `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 tblDatName : map varE names]] - - parsers tblName = concat <$> mapM (gen tblName) defs - - isExp name = isJust $ find f defs where - f (Definition nont typ _) - | nont == name && head (words typ) == "Exp" = True - | otherwise = False - - gen tblName (Definition nont typ e) - | isExp nont = return $ - [ genSig tblName nont [t| ExpQ |] - , funD (mkName nont) - [clause [] (normalB [| memo $(varE $ mkName $ "tbl_" ++ nont) $ $(genP True e) |]) []]] - | otherwise = return $ - [ genSig tblName nont (parseType' typ) - , funD (mkName nont) - [clause [] (normalB [| memo $(varE $ mkName $ "tbl_" ++ nont) $ $(genP False e) |]) []]] - - genSig tblName name typ = do - str <- newName "str" - s <- newName "s" - sigD (mkName name) $ - 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` - typ - - -- Generate Parser - genP :: Bool -> Expr -> ExpQ - genP isE e = case (isE, e) of - (False, Terminals False False str) -> - [| string str |] - (True, Terminals False False str) -> - [| lift <$> string str |] - - (False, TerminalSet rs) -> - [| satisfy $(genRanges rs) |] - (True, TerminalSet rs) -> - [| lift <$> satisfy $(genRanges rs) |] - - (False, TerminalCmp rs) -> - [| satisfy $ not . $(genRanges rs) |] - (True, TerminalCmp rs) -> - [| lift <$> (satisfy $ not . $(genRanges rs)) |] - - (False, TerminalAny) -> - [| anyChar |] - (True, TerminalAny) -> - [| lift <$> anyChar |] - - (False, NonTerminal nont) -> - if isExp nont then error $ "value cannot contain exp: " ++ nont - else [| $(varE $ mkName nont) |] - (True, NonTerminal nont) -> - if isExp nont - then [| $(varE $ mkName nont) |] - else [| lift <$> $(varE $ mkName nont) |] - - (False, Primitive name) -> - [| $(varE $ mkName name) |] - (True, Primitive name) -> - [| lift <$> $(varE $ mkName name) |] - - (False, Empty) -> - [| return () |] - (True, Empty) -> - [| lift <$> return () |] - - (False, Many f) -> - [| many $(genP isE f) |] - (True, Many f) -> - [| do eQs <- many $(genP isE f); return $ listE eQs |] - - (False, Some f) -> - [| some $(genP isE f) |] - (True, Some f) -> - [| do eQs <- some $(genP isE f); return $ listE eQs |] - - (False, Optional f) -> - [| optional $(genP isE f) |] - (True, Optional f) -> - [| do eQm <- optional $(genP isE f); case eQm of Nothing -> lift Nothing; Just q -> do ee <- q; lift (Just ee) |] - - (False, And f) -> - [| expect $(genP isE f) |] - (True, And f) -> - [| lift () <$ expect $(genP isE f) |] - - (False, Not f) -> - [| unexpect $(genP isE f) |] - (True, Not f) -> - [| lift () <$ unexpect $(genP isE f) |] - - (_, Token f) -> - [| token $(varE skip) $(varE delimiter) ( $(genP isE f) ) |] - - -- simply, ignoreing result value - (False, Named "_" f) -> - [| () <$ $(genP isE f) |] - (True, Named "_" f) -> - [| () <$ $(genP isE f) |] - - (_, Named {}) -> error "named expr must has semantic." - - (False, Choice es) -> - foldl1 (\a b -> [| $a <|> $b |]) $ map (genP isE) es - (True, Choice es) -> - [| $(foldl1 (\a b -> [| $a <|> $b |]) $ map (genP isE) es) |] - - -- Semancit Code - - -- Generates a Normal, value constructing code. - -- It cannot has anti-quotes, values dependent on anti-quotes. - (False, Semantic (Sequence es) cf) -> do - -- TODO: make it syntax-sugar - 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 isE cf) |] ] - - -- Generates a Exp constructing code. - -- It can contain anti-quotes. - -- Anti-quoted value must be Normal values. - (True, Semantic (Sequence es) cf) -> do - bs <- sequence $ genBinds 1 es - let vn = length $ filter isBind bs - let gcf = genCF isE (ccf vn) - doE $ map return bs ++ - [ noBindS [| return $ foldl appE (return $(lift =<< gcf)) $(eQnames vn) |]] - where - ccf 0 = cf - ccf nn = [Snippet $ "\\" ++ unwords (names nn ++ qames nn) ++ " -> ("] ++ cf ++ [Snippet ")"] - eQnames nn = - listE $ [ [| lift $(varE (mkName $ var i)) |] | i <- [1..nn]] ++ - [ if hasAQ i cf - then [| varE $ mkName $(varE $ mkName $ var i) |] - else [| litE $ integerL 0 |] - | i <- [1..nn]] - names nn = map var [1..nn] - qames nn = map qar [1..nn] - - _ -> - error $ "internal compile error: " ++ show e - - where - genBinds _ [] = [] - genBinds ix (f:fs) = case f of - Named "_" g -> - noBindS (genP isE g) : - genBinds ix fs - Named name g -> - bindS (asP (mkName name) $ varP $ mkName (var ix)) (genP isE g) : - genBinds (ix+1) fs - _ | shouldBind f -> - bindS (varP $ mkName $ var ix) (genP isE f) : - genBinds (ix+1) fs - _ -> - noBindS (genP isE f) : - genBinds ix fs - - genRanges :: [CharRange] -> ExpQ - genRanges rs = - let c = mkName "c" in - lamE [varP c] $ foldl1 (\a b -> [| $a || $b |]) $ map (genRange c) rs - - genRange :: Name -> CharRange -> ExpQ - genRange c (CharRange l h) = - [| l <= $(varE c) && $(varE c) <= h |] - genRange c (CharOne v) = - [| $(varE c) == v |] - - genCF isE 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 a) = var a - toStr (AntiArgument nn) - | not isE = error "Anti-quoter is not allowed in non-AQ parser" - | otherwise = qar nn - toStr ArgPos = "(LocPos " ++ stName ++ ")" - toStr ArgSpan = "(LocSpan " ++ stName ++ " " ++ edName ++ ")" - - hasAQ x cf = not . null $ filter (isAQ x) cf where - isAQ i (AntiArgument j) = i == j - isAQ _ _ = False - - hasPos = any (==ArgPos) - hasSpan = any (==ArgSpan) - - isBind (BindS _ _) = True - isBind _ = False - - skip = mkName "skip" - delimiter = mkName "delimiter" - - var nn = "v" ++ show (nn :: Int) - qar nn = "q" ++ show (nn :: Int) - stName = "st_Pos" - edName = "ed_Pos" - -parseExp' str = - case parseExp str of - Left _ -> - error $ "code fragment parse error: " ++ str - Right ret -> - return ret - -parseType' typ = - case parseType typ of - Left err -> error $ "type parse error :" ++ typ ++ ", " ++ err - Right t -> case t of - -- GHC.Unit.()/GHC.Tuple.() 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 - ConT con | show con == "GHC.Tuple.()" -> - return $ TupleT 0 - _ -> - return t +{-# LANGUAGE TemplateHaskell, TupleSections, FlexibleContexts #-} + +module Text.Peggy.CodeGen.TH ( + genDecs, + genQQ, + ) where + +import Control.Applicative +import Control.Monad +import qualified Data.HashTable.ST.Basic as HT +import Data.List +import qualified Data.ListLike as LL +import Data.Maybe +import Data.Typeable () +import Language.Haskell.Meta +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Quote +import Text.Peggy.Prim +import Text.Peggy.Syntax +import Text.Peggy.SrcLoc +import Text.Peggy.Normalize +import Text.Peggy.LeftRec + +genQQ :: Syntax -> (String, String) -> Q [Dec] +genQQ syn (qqName, parserName) = do + sig <- sigD (mkName qqName) (conT ''QuasiQuoter) + dat <- valD (varP $ mkName qqName) (normalB con) [] + return [sig, dat] + where + con = do + e <- [| \str -> do + loc <- location + case parse $(varE $ mkName parserName) (SrcPos (loc_filename loc) 0 (fst $ loc_start loc) (snd $ loc_start loc)) str of + Left err -> error $ show err + Right a -> a + |] + u <- [| undefined |] + recConE 'QuasiQuoter [ return ('quoteExp, e) + , return ('quoteDec, u) + , return ('quotePat, u) + , return ('quoteType, u) + ] + +genDecs :: Syntax -> Q [Dec] +genDecs = generate . normalize . removeLeftRecursion + +generate :: Syntax -> Q [Dec] +generate defs = do + tblTypName <- newName "MemoTable" + tblDatName <- newName "MemoTable" + ps <- parsers tblTypName + sequence $ [ defTbl tblTypName tblDatName + , instTbl tblTypName tblDatName + ] ++ ps + where + n = length defs + + defTbl :: Name -> Name -> DecQ + defTbl tblTypName tblDatName = do + s <- newName "s" + str <- newName "str" + dataD (cxt []) tblTypName [PlainTV str, PlainTV s] [con s str] [] + where + con s str = recC tblDatName $ map toMem defs where + toMem (Definition nont typ _) = do + let tt | isExp nont = [t| ExpQ |] + | otherwise = parseType' typ + t <- [t| HT.HashTable $(varT s) Int + (Result $(varT str) $tt) |] + return (mkName $ "tbl_" ++nont, NotStrict, t) + + instTbl :: Name -> Name -> DecQ + instTbl tblTypName tblDatName = do + str <- newName "str" + instanceD (cxt []) (conT ''MemoTable `appT` (conT tblTypName `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 tblDatName : map varE names]] + + parsers tblName = concat <$> mapM (gen tblName) defs + + isExp name = isJust $ find f defs where + f (Definition nont typ _) + | nont == name && head (words typ) == "Exp" = True + | otherwise = False + + gen tblName (Definition nont typ e) + | isExp nont = return $ + [ genSig tblName nont [t| ExpQ |] + , funD (mkName nont) + [clause [] (normalB [| memo $(varE $ mkName $ "tbl_" ++ nont) $ $(genP True e) |]) []]] + | otherwise = return $ + [ genSig tblName nont (parseType' typ) + , funD (mkName nont) + [clause [] (normalB [| memo $(varE $ mkName $ "tbl_" ++ nont) $ $(genP False e) |]) []]] + + genSig tblName name typ = do + str <- newName "str" + s <- newName "s" + sigD (mkName name) $ + 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` + typ + + -- Generate Parser + genP :: Bool -> Expr -> ExpQ + genP isE e = case (isE, e) of + (False, Terminals False False str) -> + [| string str |] + (True, Terminals False False str) -> + [| lift <$> string str |] + + (False, TerminalSet rs) -> + [| satisfy $(genRanges rs) |] + (True, TerminalSet rs) -> + [| lift <$> satisfy $(genRanges rs) |] + + (False, TerminalCmp rs) -> + [| satisfy $ not . $(genRanges rs) |] + (True, TerminalCmp rs) -> + [| lift <$> (satisfy $ not . $(genRanges rs)) |] + + (False, TerminalAny) -> + [| anyChar |] + (True, TerminalAny) -> + [| lift <$> anyChar |] + + (False, NonTerminal nont) -> + if isExp nont then error $ "value cannot contain exp: " ++ nont + else [| $(varE $ mkName nont) |] + (True, NonTerminal nont) -> + if isExp nont + then [| $(varE $ mkName nont) |] + else [| lift <$> $(varE $ mkName nont) |] + + (False, Primitive name) -> + [| $(varE $ mkName name) |] + (True, Primitive name) -> + [| lift <$> $(varE $ mkName name) |] + + (False, Empty) -> + [| return () |] + (True, Empty) -> + [| lift <$> return () |] + + (False, Many f) -> + [| many $(genP isE f) |] + (True, Many f) -> + [| do eQs <- many $(genP isE f); return $ listE eQs |] + + (False, Some f) -> + [| some $(genP isE f) |] + (True, Some f) -> + [| do eQs <- some $(genP isE f); return $ listE eQs |] + + (False, Optional f) -> + [| optional $(genP isE f) |] + (True, Optional f) -> + [| do eQm <- optional $(genP isE f); case eQm of Nothing -> lift Nothing; Just q -> do ee <- q; lift (Just ee) |] + + (False, And f) -> + [| expect $(genP isE f) |] + (True, And f) -> + [| lift () <$ expect $(genP isE f) |] + + (False, Not f) -> + [| unexpect $(genP isE f) |] + (True, Not f) -> + [| lift () <$ unexpect $(genP isE f) |] + + (_, Token f) -> + [| token $(varE skip) $(varE delimiter) ( $(genP isE f) ) |] + + -- simply, ignoreing result value + (False, Named "_" f) -> + [| () <$ $(genP isE f) |] + (True, Named "_" f) -> + [| () <$ $(genP isE f) |] + + (_, Named {}) -> error "named expr must has semantic." + + (False, Choice es) -> + foldl1 (\a b -> [| $a <|> $b |]) $ map (genP isE) es + (True, Choice es) -> + [| $(foldl1 (\a b -> [| $a <|> $b |]) $ map (genP isE) es) |] + + -- Semancit Code + + -- Generates a Normal, value constructing code. + -- It cannot has anti-quotes, values dependent on anti-quotes. + (False, Semantic (Sequence es) cf) -> do + -- TODO: make it syntax-sugar + 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 isE cf) |] ] + + -- Generates a Exp constructing code. + -- It can contain anti-quotes. + -- Anti-quoted value must be Normal values. + (True, Semantic (Sequence es) cf) -> do + bs <- sequence $ genBinds 1 es + let vn = length $ filter isBind bs + let gcf = genCF isE (ccf vn) + doE $ map return bs ++ + [ noBindS [| return $ foldl appE (return $(lift =<< gcf)) $(eQnames vn) |]] + where + ccf 0 = cf + ccf nn = [Snippet $ "\\" ++ unwords (names nn ++ qames nn) ++ " -> ("] ++ cf ++ [Snippet ")"] + eQnames nn = + listE $ [ [| lift $(varE (mkName $ var i)) |] | i <- [1..nn]] ++ + [ if hasAQ i cf + then [| varE $ mkName $(varE $ mkName $ var i) |] + else [| litE $ integerL 0 |] + | i <- [1..nn]] + names nn = map var [1..nn] + qames nn = map qar [1..nn] + + _ -> + error $ "internal compile error: " ++ show e + + where + genBinds _ [] = [] + genBinds ix (f:fs) = case f of + Named "_" g -> + noBindS (genP isE g) : + genBinds ix fs + Named name g -> + bindS (asP (mkName name) $ varP $ mkName (var ix)) (genP isE g) : + genBinds (ix+1) fs + _ | shouldBind f -> + bindS (varP $ mkName $ var ix) (genP isE f) : + genBinds (ix+1) fs + _ -> + noBindS (genP isE f) : + genBinds ix fs + + genRanges :: [CharRange] -> ExpQ + genRanges rs = + let c = mkName "c" in + lamE [varP c] $ foldl1 (\a b -> [| $a || $b |]) $ map (genRange c) rs + + genRange :: Name -> CharRange -> ExpQ + genRange c (CharRange l h) = + [| l <= $(varE c) && $(varE c) <= h |] + genRange c (CharOne v) = + [| $(varE c) == v |] + + genCF isE 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 a) = var a + toStr (AntiArgument nn) + | not isE = error "Anti-quoter is not allowed in non-AQ parser" + | otherwise = qar nn + toStr ArgPos = "(LocPos " ++ stName ++ ")" + toStr ArgSpan = "(LocSpan " ++ stName ++ " " ++ edName ++ ")" + + hasAQ x cf = not . null $ filter (isAQ x) cf where + isAQ i (AntiArgument j) = i == j + isAQ _ _ = False + + hasPos = any (==ArgPos) + hasSpan = any (==ArgSpan) + + isBind (BindS _ _) = True + isBind _ = False + + skip = mkName "skip" + delimiter = mkName "delimiter" + + var nn = "v" ++ show (nn :: Int) + qar nn = "q" ++ show (nn :: Int) + stName = "st_Pos" + edName = "ed_Pos" + +parseExp' str = + case parseExp str of + Left _ -> + error $ "code fragment parse error: " ++ str + Right ret -> + return ret + +parseType' typ = + case parseType typ of + Left err -> error $ "type parse error :" ++ typ ++ ", " ++ err + Right t -> case t of + -- GHC.Unit.()/GHC.Tuple.() 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 + ConT con | show con == "GHC.Tuple.()" -> + return $ TupleT 0 + _ -> + return t diff --git a/Text/Peggy/LeftRec.hs b/Text/Peggy/LeftRec.hs --- a/Text/Peggy/LeftRec.hs +++ b/Text/Peggy/LeftRec.hs @@ -1,72 +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] +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] diff --git a/Text/Peggy/Normalize.hs b/Text/Peggy/Normalize.hs --- a/Text/Peggy/Normalize.hs +++ b/Text/Peggy/Normalize.hs @@ -1,87 +1,87 @@ -module Text.Peggy.Normalize ( - normalize, - shouldBind, - ) where - -import Data.List -import Text.Peggy.Syntax - -normalize :: Syntax -> Syntax -normalize = map desugarDef . addSkipDelim - -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 True True str -> - Token $ Terminals False False str - - Terminals {} -> e - TerminalSet {} -> e - TerminalCmp {} -> e - TerminalAny {} -> e - NonTerminal {} -> e - Primitive {} -> e - Empty -> e - - Named name f -> Named name $ desugar f - - 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 - - Sequence es -> - desugar $ Semantic (Sequence es) $ defaultCF $ length $ filter shouldBind es - - Semantic (Sequence es) cf -> - Semantic (Sequence $ map desugar es) cf - Semantic f cf -> - Semantic (Sequence [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'' = desugar $ Semantic g' [Snippet "()"] in - Semantic (Sequence [f', (Many (Semantic (Sequence [g'', f']) [Argument 2]))]) - [ Argument 1 - , Snippet ":" - , Argument 2 - ] - - Token f -> - Token $ desugar f - - defaultCF n = - [ Snippet "(" ] ++ - intersperse (Snippet ",") (map Argument[1..n]) ++ - [ Snippet ")" ] - -shouldBind f = case f of - Terminals _ _ _ -> False - And _ -> False - Not _ -> False - Token g -> shouldBind g - _ -> True +module Text.Peggy.Normalize ( + normalize, + shouldBind, + ) where + +import Data.List +import Text.Peggy.Syntax + +normalize :: Syntax -> Syntax +normalize = map desugarDef . addSkipDelim + +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 True True str -> + Token $ Terminals False False str + + Terminals {} -> e + TerminalSet {} -> e + TerminalCmp {} -> e + TerminalAny {} -> e + NonTerminal {} -> e + Primitive {} -> e + Empty -> e + + Named name f -> Named name $ desugar f + + 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 + + Sequence es -> + desugar $ Semantic (Sequence es) $ defaultCF $ length $ filter shouldBind es + + Semantic (Sequence es) cf -> + Semantic (Sequence $ map desugar es) cf + Semantic f cf -> + Semantic (Sequence [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'' = desugar $ Semantic g' [Snippet "()"] in + Semantic (Sequence [f', (Many (Semantic (Sequence [g'', f']) [Argument 2]))]) + [ Argument 1 + , Snippet ":" + , Argument 2 + ] + + Token f -> + Token $ desugar f + + defaultCF n = + [ Snippet "(" ] ++ + intersperse (Snippet ",") (map Argument[1..n]) ++ + [ Snippet ")" ] + +shouldBind f = case f of + Terminals _ _ _ -> False + And _ -> False + Not _ -> False + Token g -> shouldBind g + _ -> True diff --git a/Text/Peggy/Parser.hs b/Text/Peggy/Parser.hs --- a/Text/Peggy/Parser.hs +++ b/Text/Peggy/Parser.hs @@ -1,294 +1,294 @@ -{-# LANGUAGE RankNTypes, 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 - -data MemoTable_0 str_1 s_2 - = MemoTable_3 {tbl_delimiter :: (HashTable s_2 - Int - (Result str_1 ())), - tbl_syntax :: (HashTable s_2 Int (Result str_1 Syntax)), - tbl_definition :: (HashTable s_2 Int (Result str_1 Definition)), - tbl_expr :: (HashTable s_2 Int (Result str_1 Expr)), - tbl_choiceExpr :: (HashTable s_2 Int (Result str_1 Expr)), - tbl_semanticExpr :: (HashTable s_2 Int (Result str_1 Expr)), - tbl_sequenceExpr :: (HashTable s_2 Int (Result str_1 Expr)), - tbl_namedExpr :: (HashTable s_2 Int (Result str_1 Expr)), - tbl_suffixExpr :: (HashTable s_2 Int (Result str_1 Expr)), - tbl_suffixExpr_tail :: (HashTable s_2 - Int - (Result str_1 (Expr -> Expr))), - tbl_prefixExpr :: (HashTable s_2 Int (Result str_1 Expr)), - tbl_primExpr :: (HashTable s_2 Int (Result str_1 Expr)), - tbl_charLit :: (HashTable s_2 Int (Result str_1 Char)), - 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 TermType)), - tbl_codeFragment :: (HashTable s_2 - Int - (Result str_1 CodeFragment)), - tbl_codePart :: (HashTable s_2 Int (Result str_1 CodePart)), - tbl_argument :: (HashTable s_2 Int (Result str_1 CodePart)), - tbl_digit :: (HashTable s_2 Int (Result str_1 Char)), - tbl_hexDigit :: (HashTable s_2 Int (Result str_1 Char)), - tbl_ident :: (HashTable s_2 Int (Result str_1 String)), - tbl_skip :: (HashTable s_2 Int (Result str_1 ())), - 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_4) - where newTable = do t_5 <- new - t_6 <- new - t_7 <- new - t_8 <- new - t_9 <- new - t_10 <- new - t_11 <- new - t_12 <- new - t_13 <- new - t_14 <- new - t_15 <- new - t_16 <- new - t_17 <- new - t_18 <- new - t_19 <- new - t_20 <- new - t_21 <- new - t_22 <- new - t_23 <- new - t_24 <- new - t_25 <- new - t_26 <- new - t_27 <- new - t_28 <- new - t_29 <- new - t_30 <- new - t_31 <- 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 t_30 t_31) -delimiter :: forall str_32 s_33 . ListLike str_32 Char => - Parser (MemoTable_0 str_32) str_32 s_33 () -delimiter = memo tbl_delimiter $ defaultDelimiter -syntax :: forall str_34 s_35 . ListLike str_34 Char => - Parser (MemoTable_0 str_34) str_34 s_35 Syntax -syntax = memo tbl_syntax $ (do v1 <- many definition - unexpect (do v1 <- many skip - v2 <- anyChar - return $ (v1, v2)) - return $ (v1)) -definition :: forall str_36 s_37 . ListLike str_36 Char => - Parser (MemoTable_0 str_36) str_36 s_37 Definition -definition = memo tbl_definition $ token skip delimiter ((do v1 <- ident - token skip delimiter (string ":::") - v2 <- haskellType - token skip delimiter (string "=") - v3 <- expr - return (Definition v1 v2 (Token v3))) <|> (do v1 <- ident - token skip delimiter (string "::") - v2 <- haskellType - token skip delimiter (string "=") - v3 <- expr - return (Definition v1 v2 v3))) -expr :: forall str_38 s_39 . ListLike str_38 Char => - Parser (MemoTable_0 str_38) str_38 s_39 Expr -expr = memo tbl_expr $ (do v1 <- choiceExpr - return $ (v1)) -choiceExpr :: forall str_40 s_41 . ListLike str_40 Char => - Parser (MemoTable_0 str_40) str_40 s_41 Expr -choiceExpr = memo tbl_choiceExpr $ (do v1 <- (do v1 <- do v1 <- semanticExpr - return $ (v1) - v2 <- many (do v1 <- do v1 <- do token skip delimiter (string "/") - return $ () - return () - v2 <- do v1 <- semanticExpr - return $ (v1) - return v2) - return (v1 : v2)) <|> (do v1 <- return () - return []) - return (Choice v1)) -semanticExpr :: forall str_42 s_43 . ListLike str_42 Char => - Parser (MemoTable_0 str_42) str_42 s_43 Expr -semanticExpr = memo tbl_semanticExpr $ ((do v1 <- sequenceExpr - token skip delimiter (string "{") - v2 <- codeFragment - token skip delimiter (string "}") - return (Semantic v1 v2)) <|> (do v1 <- sequenceExpr - return $ (v1))) -sequenceExpr :: forall str_44 s_45 . ListLike str_44 Char => - Parser (MemoTable_0 str_44) str_44 s_45 Expr -sequenceExpr = memo tbl_sequenceExpr $ (do v1 <- some (do v1 <- namedExpr - unexpect (token skip delimiter (string "::")) - unexpect (token skip delimiter (string "=")) - return $ (v1)) - return (Sequence v1)) -namedExpr :: forall str_46 s_47 . ListLike str_46 Char => - Parser (MemoTable_0 str_46) str_46 s_47 Expr -namedExpr = memo tbl_namedExpr $ ((do v1 <- ident - token skip delimiter (string ":") - v2 <- suffixExpr - return (Named v1 v2)) <|> (do v1 <- suffixExpr - return $ (v1))) -suffixExpr :: forall str_48 s_49 . ListLike str_48 Char => - Parser (MemoTable_0 str_48) str_48 s_49 Expr -suffixExpr = memo tbl_suffixExpr $ (do v1 <- do v1 <- prefixExpr - return $ (v1) - v2 <- suffixExpr_tail - return (v2 v1)) -suffixExpr_tail :: forall str_50 s_51 . ListLike str_50 Char => - Parser (MemoTable_0 str_50) str_50 s_51 (Expr -> Expr) -suffixExpr_tail = memo tbl_suffixExpr_tail $ ((((do token skip delimiter (string "*") - v1 <- suffixExpr_tail - return (\v999 -> v1 (Many v999))) <|> (do token skip delimiter (string "+") - v1 <- suffixExpr_tail - return (\v999 -> v1 (Some v999)))) <|> (do token skip delimiter (string "?") - v1 <- suffixExpr_tail - return (\v999 -> v1 (Optional v999)))) <|> (do v1 <- return () - return id)) -prefixExpr :: forall str_52 s_53 . ListLike str_52 Char => - Parser (MemoTable_0 str_52) str_52 s_53 Expr -prefixExpr = memo tbl_prefixExpr $ (((do token skip delimiter (string "&") - v1 <- primExpr - return (And v1)) <|> (do token skip delimiter (string "!") - v1 <- primExpr - return (Not v1))) <|> (do v1 <- primExpr - return $ (v1))) -primExpr :: forall str_54 s_55 . ListLike str_54 Char => - Parser (MemoTable_0 str_54) str_54 s_55 Expr -primExpr = memo tbl_primExpr $ token skip delimiter (((((((((do string "\"" - v1 <- many charLit - string "\"" - return (Terminals True True v1)) <|> (do string "'" - v1 <- many charLit - string "'" - return (Terminals False False v1))) <|> (do string "[^" - v1 <- many range - string "]" - return (TerminalCmp v1))) <|> (do string "[" - v1 <- many range - string "]" - return (TerminalSet v1))) <|> (do token skip delimiter (string ".") - return TerminalAny)) <|> (do v1 <- ident - return (NonTerminal v1))) <|> (do token skip delimiter (string "(") - v1 <- expr - token skip delimiter (string ",") - v2 <- expr - token skip delimiter (string ")") - return (SepBy v1 v2))) <|> (do token skip delimiter (string "(") - v1 <- expr - token skip delimiter (string ";") - v2 <- expr - token skip delimiter (string ")") - return (SepBy1 v1 v2))) <|> (do token skip delimiter (string "(") - v1 <- expr - token skip delimiter (string ")") - return $ (v1))) -charLit :: forall str_56 s_57 . ListLike str_56 Char => - Parser (MemoTable_0 str_56) str_56 s_57 Char -charLit = memo tbl_charLit $ ((do string "\\" - v1 <- escChar - return $ (v1)) <|> (do unexpect (satisfy (\c -> (c == '\'') || (c == '"'))) - v1 <- anyChar - return $ (v1))) -escChar :: forall str_58 s_59 . ListLike str_58 Char => - Parser (MemoTable_0 str_58) str_58 s_59 Char -escChar = memo tbl_escChar $ (((((((do string "n" - return '\n') <|> (do string "r" - return '\r')) <|> (do string "t" - return '\t')) <|> (do string "\\" - return '\\')) <|> (do string "\"" - return '"')) <|> (do string "'" - return '\'')) <|> (do string "x" - v1 <- hexDigit - v2 <- hexDigit - return ((chr . (fst . (head . readHex))) $ [v1, - v2]))) -range :: forall str_60 s_61 . ListLike str_60 Char => - Parser (MemoTable_0 str_60) str_60 s_61 CharRange -range = memo tbl_range $ ((do v1 <- rchar - string "-" - v2 <- rchar - return (CharRange v1 v2)) <|> (do v1 <- rchar - return (CharOne v1))) -rchar :: forall str_62 s_63 . ListLike str_62 Char => - Parser (MemoTable_0 str_62) str_62 s_63 Char -rchar = memo tbl_rchar $ ((((((do string "\\" - v1 <- escChar - return $ (v1)) <|> (do string "\\]" - return ']')) <|> (do string "\\[" - return '[')) <|> (do string "\\^" - return '^')) <|> (do string "\\-" - return '-')) <|> (do v1 <- satisfy $ (not . (\c -> c == ']')) - return $ (v1))) -haskellType :: forall str_64 s_65 . ListLike str_64 Char => - Parser (MemoTable_0 str_64) str_64 s_65 TermType -haskellType = memo tbl_haskellType $ (do v1 <- some (satisfy $ (not . (\c -> c == '='))) - return $ (v1)) -codeFragment :: forall str_66 s_67 . ListLike str_66 Char => - Parser (MemoTable_0 str_66) str_66 s_67 CodeFragment -codeFragment = memo tbl_codeFragment $ (do v1 <- many codePart - return $ (v1)) -codePart :: forall str_68 s_69 . ListLike str_68 Char => - Parser (MemoTable_0 str_68) str_68 s_69 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_70 s_71 . ListLike str_70 Char => - Parser (MemoTable_0 str_70) str_70 s_71 CodePart -argument = memo tbl_argument $ ((((do string "$$" - v1 <- some digit - return (AntiArgument $ read v1)) <|> (do string "$" - v1 <- some digit - return (Argument $ read v1))) <|> (do string "$" - string "p" - return ArgPos)) <|> (do string "$" - string "s" - return ArgSpan)) -digit :: forall str_72 s_73 . ListLike str_72 Char => - Parser (MemoTable_0 str_72) str_72 s_73 Char -digit = memo tbl_digit $ (do v1 <- satisfy (\c -> ('0' <= c) && (c <= '9')) - return $ (v1)) -hexDigit :: forall str_74 s_75 . ListLike str_74 Char => - Parser (MemoTable_0 str_74) str_74 s_75 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_76 s_77 . ListLike str_76 Char => - Parser (MemoTable_0 str_76) str_76 s_77 String -ident = memo tbl_ident $ token skip delimiter (do v1 <- satisfy (\c -> (('a' <= c) && (c <= 'z')) || (c == '_')) - v2 <- many (satisfy (\c -> (((('0' <= c) && (c <= '9')) || (('a' <= c) && (c <= 'z'))) || (('A' <= c) && (c <= 'Z'))) || (c == '_'))) - return (v1 : v2)) -skip :: forall str_78 s_79 . ListLike str_78 Char => - Parser (MemoTable_0 str_78) str_78 s_79 () -skip = memo tbl_skip $ ((do satisfy (\c -> (((c == ' ') || (c == '\r')) || (c == '\n')) || (c == '\t')) - return $ ()) <|> (do v1 <- comment - return $ (v1))) -comment :: forall str_80 s_81 . ListLike str_80 Char => - Parser (MemoTable_0 str_80) str_80 s_81 () -comment = memo tbl_comment $ ((do v1 <- lineComment - return $ (v1)) <|> (do v1 <- regionComment - return $ (v1))) -lineComment :: forall str_82 s_83 . ListLike str_82 Char => - Parser (MemoTable_0 str_82) str_82 s_83 () -lineComment = memo tbl_lineComment $ (do string "--" - many (do unexpect (string "\n") - anyChar - return $ ()) - string "\n" - return $ ()) -regionComment :: forall str_84 s_85 . ListLike str_84 Char => - Parser (MemoTable_0 str_84) str_84 s_85 () -regionComment = memo tbl_regionComment $ (do string "{-" - many ((do v1 <- regionComment - return $ (v1)) <|> (do unexpect (string "-}") - anyChar - return $ ())) - string "-}" - return $ ()) +{-# LANGUAGE RankNTypes, 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 + +data MemoTable_0 str_1 s_2 + = MemoTable_3 {tbl_delimiter :: (HashTable s_2 + Int + (Result str_1 ())), + tbl_syntax :: (HashTable s_2 Int (Result str_1 Syntax)), + tbl_definition :: (HashTable s_2 Int (Result str_1 Definition)), + tbl_expr :: (HashTable s_2 Int (Result str_1 Expr)), + tbl_choiceExpr :: (HashTable s_2 Int (Result str_1 Expr)), + tbl_semanticExpr :: (HashTable s_2 Int (Result str_1 Expr)), + tbl_sequenceExpr :: (HashTable s_2 Int (Result str_1 Expr)), + tbl_namedExpr :: (HashTable s_2 Int (Result str_1 Expr)), + tbl_suffixExpr :: (HashTable s_2 Int (Result str_1 Expr)), + tbl_suffixExpr_tail :: (HashTable s_2 + Int + (Result str_1 (Expr -> Expr))), + tbl_prefixExpr :: (HashTable s_2 Int (Result str_1 Expr)), + tbl_primExpr :: (HashTable s_2 Int (Result str_1 Expr)), + tbl_charLit :: (HashTable s_2 Int (Result str_1 Char)), + 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 TermType)), + tbl_codeFragment :: (HashTable s_2 + Int + (Result str_1 CodeFragment)), + tbl_codePart :: (HashTable s_2 Int (Result str_1 CodePart)), + tbl_argument :: (HashTable s_2 Int (Result str_1 CodePart)), + tbl_digit :: (HashTable s_2 Int (Result str_1 Char)), + tbl_hexDigit :: (HashTable s_2 Int (Result str_1 Char)), + tbl_ident :: (HashTable s_2 Int (Result str_1 String)), + tbl_skip :: (HashTable s_2 Int (Result str_1 ())), + 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_4) + where newTable = do t_5 <- new + t_6 <- new + t_7 <- new + t_8 <- new + t_9 <- new + t_10 <- new + t_11 <- new + t_12 <- new + t_13 <- new + t_14 <- new + t_15 <- new + t_16 <- new + t_17 <- new + t_18 <- new + t_19 <- new + t_20 <- new + t_21 <- new + t_22 <- new + t_23 <- new + t_24 <- new + t_25 <- new + t_26 <- new + t_27 <- new + t_28 <- new + t_29 <- new + t_30 <- new + t_31 <- 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 t_30 t_31) +delimiter :: forall str_32 s_33 . ListLike str_32 Char => + Parser (MemoTable_0 str_32) str_32 s_33 () +delimiter = memo tbl_delimiter $ defaultDelimiter +syntax :: forall str_34 s_35 . ListLike str_34 Char => + Parser (MemoTable_0 str_34) str_34 s_35 Syntax +syntax = memo tbl_syntax $ (do v1 <- many definition + unexpect (do v1 <- many skip + v2 <- anyChar + return $ (v1, v2)) + return $ (v1)) +definition :: forall str_36 s_37 . ListLike str_36 Char => + Parser (MemoTable_0 str_36) str_36 s_37 Definition +definition = memo tbl_definition $ token skip delimiter ((do v1 <- ident + token skip delimiter (string ":::") + v2 <- haskellType + token skip delimiter (string "=") + v3 <- expr + return (Definition v1 v2 (Token v3))) <|> (do v1 <- ident + token skip delimiter (string "::") + v2 <- haskellType + token skip delimiter (string "=") + v3 <- expr + return (Definition v1 v2 v3))) +expr :: forall str_38 s_39 . ListLike str_38 Char => + Parser (MemoTable_0 str_38) str_38 s_39 Expr +expr = memo tbl_expr $ (do v1 <- choiceExpr + return $ (v1)) +choiceExpr :: forall str_40 s_41 . ListLike str_40 Char => + Parser (MemoTable_0 str_40) str_40 s_41 Expr +choiceExpr = memo tbl_choiceExpr $ (do v1 <- (do v1 <- do v1 <- semanticExpr + return $ (v1) + v2 <- many (do v1 <- do v1 <- do token skip delimiter (string "/") + return $ () + return () + v2 <- do v1 <- semanticExpr + return $ (v1) + return v2) + return (v1 : v2)) <|> (do v1 <- return () + return []) + return (Choice v1)) +semanticExpr :: forall str_42 s_43 . ListLike str_42 Char => + Parser (MemoTable_0 str_42) str_42 s_43 Expr +semanticExpr = memo tbl_semanticExpr $ ((do v1 <- sequenceExpr + token skip delimiter (string "{") + v2 <- codeFragment + token skip delimiter (string "}") + return (Semantic v1 v2)) <|> (do v1 <- sequenceExpr + return $ (v1))) +sequenceExpr :: forall str_44 s_45 . ListLike str_44 Char => + Parser (MemoTable_0 str_44) str_44 s_45 Expr +sequenceExpr = memo tbl_sequenceExpr $ (do v1 <- some (do v1 <- namedExpr + unexpect (token skip delimiter (string "::")) + unexpect (token skip delimiter (string "=")) + return $ (v1)) + return (Sequence v1)) +namedExpr :: forall str_46 s_47 . ListLike str_46 Char => + Parser (MemoTable_0 str_46) str_46 s_47 Expr +namedExpr = memo tbl_namedExpr $ ((do v1 <- ident + token skip delimiter (string ":") + v2 <- suffixExpr + return (Named v1 v2)) <|> (do v1 <- suffixExpr + return $ (v1))) +suffixExpr :: forall str_48 s_49 . ListLike str_48 Char => + Parser (MemoTable_0 str_48) str_48 s_49 Expr +suffixExpr = memo tbl_suffixExpr $ (do v1 <- do v1 <- prefixExpr + return $ (v1) + v2 <- suffixExpr_tail + return (v2 v1)) +suffixExpr_tail :: forall str_50 s_51 . ListLike str_50 Char => + Parser (MemoTable_0 str_50) str_50 s_51 (Expr -> Expr) +suffixExpr_tail = memo tbl_suffixExpr_tail $ ((((do token skip delimiter (string "*") + v1 <- suffixExpr_tail + return (\v999 -> v1 (Many v999))) <|> (do token skip delimiter (string "+") + v1 <- suffixExpr_tail + return (\v999 -> v1 (Some v999)))) <|> (do token skip delimiter (string "?") + v1 <- suffixExpr_tail + return (\v999 -> v1 (Optional v999)))) <|> (do v1 <- return () + return id)) +prefixExpr :: forall str_52 s_53 . ListLike str_52 Char => + Parser (MemoTable_0 str_52) str_52 s_53 Expr +prefixExpr = memo tbl_prefixExpr $ (((do token skip delimiter (string "&") + v1 <- primExpr + return (And v1)) <|> (do token skip delimiter (string "!") + v1 <- primExpr + return (Not v1))) <|> (do v1 <- primExpr + return $ (v1))) +primExpr :: forall str_54 s_55 . ListLike str_54 Char => + Parser (MemoTable_0 str_54) str_54 s_55 Expr +primExpr = memo tbl_primExpr $ token skip delimiter (((((((((do string "\"" + v1 <- many charLit + string "\"" + return (Terminals True True v1)) <|> (do string "'" + v1 <- many charLit + string "'" + return (Terminals False False v1))) <|> (do string "[^" + v1 <- many range + string "]" + return (TerminalCmp v1))) <|> (do string "[" + v1 <- many range + string "]" + return (TerminalSet v1))) <|> (do token skip delimiter (string ".") + return TerminalAny)) <|> (do v1 <- ident + return (NonTerminal v1))) <|> (do token skip delimiter (string "(") + v1 <- expr + token skip delimiter (string ",") + v2 <- expr + token skip delimiter (string ")") + return (SepBy v1 v2))) <|> (do token skip delimiter (string "(") + v1 <- expr + token skip delimiter (string ";") + v2 <- expr + token skip delimiter (string ")") + return (SepBy1 v1 v2))) <|> (do token skip delimiter (string "(") + v1 <- expr + token skip delimiter (string ")") + return $ (v1))) +charLit :: forall str_56 s_57 . ListLike str_56 Char => + Parser (MemoTable_0 str_56) str_56 s_57 Char +charLit = memo tbl_charLit $ ((do string "\\" + v1 <- escChar + return $ (v1)) <|> (do unexpect (satisfy (\c -> (c == '\'') || (c == '"'))) + v1 <- anyChar + return $ (v1))) +escChar :: forall str_58 s_59 . ListLike str_58 Char => + Parser (MemoTable_0 str_58) str_58 s_59 Char +escChar = memo tbl_escChar $ (((((((do string "n" + return '\n') <|> (do string "r" + return '\r')) <|> (do string "t" + return '\t')) <|> (do string "\\" + return '\\')) <|> (do string "\"" + return '"')) <|> (do string "'" + return '\'')) <|> (do string "x" + v1 <- hexDigit + v2 <- hexDigit + return ((chr . (fst . (head . readHex))) $ [v1, + v2]))) +range :: forall str_60 s_61 . ListLike str_60 Char => + Parser (MemoTable_0 str_60) str_60 s_61 CharRange +range = memo tbl_range $ ((do v1 <- rchar + string "-" + v2 <- rchar + return (CharRange v1 v2)) <|> (do v1 <- rchar + return (CharOne v1))) +rchar :: forall str_62 s_63 . ListLike str_62 Char => + Parser (MemoTable_0 str_62) str_62 s_63 Char +rchar = memo tbl_rchar $ ((((((do string "\\" + v1 <- escChar + return $ (v1)) <|> (do string "\\]" + return ']')) <|> (do string "\\[" + return '[')) <|> (do string "\\^" + return '^')) <|> (do string "\\-" + return '-')) <|> (do v1 <- satisfy $ (not . (\c -> c == ']')) + return $ (v1))) +haskellType :: forall str_64 s_65 . ListLike str_64 Char => + Parser (MemoTable_0 str_64) str_64 s_65 TermType +haskellType = memo tbl_haskellType $ (do v1 <- some (satisfy $ (not . (\c -> c == '='))) + return $ (v1)) +codeFragment :: forall str_66 s_67 . ListLike str_66 Char => + Parser (MemoTable_0 str_66) str_66 s_67 CodeFragment +codeFragment = memo tbl_codeFragment $ (do v1 <- many codePart + return $ (v1)) +codePart :: forall str_68 s_69 . ListLike str_68 Char => + Parser (MemoTable_0 str_68) str_68 s_69 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_70 s_71 . ListLike str_70 Char => + Parser (MemoTable_0 str_70) str_70 s_71 CodePart +argument = memo tbl_argument $ ((((do string "$$" + v1 <- some digit + return (AntiArgument $ read v1)) <|> (do string "$" + v1 <- some digit + return (Argument $ read v1))) <|> (do string "$" + string "p" + return ArgPos)) <|> (do string "$" + string "s" + return ArgSpan)) +digit :: forall str_72 s_73 . ListLike str_72 Char => + Parser (MemoTable_0 str_72) str_72 s_73 Char +digit = memo tbl_digit $ (do v1 <- satisfy (\c -> ('0' <= c) && (c <= '9')) + return $ (v1)) +hexDigit :: forall str_74 s_75 . ListLike str_74 Char => + Parser (MemoTable_0 str_74) str_74 s_75 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_76 s_77 . ListLike str_76 Char => + Parser (MemoTable_0 str_76) str_76 s_77 String +ident = memo tbl_ident $ token skip delimiter (do v1 <- satisfy (\c -> (('a' <= c) && (c <= 'z')) || (c == '_')) + v2 <- many (satisfy (\c -> (((('0' <= c) && (c <= '9')) || (('a' <= c) && (c <= 'z'))) || (('A' <= c) && (c <= 'Z'))) || (c == '_'))) + return (v1 : v2)) +skip :: forall str_78 s_79 . ListLike str_78 Char => + Parser (MemoTable_0 str_78) str_78 s_79 () +skip = memo tbl_skip $ ((do satisfy (\c -> (((c == ' ') || (c == '\r')) || (c == '\n')) || (c == '\t')) + return $ ()) <|> (do v1 <- comment + return $ (v1))) +comment :: forall str_80 s_81 . ListLike str_80 Char => + Parser (MemoTable_0 str_80) str_80 s_81 () +comment = memo tbl_comment $ ((do v1 <- lineComment + return $ (v1)) <|> (do v1 <- regionComment + return $ (v1))) +lineComment :: forall str_82 s_83 . ListLike str_82 Char => + Parser (MemoTable_0 str_82) str_82 s_83 () +lineComment = memo tbl_lineComment $ (do string "--" + many (do unexpect (string "\n") + anyChar + return $ ()) + string "\n" + return $ ()) +regionComment :: forall str_84 s_85 . ListLike str_84 Char => + Parser (MemoTable_0 str_84) str_84 s_85 () +regionComment = memo tbl_regionComment $ (do string "{-" + many ((do v1 <- regionComment + return $ (v1)) <|> (do unexpect (string "-}") + anyChar + return $ ())) + string "-}" + return $ ()) diff --git a/Text/Peggy/Prim.hs b/Text/Peggy/Prim.hs --- a/Text/Peggy/Prim.hs +++ b/Text/Peggy/Prim.hs @@ -1,244 +1,244 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, 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(..), - - -- * Memoising combinator - memo, - - -- * Position functions - getPos, - setPos, - - -- * Combinators - anyChar, - satisfy, - char, - string, - - expect, - unexpect, - - -- * Utiligy - space, - defaultDelimiter, - token, - ) 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 - --- | 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 -> Char -> str -> ST s (Result str a) } - -data Result str a - = Parsed SrcPos Char str a - | Failed ParseError - -data ParseError - = ParseError SrcLoc String - deriving (Show) - -instance Error ParseError - -nullError :: ParseError -nullError = ParseError (LocPos $ SrcPos "" 0 1 1) "" - -errMerge :: ParseError -> ParseError -> ParseError -errMerge e1@(ParseError loc1 msg1) e2@(ParseError loc2 msg2) - | loc1 >= loc2 = e1 - | otherwise = e2 - -class MemoTable tbl where - newTable :: ST s (tbl s) - -instance Monad (Parser tbl str s) where - 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 q t x -> - unParser (f x) tbl qos q 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 prev s -> do - res <- unParser p tbl pos prev s - case res of - Parsed {} -> return res - Failed err -> unParser (h err) tbl pos prev s - -instance Alternative (Parser tbl str s) where - empty = throwError nullError - p <|> q = - catchError p $ \perr -> - catchError q $ \qerr -> - throwError $ perr `errMerge` qerr - -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 _ _) prev s -> do - cache <- HT.lookup (ft tbl) n - case cache of - Just v -> return v - Nothing -> do - v <- unParser p tbl pos prev s - HT.insert (ft tbl) n v - return v - -getPos :: Parser tbl str s SrcPos -getPos = Parser $ \_ pos prev str -> return $ Parsed pos prev str pos - -setPos :: SrcPos -> Parser tbl str s () -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 -> - if LL.null str - then return $ Failed nullError - else do - let c = LL.head str - cs = LL.tail str - return $ Parsed (pos `advance` c) c cs c - -satisfy :: LL.ListLike str Char => (Char -> Bool) -> Parser tbl str s Char -satisfy p = do - c <- anyChar - when (not $ p c) $ throwError nullError - 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 prev str -> do - res <- unParser p tbl pos prev str - return $ case res of - 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 (\c -> isPunctuation c || c == '+') - -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 <|> expect del <|> unexpect (satisfy $ check prev) - many sp - return ret - where - check pr cr - | isAlnum' pr && isAlnum' cr = True -- error "alnum" - | isDigit pr && isDigit cr = True -- error "digit" - | isGlyph pr && isGlyph cr = True -- error ("glyph " ++ show pr ++ ", " ++ show cr) - | otherwise = False - - isAlnum' c = isAlpha' c || isDigit c - isAlpha' c = isAlpha c || c == '_' - isGlyph c = isPrint c && not (isAlpha' c) && not (isDigit c) +{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, 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(..), + + -- * Memoising combinator + memo, + + -- * Position functions + getPos, + setPos, + + -- * Combinators + anyChar, + satisfy, + char, + string, + + expect, + unexpect, + + -- * Utiligy + space, + defaultDelimiter, + token, + ) 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 + +-- | 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 -> Char -> str -> ST s (Result str a) } + +data Result str a + = Parsed SrcPos Char str a + | Failed ParseError + +data ParseError + = ParseError SrcLoc String + deriving (Show) + +instance Error ParseError + +nullError :: ParseError +nullError = ParseError (LocPos $ SrcPos "" 0 1 1) "" + +errMerge :: ParseError -> ParseError -> ParseError +errMerge e1@(ParseError loc1 msg1) e2@(ParseError loc2 msg2) + | loc1 >= loc2 = e1 + | otherwise = e2 + +class MemoTable tbl where + newTable :: ST s (tbl s) + +instance Monad (Parser tbl str s) where + 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 q t x -> + unParser (f x) tbl qos q 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 prev s -> do + res <- unParser p tbl pos prev s + case res of + Parsed {} -> return res + Failed err -> unParser (h err) tbl pos prev s + +instance Alternative (Parser tbl str s) where + empty = throwError nullError + p <|> q = + catchError p $ \perr -> + catchError q $ \qerr -> + throwError $ perr `errMerge` qerr + +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 _ _) prev s -> do + cache <- HT.lookup (ft tbl) n + case cache of + Just v -> return v + Nothing -> do + v <- unParser p tbl pos prev s + HT.insert (ft tbl) n v + return v + +getPos :: Parser tbl str s SrcPos +getPos = Parser $ \_ pos prev str -> return $ Parsed pos prev str pos + +setPos :: SrcPos -> Parser tbl str s () +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 -> + if LL.null str + then return $ Failed nullError + else do + let c = LL.head str + cs = LL.tail str + return $ Parsed (pos `advance` c) c cs c + +satisfy :: LL.ListLike str Char => (Char -> Bool) -> Parser tbl str s Char +satisfy p = do + c <- anyChar + when (not $ p c) $ throwError nullError + 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 prev str -> do + res <- unParser p tbl pos prev str + return $ case res of + 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 (\c -> isPunctuation c || c == '+') + +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 <|> expect del <|> unexpect (satisfy $ check prev) + many sp + return ret + where + check pr cr + | isAlnum' pr && isAlnum' cr = True -- error "alnum" + | isDigit pr && isDigit cr = True -- error "digit" + | isGlyph pr && isGlyph cr = True -- error ("glyph " ++ show pr ++ ", " ++ show cr) + | otherwise = False + + isAlnum' c = isAlpha' c || isDigit c + isAlpha' c = isAlpha c || c == '_' + isGlyph c = isPrint c && not (isAlpha' c) && not (isDigit c) diff --git a/Text/Peggy/Quote.hs b/Text/Peggy/Quote.hs --- a/Text/Peggy/Quote.hs +++ b/Text/Peggy/Quote.hs @@ -1,134 +1,134 @@ -{-# 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 ( - -- * Quasiquoter - peggy, - peggyFile, - - -- * Parser and Quasiquoter generating function - genParser, - ) where - -import Language.Haskell.TH -import Language.Haskell.TH.Quote - -import Text.Peggy.Parser -import Text.Peggy.Prim -import Text.Peggy.Syntax -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 - 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 (locToPos loc) txt - -qExp :: String -> Q Exp -qExp txt = do - loc <- location - dataToExpQ (const Nothing) $ parseSyntax (locToPos loc) txt - --- | 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 - return $ concat qq ++ dec - --- - -parseSyntax :: SrcPos -> String -> Syntax -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) +{-# 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 ( + -- * Quasiquoter + peggy, + peggyFile, + + -- * Parser and Quasiquoter generating function + genParser, + ) where + +import Language.Haskell.TH +import Language.Haskell.TH.Quote + +import Text.Peggy.Parser +import Text.Peggy.Prim +import Text.Peggy.Syntax +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 + 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 (locToPos loc) txt + +qExp :: String -> Q Exp +qExp txt = do + loc <- location + dataToExpQ (const Nothing) $ parseSyntax (locToPos loc) txt + +-- | 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 + return $ concat qq ++ dec + +-- + +parseSyntax :: SrcPos -> String -> Syntax +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) diff --git a/Text/Peggy/SrcLoc.hs b/Text/Peggy/SrcLoc.hs --- a/Text/Peggy/SrcLoc.hs +++ b/Text/Peggy/SrcLoc.hs @@ -1,34 +1,34 @@ -{-# LANGUAGE DeriveDataTypeable #-} - -module Text.Peggy.SrcLoc ( - SrcLoc(..), - SrcPos(..), - - advance, - ) where - -import Data.Data - -data SrcLoc - = LocPos !SrcPos - | LocSpan !SrcPos !SrcPos - deriving (Show, Eq, Ord, Typeable, Data) - -data SrcPos = - SrcPos - { locFile :: !FilePath - , locAbs :: {-# UNPACK #-} !Int - , locLine :: {-# UNPACK #-} !Int - , locCol :: {-# UNPACK #-} !Int - } - deriving (Show, Eq, Ord, Typeable, Data) - -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) +{-# LANGUAGE DeriveDataTypeable #-} + +module Text.Peggy.SrcLoc ( + SrcLoc(..), + SrcPos(..), + + advance, + ) where + +import Data.Data + +data SrcLoc + = LocPos !SrcPos + | LocSpan !SrcPos !SrcPos + deriving (Show, Eq, Ord, Typeable, Data) + +data SrcPos = + SrcPos + { locFile :: !FilePath + , locAbs :: {-# UNPACK #-} !Int + , locLine :: {-# UNPACK #-} !Int + , locCol :: {-# UNPACK #-} !Int + } + deriving (Show, Eq, Ord, Typeable, Data) + +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) diff --git a/Text/Peggy/Syntax.hs b/Text/Peggy/Syntax.hs --- a/Text/Peggy/Syntax.hs +++ b/Text/Peggy/Syntax.hs @@ -1,64 +1,64 @@ -{-# LANGUAGE DeriveDataTypeable #-} - -module Text.Peggy.Syntax ( - Syntax, - Definition(..), - Expr(..), - CharRange(..), - CodeFragment, - CodePart(..), - Identifier, - TermType, - ) where - -import Data.Data - -type Syntax = [Definition] - -data Definition - = Definition Identifier TermType Expr - deriving (Show, Eq, Typeable, Data) - -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, Eq, Typeable, Data) - -data CharRange - = CharRange Char Char - | CharOne Char - deriving (Show, Eq, Typeable, Data) - -type CodeFragment = [CodePart] - -data CodePart - = Snippet String - | Argument Int - | AntiArgument Int - | ArgPos - | ArgSpan - deriving (Show, Eq, Typeable, Data) - -type Identifier = String -type TermType = String +{-# LANGUAGE DeriveDataTypeable #-} + +module Text.Peggy.Syntax ( + Syntax, + Definition(..), + Expr(..), + CharRange(..), + CodeFragment, + CodePart(..), + Identifier, + TermType, + ) where + +import Data.Data + +type Syntax = [Definition] + +data Definition + = Definition Identifier TermType Expr + deriving (Show, Eq, Typeable, Data) + +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, Eq, Typeable, Data) + +data CharRange + = CharRange Char Char + | CharOne Char + deriving (Show, Eq, Typeable, Data) + +type CodeFragment = [CodePart] + +data CodePart + = Snippet String + | Argument Int + | AntiArgument Int + | ArgPos + | ArgSpan + deriving (Show, Eq, Typeable, Data) + +type Identifier = String +type TermType = String diff --git a/bootstrap/Bootstrap.hs b/bootstrap/Bootstrap.hs --- a/bootstrap/Bootstrap.hs +++ b/bootstrap/Bootstrap.hs @@ -1,39 +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, 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 +{-# 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, 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 --- a/bootstrap/README.md +++ b/bootstrap/README.md @@ -1,10 +1,10 @@ -# Bootstrap Instructions # - -# Pre-requirement - -Previous version of peggy (>= 0.2.0.1) required. - -# Bootstrap - - $ cd bootstrap - $ runhaskell Bootstrap.hs > ../Text/Peggy/Parser.hs +# Bootstrap Instructions # + +# Pre-requirement + +Previous version of peggy (>= 0.2.0.1) required. + +# Bootstrap + + $ cd bootstrap + $ runhaskell Bootstrap.hs > ../Text/Peggy/Parser.hs diff --git a/bootstrap/Stage1.hs b/bootstrap/Stage1.hs --- a/bootstrap/Stage1.hs +++ b/bootstrap/Stage1.hs @@ -1,10 +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") +{-# 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 --- a/bootstrap/Stage2.hs +++ b/bootstrap/Stage2.hs @@ -1,13 +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) +{-# 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 --- a/bootstrap/peggy.peggy +++ b/bootstrap/peggy.peggy @@ -1,102 +1,102 @@ --- 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 - = (namedExpr !"::" !"=")+ { Sequence $1 } - -namedExpr :: Expr - = ident ":" suffixExpr { Named $1 $2 } - / suffixExpr - -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+ { AntiArgument $ read $1 } - / '$' digit+ { Argument $ read $1 } - / '$' 'p' { ArgPos } - / '$' 's' { ArgSpan } - -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 / !'-}' _:.)* '-}' +-- 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 + = (namedExpr !"::" !"=")+ { Sequence $1 } + +namedExpr :: Expr + = ident ":" suffixExpr { Named $1 $2 } + / suffixExpr + +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+ { AntiArgument $ read $1 } + / '$' digit+ { Argument $ read $1 } + / '$' 'p' { ArgPos } + / '$' 's' { ArgSpan } + +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/example/Main.hs b/example/Main.hs --- a/example/Main.hs +++ b/example/Main.hs @@ -1,31 +1,31 @@ -{-# LANGUAGE TemplateHaskell, QuasiQuotes, FlexibleContexts #-} - -module Main (main) where - -import Text.Peggy - -genParser [] [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 . parseString top "" =<< getContents +{-# LANGUAGE TemplateHaskell, QuasiQuotes, FlexibleContexts #-} + +module Main (main) where + +import Text.Peggy + +genParser [] [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 . parseString top "" =<< getContents diff --git a/peggy.cabal b/peggy.cabal --- a/peggy.cabal +++ b/peggy.cabal @@ -1,62 +1,62 @@ -Name: peggy -Version: 0.3.1.1 -Synopsis: The Parser Generator for Haskell - -Description: - - The Parser Generator for Haskell - - - -Homepage: http://tanakh.github.com/Peggy -License: BSD3 -License-file: LICENSE -Author: Hideyuki Tanaka -Maintainer: Hideyuki Tanaka -Copyright: Copyright (c)2011, Hideyuki Tanaka -Category: Language -Build-type: Simple -Cabal-version: >=1.8 - -Extra-source-files: README.md - bootstrap/README.md - bootstrap/Stage1.hs - bootstrap/Stage2.hs - bootstrap/Bootstrap.hs - bootstrap/peggy.peggy - -flag build-example - default: False - -Source-repository head - Type: git - Location: git://github.com/tanakh/Peggy.git - -Library - Exposed-modules: Text.Peggy - , Text.Peggy.CodeGen.TH - , Text.Peggy.LeftRec - , Text.Peggy.Normalize - , Text.Peggy.Parser - , Text.Peggy.Prim - , Text.Peggy.Quote - , Text.Peggy.SrcLoc - , Text.Peggy.Syntax - - Build-depends: base == 4.* - , mtl >= 2.0 - , ListLike == 3.1.* - , hashtables == 1.0.* - , monad-control == 0.3.* - , template-haskell >= 2.5 && < 2.8 - , haskell-src-meta == 0.5.* - -Executable peggy-example - Hs-source-dirs: example - Main-is: Main.hs - - Build-depends: base == 4.* - , peggy - - if !flag(build-example) - Buildable: False +Name: peggy +Version: 0.3.2 +Synopsis: The Parser Generator for Haskell + +Description: + + The Parser Generator for Haskell + + + +Homepage: http://tanakh.github.com/Peggy +License: BSD3 +License-file: LICENSE +Author: Hideyuki Tanaka +Maintainer: Hideyuki Tanaka +Copyright: Copyright (c)2011, Hideyuki Tanaka +Category: Language +Build-type: Simple +Cabal-version: >=1.8 + +Extra-source-files: README.md + bootstrap/README.md + bootstrap/Stage1.hs + bootstrap/Stage2.hs + bootstrap/Bootstrap.hs + bootstrap/peggy.peggy + +flag build-example + default: False + +Source-repository head + Type: git + Location: git://github.com/tanakh/Peggy.git + +Library + Exposed-modules: Text.Peggy + , Text.Peggy.CodeGen.TH + , Text.Peggy.LeftRec + , Text.Peggy.Normalize + , Text.Peggy.Parser + , Text.Peggy.Prim + , Text.Peggy.Quote + , Text.Peggy.SrcLoc + , Text.Peggy.Syntax + + Build-depends: base == 4.* + , mtl >= 2.0 + , ListLike == 3.1.* + , hashtables == 1.0.* + , monad-control == 0.3.* + , template-haskell >= 2.5 && < 2.9 + , haskell-src-meta >= 0.5 + +Executable peggy-example + Hs-source-dirs: example + Main-is: Main.hs + + Build-depends: base == 4.* + , peggy + + if !flag(build-example) + Buildable: False