starlitcanopy/simple-sql-parser
1
Fork 0
Code Activity

work on errors

Browse source
This commit is contained in:
Jake Wheat 2013-12-13 19:21:44 +02:00
parent aa26603a0c
commit ed47656a0c
2 changed files with 73 additions and 15 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

70
Language/SQL/SimpleSQL/Parser.lhs
View file

@ -3,10 +3,11 @@
> module Language.SQL.SimpleSQL.Parser > module Language.SQL.SimpleSQL.Parser
> (parseQueryExpr > (parseQueryExpr
> ,parseScalarExpr > ,parseScalarExpr
> ,ParseError) where > ,ParseError(..)) where
> import Text.Groom > import Text.Groom
> import Text.Parsec > import Text.Parsec hiding (ParseError)
> import qualified Text.Parsec as P
> import Control.Monad.Identity > import Control.Monad.Identity
> import Control.Applicative hiding (many, (<|>), optional) > import Control.Applicative hiding (many, (<|>), optional)
> import qualified Language.Haskell.Exts.Syntax as HSE > import qualified Language.Haskell.Exts.Syntax as HSE
@ -16,12 +17,69 @@
> import Language.SQL.SimpleSQL.Syntax > import Language.SQL.SimpleSQL.Syntax
> parseQueryExpr :: FilePath -> Maybe (Int,Int) -> String -> Either ParseError QueryExpr > parseQueryExpr :: FilePath
> parseQueryExpr _ _ = parse (whiteSpace *> queryExpr <* eof) "" > -> Maybe (Int,Int)
> -> String
> -> Either ParseError QueryExpr
> parseQueryExpr f p src =
> either (Left . convParseError src) Right
> $ parse (setPos f p *> whiteSpace
> *> queryExpr <* eof) "" src
> parseScalarExpr :: FilePath -> Maybe (Int,Int) -> String -> Either ParseError ScalarExpr > parseScalarExpr :: FilePath
> parseScalarExpr _ _ = parse (whiteSpace *> scalarExpr <* eof) "" > -> Maybe (Int,Int)
> -> String
> -> Either ParseError ScalarExpr
> parseScalarExpr f p src =
> either (Left . convParseError src) Right
> $ parse (setPos f p *> whiteSpace
> *> scalarExpr <* eof) "" src
> setPos :: FilePath -> Maybe (Int,Int) -> P ()
> setPos f p = do
> sp <- getPosition
> let sp' = setSourceName sp f
> sp'' = maybe sp'
> (\(l,c) -> flip setSourceColumn c
> $ setSourceLine sp' l)
> p
> setPosition sp''
> data ParseError = ParseError
> {peErrorString :: String
> ,peFilename :: FilePath
> ,pePosition :: (Int,Int)
> ,peFormattedError :: String}
> convParseError :: String -> P.ParseError -> ParseError
> convParseError src e =
> ParseError
> {peErrorString = show e
> ,peFilename = sourceName p
> ,pePosition = (sourceLine p, sourceColumn p)
> ,peFormattedError = formatError src e
> }
> where
> p = errorPos e
format the error more nicely: emacs format for positioning, plus context
> formatError :: String -> P.ParseError -> String
> formatError src e =
> sourceName p ++ ":" ++ show (sourceLine p)
> ++ ":" ++ show (sourceColumn p) ++ ":"
> ++ context
> ++ show e
> where
> context =
> let lns = take 1 $ drop (sourceLine p - 1) $ lines src
> in case lns of
> [x] -> "\n" ++ x ++ "\n"
> ++ replicate (sourceColumn p - 1) ' ' ++ "^\n"
> _ -> ""
> p = errorPos e
Language/SQL/SimpleSQL/Parser.lhs:54:3:
> type P a = ParsecT String () Identity a > type P a = ParsecT String () Identity a

18
Tests.lhs
View file

@ -401,8 +401,8 @@
> itemToTest (ParseQueryExpr str) = > itemToTest (ParseQueryExpr str) =
> toPTest parseQueryExpr prettyQueryExpr str > toPTest parseQueryExpr prettyQueryExpr str
> toTest :: (Eq a, Show a, Show e) => > toTest :: (Eq a, Show a) =>
> (String -> Maybe (Int,Int) -> String -> Either e a) > (String -> Maybe (Int,Int) -> String -> Either ParseError a)
> -> (a -> String) > -> (a -> String)
> -> String > -> String
> -> a > -> a
@ -410,27 +410,27 @@
> toTest parser pp str expected = H.TestLabel str $ H.TestCase $ do > toTest parser pp str expected = H.TestLabel str $ H.TestCase $ do
> let egot = parser "" Nothing str > let egot = parser "" Nothing str
> case egot of > case egot of
> Left e -> H.assertFailure $ show e > Left e -> H.assertFailure $ peFormattedError e
> Right got -> do > Right got -> do
> H.assertEqual "" expected got > H.assertEqual "" expected got
> let str' = pp got > let str' = pp got
> let egot' = parser "" Nothing str' > let egot' = parser "" Nothing str'
> case egot' of > case egot' of
> Left e' -> H.assertFailure $ "pp roundtrip " ++ show e' > Left e' -> H.assertFailure $ "pp roundtrip " ++ peFormattedError e'
> Right got' -> H.assertEqual "pp roundtrip" expected got' > Right got' -> H.assertEqual "pp roundtrip" expected got'
> toPTest :: (Eq a, Show a, Show e) => > toPTest :: (Eq a, Show a) =>
> (String -> Maybe (Int,Int) -> String -> Either e a) > (String -> Maybe (Int,Int) -> String -> Either ParseError a)
> -> (a -> String) > -> (a -> String)
> -> String > -> String
> -> H.Test > -> H.Test
> toPTest parser pp str = H.TestLabel str $ H.TestCase $ do > toPTest parser pp str = H.TestLabel str $ H.TestCase $ do
> let egot = parser "" Nothing str > let egot = parser "" Nothing str
> case egot of > case egot of
> Left e -> H.assertFailure $ show e > Left e -> H.assertFailure $ peFormattedError e
> Right got -> do > Right got -> do
> let str' = pp got > let str' = pp got
> let egot' = parser "" Nothing str' > let egot' = parser "" Nothing str'
> case egot' of > case egot' of
> Left e' -> H.assertFailure $ "pp roundtrip " ++ show e' > Left e' -> H.assertFailure $ "pp roundtrip " ++ peFormattedError e'
> Right got' -> return () > Right _got' -> return ()