diff --git a/Language/SQL/SimpleSQL/Parser.lhs b/Language/SQL/SimpleSQL/Parser.lhs index 7a4c69c..b7a6507 100644 --- a/Language/SQL/SimpleSQL/Parser.lhs +++ b/Language/SQL/SimpleSQL/Parser.lhs @@ -3,10 +3,11 @@ > module Language.SQL.SimpleSQL.Parser > (parseQueryExpr > ,parseScalarExpr -> ,ParseError) where +> ,ParseError(..)) where > import Text.Groom -> import Text.Parsec +> import Text.Parsec hiding (ParseError) +> import qualified Text.Parsec as P > import Control.Monad.Identity > import Control.Applicative hiding (many, (<|>), optional) > import qualified Language.Haskell.Exts.Syntax as HSE @@ -16,12 +17,69 @@ > import Language.SQL.SimpleSQL.Syntax -> parseQueryExpr :: FilePath -> Maybe (Int,Int) -> String -> Either ParseError QueryExpr -> parseQueryExpr _ _ = parse (whiteSpace *> queryExpr <* eof) "" +> parseQueryExpr :: FilePath +> -> 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 _ _ = parse (whiteSpace *> scalarExpr <* eof) "" +> parseScalarExpr :: FilePath +> -> 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 diff --git a/Tests.lhs b/Tests.lhs index 1564f11..8db8bfb 100644 --- a/Tests.lhs +++ b/Tests.lhs @@ -401,8 +401,8 @@ > itemToTest (ParseQueryExpr str) = > toPTest parseQueryExpr prettyQueryExpr str -> toTest :: (Eq a, Show a, Show e) => -> (String -> Maybe (Int,Int) -> String -> Either e a) +> toTest :: (Eq a, Show a) => +> (String -> Maybe (Int,Int) -> String -> Either ParseError a) > -> (a -> String) > -> String > -> a @@ -410,27 +410,27 @@ > toTest parser pp str expected = H.TestLabel str $ H.TestCase $ do > let egot = parser "" Nothing str > case egot of -> Left e -> H.assertFailure $ show e +> Left e -> H.assertFailure $ peFormattedError e > Right got -> do > H.assertEqual "" expected got > let str' = pp got > let egot' = parser "" Nothing str' > 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' -> toPTest :: (Eq a, Show a, Show e) => -> (String -> Maybe (Int,Int) -> String -> Either e a) +> toPTest :: (Eq a, Show a) => +> (String -> Maybe (Int,Int) -> String -> Either ParseError a) > -> (a -> String) > -> String > -> H.Test > toPTest parser pp str = H.TestLabel str $ H.TestCase $ do > let egot = parser "" Nothing str > case egot of -> Left e -> H.assertFailure $ show e +> Left e -> H.assertFailure $ peFormattedError e > Right got -> do > let str' = pp got > let egot' = parser "" Nothing str' > case egot' of -> Left e' -> H.assertFailure $ "pp roundtrip " ++ show e' -> Right got' -> return () +> Left e' -> H.assertFailure $ "pp roundtrip " ++ peFormattedError e' +> Right _got' -> return ()