peggy 0.1.1 → 0.1.2
raw patch · 8 files changed
+98/−28 lines, 8 files
Files
- Main.hs +3/−3
- Text/Peggy.hs +2/−0
- Text/Peggy/CodeGen/TH.hs +25/−4
- Text/Peggy/Prim.hs +18/−4
- Text/Peggy/Quote.hs +35/−10
- Text/Peggy/SrcLoc.hs +6/−2
- Text/Peggy/Syntax.hs +8/−4
- peggy.cabal +1/−1
Main.hs view
@@ -1,11 +1,11 @@-{-# Language QuasiQuotes #-}+{-# Language TemplateHaskell, QuasiQuotes #-} {-# Language FlexibleContexts #-} module Main (main) where import Text.Peggy -[peggy|+genParser [("qqexpr", "top")] [peggy| -- Simple Arithmetic Expression Parser top :: Double = expr !.@@ -29,4 +29,4 @@ |] main :: IO ()-main = print . parse top =<< getContents+main = print . parse top (SrcPos "<stdin>" 0 1 1) =<< getContents
Text/Peggy.hs view
@@ -1,9 +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
Text/Peggy/CodeGen/TH.hs view
@@ -3,8 +3,8 @@ {-# Language FlexibleContexts #-} module Text.Peggy.CodeGen.TH (- genCode,- removeLeftRecursion,+ genDecs,+ genQQ, ) where import Control.Applicative@@ -13,14 +13,35 @@ import qualified Data.ListLike as LL import Language.Haskell.Meta import Language.Haskell.TH+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 -genCode :: Syntax -> Q [Dec]-genCode = generate . removeLeftRecursion . normalize+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 -> dataToExpQ (const Nothing) a + |]+ u <- [| undefined |]+ recConE 'QuasiQuoter [ return ('quoteExp, e)+ , return ('quoteDec, u)+ , return ('quotePat, u)+ , return ('quoteType, u)+ ]++genDecs :: Syntax -> Q [Dec]+genDecs = generate . removeLeftRecursion . normalize generate :: Syntax -> Q [Dec] generate defs = do
Text/Peggy/Prim.hs view
@@ -11,6 +11,9 @@ memo, parse, + getPos,+ setPos,+ anyChar, satisfy, char,@@ -47,6 +50,10 @@ nullError :: ParseError nullError = ParseError (LocPos $ SrcPos "" 0 1 1) "" +errMerge e1@(ParseError loc1 msg1) e2@(ParseError loc2 msg2)+ | loc1 >= loc2 = e1+ | otherwise = e2+ class MemoTable tbl where newTable :: ST s (tbl s) @@ -80,7 +87,10 @@ instance Alternative (Parser tbl str s) where empty = throwError nullError- p <|> q = catchError p (const q)+ 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 @@ -96,11 +106,12 @@ parse :: MemoTable tbl => (forall s . Parser tbl str s a)+ -> SrcPos -> str -> Either ParseError a-parse p str = runST $ do+parse p pos str = runST $ do tbl <- newTable- res <- unParser p tbl (SrcPos "<input>" 0 1 1) str+ res <- unParser p tbl pos str case res of Parsed _ _ ret -> return $ Right ret Failed err -> return $ Left err@@ -108,6 +119,9 @@ getPos :: Parser tbl str s SrcPos getPos = Parser $ \_ pos str -> return $ Parsed pos str pos +setPos :: SrcPos -> Parser tbl str s ()+setPos pos = Parser $ \_ _ str -> return $ Parsed pos str ()+ parseError :: String -> Parser tbl str s a parseError msg = throwError =<< ParseError . LocPos <$> getPos <*> pure msg@@ -124,7 +138,7 @@ satisfy :: LL.ListLike str Char => (Char -> Bool) -> Parser tbl str s Char satisfy p = do c <- anyChar- when (not $ p c) $ parseError "unexpected input"+ when (not $ p c) $ throwError nullError return c char :: LL.ListLike str Char => Char -> Parser tbl str s Char
Text/Peggy/Quote.hs view
@@ -1,6 +1,10 @@+{-# Language RankNTypes #-}+ module Text.Peggy.Quote ( peggy,- peggy_f,+ peggyFile,+ + genParser, ) where import Language.Haskell.TH@@ -9,19 +13,40 @@ import Text.Parsec.Pos import Text.Peggy.Parser+import Text.Peggy.Syntax+import Text.Peggy.SrcLoc import Text.Peggy.CodeGen.TH peggy :: QuasiQuoter-peggy = QuasiQuoter { quoteDec = quote, quoteExp = undefined, quotePat = undefined, quoteType = undefined }+peggy = QuasiQuoter { quoteDec = qDecs, quoteExp = qExp, quotePat = undefined, quoteType = undefined } -peggy_f :: QuasiQuoter-peggy_f = quoteFile peggy+peggyFile :: FilePath -> Q Exp+peggyFile filename = do+ txt <- runIO $ readFile filename+ case parse syntax filename txt of+ Left err -> error $ show err+ Right syn -> dataToExpQ (const Nothing) syn -quote :: String -> Q [Dec]-quote txt = do+qDecs :: String -> Q [Dec]+qDecs txt = do loc <- location- case parse (setPosition (initPos loc) >> syntax) (loc_filename loc) txt of+ genDecs $ parseSyntax (SrcPos (loc_filename loc) 0 (fst $ loc_start loc) (snd $ loc_start loc)) txt++qExp :: String -> Q Exp+qExp txt = do+ loc <- location+ dataToExpQ (const Nothing) $ parseSyntax (SrcPos (loc_filename loc) 0 (fst $ loc_start loc) (snd $ loc_start loc)) txt++genParser :: [(String, String)] -> Syntax -> Q [Dec]+genParser qqs syn = do+ qq <- mapM (genQQ syn) qqs+ dec <- genDecs syn+ return $ concat qq ++ dec++--++parseSyntax :: SrcPos -> String -> Syntax+parseSyntax (SrcPos fname _ lno cno) txt =+ case parse (setPosition (newPos fname lno cno) >> syntax) fname txt of Left err -> error $ "peggy syntax-error: " ++ show err- Right defs -> genCode defs- where- initPos loc = newPos (loc_filename loc) (fst $ loc_start loc) (snd $ loc_start loc)+ Right defs -> defs
Text/Peggy/SrcLoc.hs view
@@ -1,3 +1,5 @@+{-# Language DeriveDataTypeable #-}+ module Text.Peggy.SrcLoc ( SrcLoc(..), SrcPos(..),@@ -5,10 +7,12 @@ advance, ) where +import Data.Data+ data SrcLoc = LocPos !SrcPos | LocSpan !SrcPos !SrcPos- deriving (Show)+ deriving (Show, Eq, Ord, Typeable, Data) data SrcPos = SrcPos@@ -17,7 +21,7 @@ , locLine :: {-# UNPACK #-} !Int , locCol :: {-# UNPACK #-} !Int }- deriving (Show)+ deriving (Show, Eq, Ord, Typeable, Data) tabWidth :: Int tabWidth = 8
Text/Peggy/Syntax.hs view
@@ -1,3 +1,5 @@+{-# Language DeriveDataTypeable #-}+ module Text.Peggy.Syntax ( Syntax, Definition(..),@@ -9,11 +11,13 @@ HaskellType, ) where +import Data.Data+ type Syntax = [Definition] data Definition = Definition Identifier HaskellType Expr- deriving (Show)+ deriving (Show, Typeable, Data) data Expr = Terminals Bool Bool String@@ -39,19 +43,19 @@ | Token Expr | Semantic Expr CodeFragment- deriving (Show)+ deriving (Show, Typeable, Data) data CharRange = CharRange Char Char | CharOne Char- deriving (Show)+ deriving (Show, Typeable, Data) type CodeFragment = [CodePart] data CodePart = Snippet String | Argument Int- deriving (Show)+ deriving (Show, Typeable, Data) type Identifier = String type HaskellType = String
peggy.cabal view
@@ -1,5 +1,5 @@ Name: peggy-Version: 0.1.1+Version: 0.1.2 Synopsis: The Parser Generator for Haskell Description: The Parser Generator for Haskell