diff --git a/Language/SQL/SimpleSQL/Parser.lhs b/Language/SQL/SimpleSQL/Parser.lhs index 377c660..2eea14b 100644 --- a/Language/SQL/SimpleSQL/Parser.lhs +++ b/Language/SQL/SimpleSQL/Parser.lhs @@ -119,7 +119,7 @@ which parses as a typed literal > mkIt <$> stringToken > <*> optionMaybe > ((,) <$> identifierBlacklist blacklist -> <*> optionMaybe (parens integer)) +> <*> optionMaybe (parens unsignedInteger)) > where > mkIt val Nothing = TypedLit (TypeName "interval") val > mkIt val (Just (a,b)) = IntervalLit val a b @@ -541,7 +541,7 @@ todo: timestamp types: | TIMESTAMParser [ ] [ WITH TIME ZONE ] -> precision t = parens (commaSep integer) >>= makeWrap t +> precision t = parens (commaSep unsignedInteger) >>= makeWrap t > makeWrap (TypeName t) [a] = return $ PrecTypeName t a > makeWrap (TypeName t) [a,b] = return $ PrecScaleTypeName t a b > makeWrap _ _ = fail "there must be one or two precision components" @@ -574,8 +574,8 @@ There is probably a simpler way of doing this but I am a bit thick. > makeKeywordTree :: [String] -> Parser [String] -> makeKeywordTree sets = do -> reverse <$> parseTrees (sort $ map words sets) +> makeKeywordTree sets = +> parseTrees (sort $ map words sets) > -- ?? intercalate "," sets > where > parseTrees :: [[String]] -> Parser [String] @@ -584,14 +584,14 @@ thick. > gs = groupBy ((==) `on` head) ws > choice $ map parseGroup gs > parseGroup :: [[String]] -> Parser [String] -> parseGroup l = do -> let k = head $ head l +> parseGroup l@((k:_):_) = do > keyword_ k > let tls = map tail l > pr = (k:) <$> parseTrees tls > if (or $ map null tls) > then pr <|> return [k] > else pr +> parseGroup _ = guard False >> error "impossible" == operator parsing @@ -673,12 +673,12 @@ messages, but both of these are considered too important. > binaryKeyword nm assoc = binary (keyword_ nm) nm assoc > binaryKeywords p = > E.Infix (do -> o <- p +> o <- try p > return (\a b -> BinOp a [Name $ unwords o] b)) > E.AssocNone > postfixKeywords p = > postfix' $ do -> o <- p +> o <- try p > return $ PostfixOp [Name $ unwords o] > binary p nm assoc = > E.Infix (p >> return (\a b -> BinOp a [Name nm] b)) assoc @@ -979,8 +979,8 @@ whitespace parser which skips comments also > lexeme :: Parser a -> Parser a > lexeme p = p <* whitespace -> integer :: Parser Integer -> integer = read <$> lexeme (many1 digit) "integer" +> unsignedInteger :: Parser Integer +> unsignedInteger = read <$> lexeme (many1 digit) "integer" number literals diff --git a/Language/SQL/SimpleSQL/Pretty.lhs b/Language/SQL/SimpleSQL/Pretty.lhs index 98cc3e1..4ab6166 100644 --- a/Language/SQL/SimpleSQL/Pretty.lhs +++ b/Language/SQL/SimpleSQL/Pretty.lhs @@ -40,15 +40,13 @@ which have been changed to try to improve the layout of the output. > valueExpr (IntervalLit v u p) = > text "interval" <+> quotes (text v) > <+> text u -> <+> maybe empty (parens . text . show ) p +> <+> me (parens . text . show ) p > valueExpr (Iden i) = names i > valueExpr Star = text "*" > valueExpr Parameter = text "?" > valueExpr (HostParameter p i) = > text (':':p) -> <+> maybe empty -> (\i' -> text "indicator" <+> text (':':i')) -> i +> <+> me (\i' -> text "indicator" <+> text (':':i')) i > valueExpr (App f es) = names f <> parens (commaSep (map valueExpr es)) @@ -69,7 +67,7 @@ which have been changed to try to improve the layout of the output. > _ -> text "partition by" > <+> nest 13 (commaSep $ map valueExpr pb)) > <+> orderBy od -> <+> maybe empty frd fr) +> <+> me frd fr) > where > frd (FrameFrom rs fp) = rsd rs <+> fpd fp > frd (FrameBetween rs fps fpe) = @@ -120,7 +118,7 @@ which have been changed to try to improve the layout of the output. > valueExpr e0 <+> names f <+> valueExpr e1 > valueExpr (Case t ws els) = -> sep $ [text "case" <+> maybe empty valueExpr t] +> sep $ [text "case" <+> me valueExpr t] > ++ map w ws > ++ maybeToList (fmap e els) > ++ [text "end"] @@ -231,9 +229,9 @@ which have been changed to try to improve the layout of the output. > ,grpBy gb > ,maybeValueExpr "having" hv > ,orderBy od -> ,maybe empty (\e -> text "offset" <+> valueExpr e <+> text "rows") off -> ,maybe empty (\e -> text "fetch first" <+> valueExpr e -> <+> text "rows only") fe +> ,me (\e -> text "offset" <+> valueExpr e <+> text "rows") off +> ,me (\e -> text "fetch first" <+> valueExpr e +> <+> text "rows only") fe > ] > queryExpr (CombineQueryExpr q1 ct d c q2) = > sep [queryExpr q1 @@ -264,12 +262,12 @@ which have been changed to try to improve the layout of the output. > alias :: Alias -> Doc > alias (Alias nm cols) = > text "as" <+> name nm -> <+> maybe empty (parens . commaSep . map name) cols +> <+> me (parens . commaSep . map name) cols > selectList :: [(ValueExpr,Maybe Name)] -> Doc > selectList is = commaSep $ map si is > where -> si (e,al) = valueExpr e <+> maybe empty als al +> si (e,al) = valueExpr e <+> me als al > als al = text "as" <+> name al > from :: [TableRef] -> Doc @@ -307,7 +305,7 @@ which have been changed to try to improve the layout of the output. > joinCond (Just JoinNatural) = empty > maybeValueExpr :: String -> Maybe ValueExpr -> Doc -> maybeValueExpr k = maybe empty +> maybeValueExpr k = me > (\e -> sep [text k > ,nest (length k + 1) $ valueExpr e]) @@ -342,3 +340,6 @@ which have been changed to try to improve the layout of the output. > commaSep :: [Doc] -> Doc > commaSep ds = sep $ punctuate comma ds + +> me :: (a -> Doc) -> Maybe a -> Doc +> me = maybe empty diff --git a/Language/SQL/SimpleSQL/Syntax.lhs b/Language/SQL/SimpleSQL/Syntax.lhs index e035a01..bb71af7 100644 --- a/Language/SQL/SimpleSQL/Syntax.lhs +++ b/Language/SQL/SimpleSQL/Syntax.lhs @@ -127,12 +127,12 @@ > -- Maybe String is for the > -- indicator, e.g. :var > -- indicator :nl -> | QuantifiedComparison +> | QuantifiedComparison > ValueExpr > [Name] -- operator > CompPredQuantifier > QueryExpr -> | Match ValueExpr Bool -- true if unique +> | Match ValueExpr Bool -- true if unique > QueryExpr > | Array ValueExpr [ValueExpr] -- ^ represents an array > -- access expression, or an array ctor @@ -157,7 +157,6 @@ > | PrecScaleTypeName String Integer Integer > deriving (Eq,Show,Read,Data,Typeable) - > -- | Used for 'expr in (value expression list)', and 'expr in > -- (subquery)' syntax. > data InPredValue = InList [ValueExpr]