add support for multiple case when expressions

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
+>     whens (HSE.List l) = map (\(HSE.List (t:ws)) -> (map toSql ws, toSql t)) l
->     pairs ex = err ex
+>     whens ex = err ex
 >     err :: Show a => a -> e
 >     err a = error $ "simple-sql-parser: internal fixity error " ++ show a
 >     unname ('"':nm) = QName nm

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
 

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

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

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?

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")
+>      ,Case (Just $ Iden "a") [([NumLit "1"], NumLit "2")
->                              ,(NumLit "3", NumLit "4")] Nothing)
+>                              ,([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")
+>      ,Case (Just $ Iden "a") [([NumLit "1"], NumLit "2")
->                              ,(NumLit "3", NumLit "4")] (Just $ NumLit "5"))
+>                              ,([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")
+>      ,Case Nothing [([BinOp (Iden "a") "=" (NumLit "1")], NumLit "2")
->                    ,(BinOp (Iden "a") "=" (NumLit "3"), NumLit "4")]
+>                    ,([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