From 7d094182b762ffc4a7f469dc4b384eb396cfd236 Mon Sep 17 00:00:00 2001 From: Jake Wheat Date: Tue, 17 Dec 2013 18:42:00 +0200 Subject: [PATCH] add support for multiple case when expressions --- Language/SQL/SimpleSQL/Fixity.lhs | 8 +++---- Language/SQL/SimpleSQL/Parser.lhs | 3 ++- Language/SQL/SimpleSQL/Pretty.lhs | 2 +- Language/SQL/SimpleSQL/Syntax.lhs | 2 +- TODO | 23 +++++--------------- tools/Language/SQL/SimpleSQL/ScalarExprs.lhs | 21 ++++++++++++------ 6 files changed, 28 insertions(+), 31 deletions(-) diff --git a/Language/SQL/SimpleSQL/Fixity.lhs b/Language/SQL/SimpleSQL/Fixity.lhs index 3080016..1a4e63d 100644 --- a/Language/SQL/SimpleSQL/Fixity.lhs +++ b/Language/SQL/SimpleSQL/Fixity.lhs @@ -102,7 +102,7 @@ the fixity code. > -- map the two maybes to lists with either 0 or 1 element > Case v ts el -> HSE.App (var "$case") > (HSE.List [ltoh $ maybeToList v -> ,HSE.List $ map (ltoh . (\(a,b) -> [a,b])) ts +> ,HSE.List $ map (ltoh . (\(a,b) -> b:a)) ts > ,ltoh $ maybeToList el]) > Cast e0 tn -> HSE.App (str ('c':show tn)) $ toHaskell e0 > TypedLit {} -> str ('v':show e) @@ -158,7 +158,7 @@ the fixity code. > SpecialOp (unname nm) $ map toSql es > HSE.App (HSE.Var (HSE.UnQual (HSE.Ident "$case"))) > (HSE.List [v,ts,el]) -> -> Case (ltom v) (pairs ts) (ltom el) +> Case (ltom v) (whens ts) (ltom el) > HSE.App (HSE.Lit (HSE.String ('c':nm))) e0 -> > Cast (toSql e0) (read nm) > HSE.App (HSE.Lit (HSE.String ('i':nm))) @@ -173,8 +173,8 @@ the fixity code. > ltom (HSE.List []) = Nothing > ltom (HSE.List [ex]) = Just $ toSql ex > ltom ex = err ex -> pairs (HSE.List l) = map (\(HSE.List [a,b]) -> (toSql a, toSql b)) l -> pairs ex = err ex +> whens (HSE.List l) = map (\(HSE.List (t:ws)) -> (map toSql ws, toSql t)) l +> whens ex = err ex > err :: Show a => a -> e > err a = error $ "simple-sql-parser: internal fixity error " ++ show a > unname ('"':nm) = QName nm diff --git a/Language/SQL/SimpleSQL/Parser.lhs b/Language/SQL/SimpleSQL/Parser.lhs index ff68de3..817357c 100644 --- a/Language/SQL/SimpleSQL/Parser.lhs +++ b/Language/SQL/SimpleSQL/Parser.lhs @@ -222,7 +222,8 @@ always used with the optionSuffix combinator. > <* keyword_ "end" > where > swhen = keyword_ "when" *> -> ((,) <$> scalarExpr' <*> (keyword_ "then" *> scalarExpr')) +> ((,) <$> commaSep1 scalarExpr' +> <*> (keyword_ "then" *> scalarExpr')) == miscellaneous keyword operators diff --git a/Language/SQL/SimpleSQL/Pretty.lhs b/Language/SQL/SimpleSQL/Pretty.lhs index e3e15f3..3b20f62 100644 --- a/Language/SQL/SimpleSQL/Pretty.lhs +++ b/Language/SQL/SimpleSQL/Pretty.lhs @@ -124,7 +124,7 @@ > ++ [text "end"] > where > w (t0,t1) = -> text "when" <+> nest 5 (scalarExpr t0) +> text "when" <+> nest 5 (commaSep $ map scalarExpr t0) > <+> text "then" <+> nest 5 (scalarExpr t1) > e el = text "else" <+> nest 5 (scalarExpr el) > scalarExpr (Parens e) = parens $ scalarExpr e diff --git a/Language/SQL/SimpleSQL/Syntax.lhs b/Language/SQL/SimpleSQL/Syntax.lhs index ad7141a..82669e4 100644 --- a/Language/SQL/SimpleSQL/Syntax.lhs +++ b/Language/SQL/SimpleSQL/Syntax.lhs @@ -99,7 +99,7 @@ > -- a=4,b=5 then x end) > | Case > {caseTest :: Maybe ScalarExpr -- ^ test value -> ,caseWhens :: [(ScalarExpr,ScalarExpr)] -- ^ when branches +> ,caseWhens :: [([ScalarExpr],ScalarExpr)] -- ^ when branches > ,caseElse :: Maybe ScalarExpr -- ^ else value > } > | Parens ScalarExpr diff --git a/TODO b/TODO index 00d1d2e..23f641b 100644 --- a/TODO +++ b/TODO @@ -1,24 +1,11 @@ next release: -more symbolic operators, array access a[5]? don't think this is - standard sql, if not, leave for now. There is something about - arrays in sql:2008 - -row ctor: row(a,b) is fine, but also when there is 2 or more elements, - the word row can be omitted: (a,b) - -fix lateral binding issue - -window frames - review tests to copy from hssqlppp -order by nulls first/last -extend case group by extensions. Question: some of the syntax can be represented by app and row ctor, should this be reused or new syntax created - (the standard has special syntax for cube and rollup). + (the standard has special grammar for cube and rollup). collate? -> postfix operator which binds very tightly: a < 'foo' collate 'C' @@ -28,12 +15,10 @@ Op "<" [Iden "a", SpecialOp "collate" [StringLit 'foo', StringLit also postfix in order by: select a from t order by a collate 'C': add to order by syntax, one collation per column + much more table reference tests, for joins and aliases etc. -proper character sets for identifiers - review internal sql collection for more syntax/tests -all ansi sql operators review syntax to replace maybe and bool with better ctors @@ -55,6 +40,8 @@ review abstract syntax (e.g. combine App with SpecialOp?) Later general tasks: +more operators + sql server top syntax named windows @@ -79,6 +66,8 @@ quasi quotes? = sql support +proper character sets for identifiers, escapes, etc. + placeholder/positional arg full number literals -> other bases? diff --git a/tools/Language/SQL/SimpleSQL/ScalarExprs.lhs b/tools/Language/SQL/SimpleSQL/ScalarExprs.lhs index f9625db..2cefd2a 100644 --- a/tools/Language/SQL/SimpleSQL/ScalarExprs.lhs +++ b/tools/Language/SQL/SimpleSQL/ScalarExprs.lhs @@ -74,22 +74,29 @@ Tests for parsing scalar expressions > caseexp :: TestItem > caseexp = Group "caseexp" $ map (uncurry TestScalarExpr) > [("case a when 1 then 2 end" -> ,Case (Just $ Iden "a") [(NumLit "1" +> ,Case (Just $ Iden "a") [([NumLit "1"] > ,NumLit "2")] Nothing) > ,("case a when 1 then 2 when 3 then 4 end" -> ,Case (Just $ Iden "a") [(NumLit "1", NumLit "2") -> ,(NumLit "3", NumLit "4")] Nothing) +> ,Case (Just $ Iden "a") [([NumLit "1"], NumLit "2") +> ,([NumLit "3"], NumLit "4")] Nothing) > ,("case a when 1 then 2 when 3 then 4 else 5 end" -> ,Case (Just $ Iden "a") [(NumLit "1", NumLit "2") -> ,(NumLit "3", NumLit "4")] (Just $ NumLit "5")) +> ,Case (Just $ Iden "a") [([NumLit "1"], NumLit "2") +> ,([NumLit "3"], NumLit "4")] (Just $ NumLit "5")) > ,("case when a=1 then 2 when a=3 then 4 else 5 end" -> ,Case Nothing [(BinOp (Iden "a") "=" (NumLit "1"), NumLit "2") -> ,(BinOp (Iden "a") "=" (NumLit "3"), NumLit "4")] +> ,Case Nothing [([BinOp (Iden "a") "=" (NumLit "1")], NumLit "2") +> ,([BinOp (Iden "a") "=" (NumLit "3")], NumLit "4")] > (Just $ NumLit "5")) +> ,("case a when 1,2 then 10 when 3,4 then 20 end" +> ,Case (Just $ Iden "a") [([NumLit "1",NumLit "2"] +> ,NumLit "10") +> ,([NumLit "3",NumLit "4"] +> ,NumLit "20")] +> Nothing) + > ] > operators :: TestItem