diff --git a/Language/SQL/SimpleSQL/Parse.hs b/Language/SQL/SimpleSQL/Parse.hs index 4d582b0..62b6a61 100644 --- a/Language/SQL/SimpleSQL/Parse.hs +++ b/Language/SQL/SimpleSQL/Parse.hs @@ -192,8 +192,9 @@ module Language.SQL.SimpleSQL.Parse ) where import Text.Megaparsec - (Parsec - ,ParsecT + (ParsecT + ,runParserT + ,Stream(..) ,PosState(..) ,TraversableStream(..) @@ -205,7 +206,6 @@ import Text.Megaparsec ,ParseErrorBundle(..) ,errorBundlePretty - ,parse ,() ,(<|>) @@ -223,6 +223,12 @@ import Text.Megaparsec ) import qualified Control.Monad.Combinators.Expr as E +import Control.Monad.Reader + (Reader(..) + ,runReader + ,ask + ) + import qualified Data.List as DL import qualified Data.List.NonEmpty as NE import qualified Data.Set as Set @@ -327,8 +333,8 @@ wrapParse :: Parser a -> Either ParseError a wrapParse parser d f p src = let lx = either (error . show) id $ L.lexSQL d f p src - in parse (parser <* (eof "")) (T.unpack f) - $ MyStream (T.unpack src) $ filter notSpace lx + in runReader (runParserT (parser <* (eof "")) (T.unpack f) + $ MyStream (T.unpack src) $ filter notSpace lx) d where notSpace = notSpace' . L.tokenVal notSpace' (L.Whitespace {}) = False @@ -340,7 +346,7 @@ wrapParse parser d f p src = -- parsing code -type Parser = Parsec Void MyStream +type Parser = ParsecT Void MyStream (Reader Dialect) {- ------------------------------------------------ @@ -1158,7 +1164,7 @@ wanted to avoid extensibility and to not be concerned with parse error messages, but both of these are too important. -} -opTable :: Bool -> [[E.Operator (ParsecT Void MyStream Identity) ScalarExpr]] +opTable :: Bool -> [[E.Operator Parser ScalarExpr]] opTable bExpr = [] {- [-- parse match and quantified comparisons as postfix ops -- todo: left factor the quantified comparison with regular @@ -2110,7 +2116,7 @@ makeKeywordTree sets = if (or $ map null tls) then pr <|> pure [k] else pr - parseGroup _ = guard False >> error "impossible" + parseGroup _ = guard False >> fail "impossible" safeHead (x:_) = Just x safeHead [] = Nothing safeTail (_:x) = Just x @@ -2378,11 +2384,14 @@ unquotedIdentifierTok blackList kw = token test Set.empty "" -- dialect guardDialect :: (Dialect -> Bool) -> Parser () -guardDialect = error "guardDialect" +guardDialect p = do + d <- ask + guard (p d) queryDialect :: (Dialect -> a) -> Parser a -queryDialect = error "queryDialect" - +queryDialect f = do + d <- ask + pure $ f d ------------------------------------------------------------------------------