diff --git a/Language/SQL/SimpleSQL/Parser.lhs b/Language/SQL/SimpleSQL/Parser.lhs index f731a4e..b347f97 100644 --- a/Language/SQL/SimpleSQL/Parser.lhs +++ b/Language/SQL/SimpleSQL/Parser.lhs @@ -1343,7 +1343,7 @@ and union, etc.. > mkSelect d sl Nothing = > makeSelect{qeSetQuantifier = d, qeSelectList = sl} > mkSelect d sl (Just (TableExpression f w g h od ofs fe)) = -> Select d sl f w g h od ofs fe +> Select d sl f w g h od ofs fe [] > values = keyword_ "values" > >> Values <$> commaSep (parens (commaSep valueExpr)) > table = keyword_ "table" >> Table <$> names @@ -1379,7 +1379,7 @@ be in the public syntax? > <*> option SQDefault duplicates > <*> corr > where -> cq o d c q0 q1 = CombineQueryExpr q0 o d c q1 +> cq o d c q0 q1 = CombineQueryExpr q0 o d c q1 [] > setOpK = choice [Union <$ keyword_ "union" > ,Intersect <$ keyword_ "intersect" > ,Except <$ keyword_ "except"] diff --git a/Language/SQL/SimpleSQL/Pretty.lhs b/Language/SQL/SimpleSQL/Pretty.lhs index a73c430..aa011af 100644 --- a/Language/SQL/SimpleSQL/Pretty.lhs +++ b/Language/SQL/SimpleSQL/Pretty.lhs @@ -13,7 +13,7 @@ which have been changed to try to improve the layout of the output. > import Language.SQL.SimpleSQL.Syntax > import Text.PrettyPrint (render, vcat, text, (<>), (<+>), empty, parens, -> nest, Doc, punctuate, comma, sep, quotes, +> nest, Doc, punctuate, comma, sep, fsep, quotes, > doubleQuotes, brackets,hcat) > import Data.Maybe (maybeToList, catMaybes) > import Data.List (intercalate) @@ -221,6 +221,8 @@ which have been changed to try to improve the layout of the output. > valueExpr _ (NextValueFor ns) = > text "next value for" <+> names ns +> valueExpr d (QEComment cmt v) = +> vcat $ map comment cmt ++ [valueExpr d v] > doubleUpQuotes :: String -> String > doubleUpQuotes [] = [] @@ -312,8 +314,9 @@ which have been changed to try to improve the layout of the output. = query expressions > queryExpr :: Dialect -> QueryExpr -> Doc -> queryExpr dia (Select d sl fr wh gb hv od off fe) = -> sep [text "select" +> queryExpr dia (Select d sl fr wh gb hv od off fe cmt) = +> fsep $ map comment cmt++ +> [sep [text "select" > ,case d of > SQDefault -> empty > All -> text "all" @@ -326,7 +329,7 @@ which have been changed to try to improve the layout of the output. > ,orderBy dia od > ,me (\e -> text "offset" <+> valueExpr dia e <+> text "rows") off > ,fetchFirst -> ] +> ]] > where > fetchFirst = > me (\e -> if dia == MySQL @@ -334,8 +337,9 @@ which have been changed to try to improve the layout of the output. > else text "fetch first" <+> valueExpr dia e > <+> text "rows only") fe -> queryExpr dia (CombineQueryExpr q1 ct d c q2) = -> sep [queryExpr dia q1 +> queryExpr dia (CombineQueryExpr q1 ct d c q2 cmt) = +> fsep $ map comment cmt++ +> [sep [queryExpr dia q1 > ,text (case ct of > Union -> "union" > Intersect -> "intersect" @@ -347,7 +351,7 @@ which have been changed to try to improve the layout of the output. > <+> case c of > Corresponding -> text "corresponding" > Respectively -> empty -> ,queryExpr dia q2] +> ,queryExpr dia q2]] > queryExpr d (With rc withs qe) = > text "with" <+> (if rc then text "recursive" else empty) > <+> vcat [nest 5 @@ -441,3 +445,6 @@ which have been changed to try to improve the layout of the output. > me :: (a -> Doc) -> Maybe a -> Doc > me = maybe empty + +> comment :: Comment -> Doc +> comment (Comment str) = text "/*" <+> text str <+> text "*/" diff --git a/Language/SQL/SimpleSQL/Syntax.lhs b/Language/SQL/SimpleSQL/Syntax.lhs index 87ac07c..8542f1f 100644 --- a/Language/SQL/SimpleSQL/Syntax.lhs +++ b/Language/SQL/SimpleSQL/Syntax.lhs @@ -32,6 +32,8 @@ > ,JoinCondition(..) > -- * dialect > ,Dialect(..) +> -- * comment +> ,Comment(..) > ) where > import Data.Data @@ -161,6 +163,7 @@ > | MultisetCtor [ValueExpr] > | MultisetQueryCtor QueryExpr > | NextValueFor [Name] +> | QEComment [Comment] ValueExpr > deriving (Eq,Show,Read,Data,Typeable) > -- | Represents an identifier name, which can be quoted or unquoted. @@ -278,6 +281,7 @@ This would make some things a bit cleaner? > ,qeOrderBy :: [SortSpec] > ,qeOffset :: Maybe ValueExpr > ,qeFetchFirst :: Maybe ValueExpr +> ,qeComment :: [Comment] > } > | CombineQueryExpr > {qe0 :: QueryExpr @@ -285,6 +289,7 @@ This would make some things a bit cleaner? > ,qeSetQuantifier :: SetQuantifier > ,qeCorresponding :: Corresponding > ,qe1 :: QueryExpr +> ,qeComment :: [Comment] > } > | With > {qeWithRecursive :: Bool @@ -321,7 +326,8 @@ I'm not sure if this is valid syntax or not. > ,qeHaving = Nothing > ,qeOrderBy = [] > ,qeOffset = Nothing -> ,qeFetchFirst = Nothing} +> ,qeFetchFirst = Nothing +> ,qeComment = []} > -- | Represents the Distinct or All keywords, which can be used @@ -383,3 +389,9 @@ I'm not sure if this is valid syntax or not. > data Dialect = SQL2011 > | MySQL > deriving (Eq,Show,Read,Data,Typeable) + + +> -- | Comment. Useful when geterating SQL code programmatically. +> data Comment = Comment String +> deriving (Eq,Show,Read,Data,Typeable) + diff --git a/tools/Language/SQL/SimpleSQL/QueryExprComponents.lhs b/tools/Language/SQL/SimpleSQL/QueryExprComponents.lhs index 7427bc3..5828a3a 100644 --- a/tools/Language/SQL/SimpleSQL/QueryExprComponents.lhs +++ b/tools/Language/SQL/SimpleSQL/QueryExprComponents.lhs @@ -144,24 +144,24 @@ These are a few misc tests which don't fit anywhere else. > combos :: TestItem > combos = Group "combos" $ map (uncurry (TestQueryExpr SQL2011)) > [("select a from t union select b from u" -> ,CombineQueryExpr ms1 Union SQDefault Respectively ms2) +> ,CombineQueryExpr ms1 Union SQDefault Respectively ms2 []) > ,("select a from t intersect select b from u" -> ,CombineQueryExpr ms1 Intersect SQDefault Respectively ms2) +> ,CombineQueryExpr ms1 Intersect SQDefault Respectively ms2 []) > ,("select a from t except all select b from u" -> ,CombineQueryExpr ms1 Except All Respectively ms2) +> ,CombineQueryExpr ms1 Except All Respectively ms2 []) > ,("select a from t union distinct corresponding \ > \select b from u" -> ,CombineQueryExpr ms1 Union Distinct Corresponding ms2) +> ,CombineQueryExpr ms1 Union Distinct Corresponding ms2 []) > ,("select a from t union select a from t union select a from t" > -- TODO: union should be left associative. I think the others also > -- so this needs to be fixed (new optionSuffix variation which > -- handles this) > ,CombineQueryExpr ms1 Union SQDefault Respectively -> (CombineQueryExpr ms1 Union SQDefault Respectively ms1)) +> (CombineQueryExpr ms1 Union SQDefault Respectively ms1 []) []) > ] > where > ms1 = makeSelect