diff --git a/Language/SQL/SimpleSQL/Parse.hs b/Language/SQL/SimpleSQL/Parse.hs index 1813911..7aa9ba6 100644 --- a/Language/SQL/SimpleSQL/Parse.hs +++ b/Language/SQL/SimpleSQL/Parse.hs @@ -54,7 +54,7 @@ A lot of care has been given to generating good parser error messages for invalid syntax. There are a few utils below which partially help in this area. -There is a set of crafted bad expressions in ErrorMessages. hs, these +There is a set of crafted bad expressions in ErrorMessages.hs, these are used to guage the quality of the error messages and monitor regressions by hand. The use of is limited as much as possible: each instance should justify itself by improving an actual error diff --git a/Language/SQL/SimpleSQL/Pretty.hs b/Language/SQL/SimpleSQL/Pretty.hs index 8726d58..8774f26 100644 --- a/Language/SQL/SimpleSQL/Pretty.hs +++ b/Language/SQL/SimpleSQL/Pretty.hs @@ -2,6 +2,7 @@ -- | These is the pretty printing functions, which produce SQL -- source from ASTs. The code attempts to format the output in a -- readable way. +{-# LANGUAGE OverloadedStrings #-} module Language.SQL.SimpleSQL.Pretty (prettyQueryExpr ,prettyScalarExpr @@ -9,21 +10,34 @@ module Language.SQL.SimpleSQL.Pretty ,prettyStatements ) where -import Prelude hiding ((<>)) - {- TODO: there should be more comments in this file, especially the bits which have been changed to try to improve the layout of the output. -Try to do this when this code is ported to a modern pretty printing lib. -} ---import Language.SQL.SimpleSQL.Dialect -import Text.PrettyPrint (render, vcat, text, (<>), (<+>), empty, parens, - nest, Doc, punctuate, comma, sep, quotes, - brackets,hcat) +import Prettyprinter (Doc + ,parens + ,nest + ,(<+>) + ,sep + ,punctuate + ,comma + ,squotes + ,vsep + ,hsep + ,layoutPretty + ,defaultLayoutOptions + ,brackets + ) +import qualified Prettyprinter as P + +import Prettyprinter.Render.Text (renderLazy) + import Data.Maybe (maybeToList, catMaybes) import Data.List (intercalate) +import qualified Data.Text.Lazy as L +import qualified Data.Text as T import Language.SQL.SimpleSQL.Syntax import Language.SQL.SimpleSQL.Dialect @@ -38,8 +52,8 @@ prettyScalarExpr :: Dialect -> ScalarExpr -> String prettyScalarExpr d = render . scalarExpr d -- | A terminating semicolon. -terminator :: Doc -terminator = text ";\n" +terminator :: Doc a +terminator = pretty ";\n" -- | Convert a statement ast to concrete syntax. prettyStatement :: Dialect -> Statement -> String @@ -49,81 +63,84 @@ prettyStatement d s = render (statement d s) -- | Convert a list of statements to concrete syntax. A semicolon -- is inserted after each statement. prettyStatements :: Dialect -> [Statement] -> String -prettyStatements d = render . vcat . map prettyStatementWithSemicolon +prettyStatements d = render . vsep . map prettyStatementWithSemicolon where - prettyStatementWithSemicolon :: Statement -> Doc + prettyStatementWithSemicolon :: Statement -> Doc a prettyStatementWithSemicolon s = statement d s <> terminator +render :: Doc a -> String -- L.Text +render = L.unpack . renderLazy . layoutPretty defaultLayoutOptions + -- = scalar expressions -scalarExpr :: Dialect -> ScalarExpr -> Doc -scalarExpr _ (StringLit s e t) = text s <> text t <> text e +scalarExpr :: Dialect -> ScalarExpr -> Doc a +scalarExpr _ (StringLit s e t) = pretty s <> pretty t <> pretty e -scalarExpr _ (NumLit s) = text s +scalarExpr _ (NumLit s) = pretty s scalarExpr _ (IntervalLit s v f t) = - text "interval" - <+> me (\x -> text $ case x of + pretty "interval" + <+> me (\x -> pretty $ case x of Plus -> "+" Minus -> "-") s - <+> quotes (text v) + <+> squotes (pretty v) <+> intervalTypeField f - <+> me (\x -> text "to" <+> intervalTypeField x) t + <+> me (\x -> pretty "to" <+> intervalTypeField x) t scalarExpr _ (Iden i) = names i -scalarExpr _ Star = text "*" -scalarExpr _ Parameter = text "?" -scalarExpr _ (PositionalArg n) = text $ "$" ++ show n +scalarExpr _ Star = pretty "*" +scalarExpr _ Parameter = pretty "?" +scalarExpr _ (PositionalArg n) = pretty $ "$" ++ show n scalarExpr _ (HostParameter p i) = - text p - <+> me (\i' -> text "indicator" <+> text i') i + pretty p + <+> me (\i' -> pretty "indicator" <+> pretty i') i scalarExpr d (App f es) = names f <> parens (commaSep (map (scalarExpr d) es)) scalarExpr dia (AggregateApp f d es od fil) = names f <> parens ((case d of - Distinct -> text "distinct" - All -> text "all" - SQDefault -> empty) + Distinct -> pretty "distinct" + All -> pretty "all" + SQDefault -> mempty) <+> commaSep (map (scalarExpr dia) es) <+> orderBy dia od) - <+> me (\x -> text "filter" - <+> parens (text "where" <+> scalarExpr dia x)) fil + <+> me (\x -> pretty "filter" + <+> parens (pretty "where" <+> scalarExpr dia x)) fil scalarExpr d (AggregateAppGroup f es od) = names f <> parens (commaSep (map (scalarExpr d) es)) <+> if null od - then empty - else text "within group" <+> parens (orderBy d od) + then mempty + else pretty "within group" <+> parens (orderBy d od) scalarExpr d (WindowApp f es pb od fr) = names f <> parens (commaSep $ map (scalarExpr d) es) - <+> text "over" + <+> pretty "over" <+> parens ((case pb of - [] -> empty - _ -> text "partition by" + [] -> mempty + _ -> pretty "partition by" <+> nest 13 (commaSep $ map (scalarExpr d) pb)) <+> orderBy d od <+> me frd fr) where frd (FrameFrom rs fp) = rsd rs <+> fpd fp frd (FrameBetween rs fps fpe) = - rsd rs <+> text "between" <+> fpd fps - <+> text "and" <+> fpd fpe + rsd rs <+> pretty "between" <+> fpd fps + <+> pretty "and" <+> fpd fpe rsd rs = case rs of - FrameRows -> text "rows" - FrameRange -> text "range" - fpd UnboundedPreceding = text "unbounded preceding" - fpd UnboundedFollowing = text "unbounded following" - fpd Current = text "current row" - fpd (Preceding e) = scalarExpr d e <+> text "preceding" - fpd (Following e) = scalarExpr d e <+> text "following" + FrameRows -> pretty "rows" + FrameRange -> pretty "range" + fpd UnboundedPreceding = pretty "unbounded preceding" + fpd UnboundedFollowing = pretty "unbounded following" + fpd Current = pretty "current row" + fpd (Preceding e) = scalarExpr d e <+> pretty "preceding" + fpd (Following e) = scalarExpr d e <+> pretty "following" scalarExpr dia (SpecialOp nm [a,b,c]) | nm `elem` [[Name Nothing "between"] ,[Name Nothing "not between"]] = sep [scalarExpr dia a ,names nm <+> scalarExpr dia b - ,nest (length (unnames nm) + 1) $ text "and" <+> scalarExpr dia c] + ,nest (length (unnames nm) + 1) $ pretty "and" <+> scalarExpr dia c] scalarExpr d (SpecialOp [Name Nothing "rowctor"] as) = parens $ commaSep $ map (scalarExpr d) as @@ -134,57 +151,57 @@ scalarExpr d (SpecialOp nm es) = scalarExpr d (SpecialOpK nm fs as) = names nm <> parens (sep $ catMaybes (fmap (scalarExpr d) fs - : map (\(n,e) -> Just (text n <+> scalarExpr d e)) as)) + : map (\(n,e) -> Just (pretty n <+> scalarExpr d e)) as)) scalarExpr d (PrefixOp f e) = names f <+> scalarExpr d e scalarExpr d (PostfixOp f e) = scalarExpr d e <+> names f scalarExpr d e@(BinOp _ op _) | op `elem` [[Name Nothing "and"] ,[Name Nothing "or"]] = - -- special case for and, or, get all the ands so we can vcat them + -- special case for and, or, get all the ands so we can vsep them -- nicely case ands e of - (e':es) -> vcat (scalarExpr d e' + (e':es) -> vsep (scalarExpr d e' : map ((names op <+>) . scalarExpr d) es) - [] -> empty -- shouldn't be possible + [] -> mempty -- shouldn't be possible where ands (BinOp a op' b) | op == op' = ands a ++ ands b ands x = [x] -- special case for . we don't use whitespace scalarExpr d (BinOp e0 [Name Nothing "."] e1) = - scalarExpr d e0 <> text "." <> scalarExpr d e1 + scalarExpr d e0 <> pretty "." <> scalarExpr d e1 scalarExpr d (BinOp e0 f e1) = scalarExpr d e0 <+> names f <+> scalarExpr d e1 scalarExpr dia (Case t ws els) = - sep $ [text "case" <+> me (scalarExpr dia) t] + sep $ [pretty "case" <+> me (scalarExpr dia) t] ++ map w ws ++ maybeToList (fmap e els) - ++ [text "end"] + ++ [pretty "end"] where w (t0,t1) = - text "when" <+> nest 5 (commaSep $ map (scalarExpr dia) t0) - <+> text "then" <+> nest 5 (scalarExpr dia t1) - e el = text "else" <+> nest 5 (scalarExpr dia el) + pretty "when" <+> nest 5 (commaSep $ map (scalarExpr dia) t0) + <+> pretty "then" <+> nest 5 (scalarExpr dia t1) + e el = pretty "else" <+> nest 5 (scalarExpr dia el) scalarExpr d (Parens e) = parens $ scalarExpr d e scalarExpr d (Cast e tn) = - text "cast" <> parens (sep [scalarExpr d e - ,text "as" - ,typeName tn]) + pretty "cast" <> parens (sep [scalarExpr d e + ,pretty "as" + ,typeName tn]) scalarExpr _ (TypedLit tn s) = - typeName tn <+> quotes (text s) + typeName tn <+> squotes (pretty s) scalarExpr d (SubQueryExpr ty qe) = (case ty of - SqSq -> empty - SqExists -> text "exists" - SqUnique -> text "unique" + SqSq -> mempty + SqExists -> pretty "exists" + SqUnique -> pretty "unique" ) <+> parens (queryExpr d qe) scalarExpr d (QuantifiedComparison v c cp sq) = scalarExpr d v <+> names c - <+> (text $ case cp of + <+> (pretty $ case cp of CPAny -> "any" CPSome -> "some" CPAll -> "all") @@ -192,14 +209,14 @@ scalarExpr d (QuantifiedComparison v c cp sq) = scalarExpr d (Match v u sq) = scalarExpr d v - <+> text "match" - <+> (if u then text "unique" else empty) + <+> pretty "match" + <+> (if u then pretty "unique" else mempty) <+> parens (queryExpr d sq) scalarExpr d (In b se x) = scalarExpr d se <+> - (if b then empty else text "not") - <+> text "in" + (if b then mempty else pretty "not") + <+> pretty "in" <+> parens (nest (if b then 3 else 7) $ case x of InList es -> commaSep $ map (scalarExpr d) es @@ -209,57 +226,57 @@ scalarExpr d (Array v es) = scalarExpr d v <> brackets (commaSep $ map (scalarExpr d) es) scalarExpr d (ArrayCtor q) = - text "array" <> parens (queryExpr d q) + pretty "array" <> parens (queryExpr d q) scalarExpr d (MultisetCtor es) = - text "multiset" <> brackets (commaSep $ map (scalarExpr d) es) + pretty "multiset" <> brackets (commaSep $ map (scalarExpr d) es) scalarExpr d (MultisetQueryCtor q) = - text "multiset" <> parens (queryExpr d q) + pretty "multiset" <> parens (queryExpr d q) scalarExpr d (MultisetBinOp a c q b) = sep [scalarExpr d a - ,text "multiset" - ,text $ case c of + ,pretty "multiset" + ,pretty $ case c of Union -> "union" Intersect -> "intersect" Except -> "except" ,case q of - SQDefault -> empty - All -> text "all" - Distinct -> text "distinct" + SQDefault -> mempty + All -> pretty "all" + Distinct -> pretty "distinct" ,scalarExpr d b] {-scalarExpr d (Escape v e) = - scalarExpr d v <+> text "escape" <+> text [e] + scalarExpr d v <+> pretty "escape" <+> pretty [e] scalarExpr d (UEscape v e) = - scalarExpr d v <+> text "uescape" <+> text [e]-} + scalarExpr d v <+> pretty "uescape" <+> pretty [e]-} scalarExpr d (Collate v c) = - scalarExpr d v <+> text "collate" <+> names c + scalarExpr d v <+> pretty "collate" <+> names c scalarExpr _ (NextValueFor ns) = - text "next value for" <+> names ns + pretty "next value for" <+> names ns scalarExpr d (VEComment cmt v) = - vcat $ map comment cmt ++ [scalarExpr d v] + vsep $ map comment cmt ++ [scalarExpr d v] scalarExpr _ (OdbcLiteral t s) = - text "{" <> lt t <+> quotes (text s) <> text "}" + pretty "{" <> lt t <+> squotes (pretty s) <> pretty "}" where - lt OLDate = text "d" - lt OLTime = text "t" - lt OLTimestamp = text "ts" + lt OLDate = pretty "d" + lt OLTime = pretty "t" + lt OLTimestamp = pretty "ts" scalarExpr d (OdbcFunc e) = - text "{fn" <+> scalarExpr d e <> text "}" + pretty "{fn" <+> scalarExpr d e <> pretty "}" scalarExpr d (Convert t e Nothing) = - text "convert(" <> typeName t <> text "," <+> scalarExpr d e <> text ")" + pretty "convert(" <> typeName t <> pretty "," <+> scalarExpr d e <> pretty ")" scalarExpr d (Convert t e (Just i)) = - text "convert(" <> typeName t <> text "," <+> scalarExpr d e <> text "," <+> text (show i) <> text ")" + pretty "convert(" <> typeName t <> pretty "," <+> scalarExpr d e <> pretty "," <+> pretty (show i) <> pretty ")" unname :: Name -> String unname (Name Nothing n) = n @@ -270,112 +287,112 @@ unnames :: [Name] -> String unnames ns = intercalate "." $ map unname ns -name :: Name -> Doc -name (Name Nothing n) = text n -name (Name (Just (s,e)) n) = text s <> text n <> text e +name :: Name -> Doc a +name (Name Nothing n) = pretty n +name (Name (Just (s,e)) n) = pretty s <> pretty n <> pretty e -names :: [Name] -> Doc -names ns = hcat $ punctuate (text ".") $ map name ns +names :: [Name] -> Doc a +names ns = hsep $ punctuate (pretty ".") $ map name ns -typeName :: TypeName -> Doc +typeName :: TypeName -> Doc a typeName (TypeName t) = names t -typeName (PrecTypeName t a) = names t <+> parens (text $ show a) +typeName (PrecTypeName t a) = names t <+> parens (pretty $ show a) typeName (PrecScaleTypeName t a b) = - names t <+> parens (text (show a) <+> comma <+> text (show b)) + names t <+> parens (pretty (show a) <+> comma <+> pretty (show b)) typeName (PrecLengthTypeName t i m u) = names t - <> parens (text (show i) + <> parens (pretty (show i) <> me (\x -> case x of - PrecK -> text "K" - PrecM -> text "M" - PrecG -> text "G" - PrecT -> text "T" - PrecP -> text "P") m + PrecK -> pretty "K" + PrecM -> pretty "M" + PrecG -> pretty "G" + PrecT -> pretty "T" + PrecP -> pretty "P") m <+> me (\x -> case x of - PrecCharacters -> text "CHARACTERS" - PrecOctets -> text "OCTETS") u) + PrecCharacters -> pretty "CHARACTERS" + PrecOctets -> pretty "OCTETS") u) typeName (CharTypeName t i cs col) = names t - <> me (\x -> parens (text $ show x)) i + <> me (\x -> parens (pretty $ show x)) i <+> (if null cs - then empty - else text "character set" <+> names cs) + then mempty + else pretty "character set" <+> names cs) <+> (if null col - then empty - else text "collate" <+> names col) + then mempty + else pretty "collate" <+> names col) typeName (TimeTypeName t i tz) = names t - <> me (\x -> parens (text $ show x)) i - <+> text (if tz + <> me (\x -> parens (pretty $ show x)) i + <+> pretty (if tz then "with time zone" else "without time zone") typeName (RowTypeName cs) = - text "row" <> parens (commaSep $ map f cs) + pretty "row" <> parens (commaSep $ map f cs) where f (n,t) = name n <+> typeName t typeName (IntervalTypeName f t) = - text "interval" + pretty "interval" <+> intervalTypeField f - <+> me (\x -> text "to" <+> intervalTypeField x) t + <+> me (\x -> pretty "to" <+> intervalTypeField x) t typeName (ArrayTypeName tn sz) = - typeName tn <+> text "array" <+> me (brackets . text . show) sz + typeName tn <+> pretty "array" <+> me (brackets . pretty . show) sz typeName (MultisetTypeName tn) = - typeName tn <+> text "multiset" + typeName tn <+> pretty "multiset" -intervalTypeField :: IntervalTypeField -> Doc +intervalTypeField :: IntervalTypeField -> Doc a intervalTypeField (Itf n p) = - text n + pretty n <+> me (\(x,x1) -> - parens (text (show x) - <+> me (\y -> (sep [comma,text (show y)])) x1)) p + parens (pretty (show x) + <+> me (\y -> (sep [comma,pretty (show y)])) x1)) p -- = query expressions -queryExpr :: Dialect -> QueryExpr -> Doc +queryExpr :: Dialect -> QueryExpr -> Doc a queryExpr dia (Select d sl fr wh gb hv od off fe) = - sep [text "select" + sep [pretty "select" ,case d of - SQDefault -> empty - All -> text "all" - Distinct -> text "distinct" + SQDefault -> mempty + All -> pretty "all" + Distinct -> pretty "distinct" ,nest 7 $ sep [selectList dia sl] ,from dia fr ,maybeScalarExpr dia "where" wh ,grpBy dia gb ,maybeScalarExpr dia "having" hv ,orderBy dia od - ,me (\e -> text "offset" <+> scalarExpr dia e <+> text "rows") off + ,me (\e -> pretty "offset" <+> scalarExpr dia e <+> pretty "rows") off ,fetchFirst ] where fetchFirst = me (\e -> if diLimit dia - then text "limit" <+> scalarExpr dia e - else text "fetch first" <+> scalarExpr dia e - <+> text "rows only") fe + then pretty "limit" <+> scalarExpr dia e + else pretty "fetch first" <+> scalarExpr dia e + <+> pretty "rows only") fe queryExpr dia (QueryExprSetOp q1 ct d c q2) = sep [queryExpr dia q1 - ,text (case ct of + ,pretty (case ct of Union -> "union" Intersect -> "intersect" Except -> "except") <+> case d of - SQDefault -> empty - All -> text "all" - Distinct -> text "distinct" + SQDefault -> mempty + All -> pretty "all" + Distinct -> pretty "distinct" <+> case c of - Corresponding -> text "corresponding" - Respectively -> empty + Corresponding -> pretty "corresponding" + Respectively -> mempty ,queryExpr dia q2] queryExpr d (With rc withs qe) = - text "with" <+> (if rc then text "recursive" else empty) - <+> vcat [nest 5 - (vcat $ punctuate comma $ flip map withs $ \(n,q) -> - withAlias n <+> text "as" <+> parens (queryExpr d q)) + pretty "with" <+> (if rc then pretty "recursive" else mempty) + <+> vsep [nest 5 + (vsep $ punctuate comma $ flip map withs $ \(n,q) -> + withAlias n <+> pretty "as" <+> parens (queryExpr d q)) ,queryExpr d qe] where withAlias (Alias nm cols) = name nm @@ -383,32 +400,32 @@ queryExpr d (With rc withs qe) = queryExpr d (Values vs) = - text "values" + pretty "values" <+> nest 7 (commaSep (map (parens . commaSep . map (scalarExpr d)) vs)) -queryExpr _ (Table t) = text "table" <+> names t +queryExpr _ (Table t) = pretty "table" <+> names t queryExpr d (QEComment cmt v) = - vcat $ map comment cmt ++ [queryExpr d v] + vsep $ map comment cmt ++ [queryExpr d v] -alias :: Alias -> Doc +alias :: Alias -> Doc a alias (Alias nm cols) = - text "as" <+> name nm + pretty "as" <+> name nm <+> me (parens . commaSep . map name) cols -selectList :: Dialect -> [(ScalarExpr,Maybe Name)] -> Doc +selectList :: Dialect -> [(ScalarExpr,Maybe Name)] -> Doc a selectList d is = commaSep $ map si is where si (e,al) = scalarExpr d e <+> me als al - als al = text "as" <+> name al + als al = pretty "as" <+> name al -from :: Dialect -> [TableRef] -> Doc -from _ [] = empty +from :: Dialect -> [TableRef] -> Doc a +from _ [] = mempty from d ts = - sep [text "from" - ,nest 5 $ vcat $ punctuate comma $ map tr ts] + sep [pretty "from" + ,nest 5 $ vsep $ punctuate comma $ map tr ts] where tr (TRSimple t) = names t - tr (TRLateral t) = text "lateral" <+> tr t + tr (TRLateral t) = pretty "lateral" <+> tr t tr (TRFunction f as) = names f <> parens (commaSep $ map (scalarExpr d) as) tr (TRAlias t a) = sep [tr t, alias a] @@ -416,71 +433,71 @@ from d ts = tr (TRQueryExpr q) = parens $ queryExpr d q tr (TRJoin t0 b jt t1 jc) = sep [tr t0 - ,if b then text "natural" else empty + ,if b then pretty "natural" else mempty ,joinText jt <+> tr t1 ,joinCond jc] - tr (TROdbc t) = text "{oj" <+> tr t <+> text "}" + tr (TROdbc t) = pretty "{oj" <+> tr t <+> pretty "}" joinText jt = sep [case jt of - JInner -> text "inner" - JLeft -> text "left" - JRight -> text "right" - JFull -> text "full" - JCross -> text "cross" - ,text "join"] - joinCond (Just (JoinOn e)) = text "on" <+> scalarExpr d e + JInner -> pretty "inner" + JLeft -> pretty "left" + JRight -> pretty "right" + JFull -> pretty "full" + JCross -> pretty "cross" + ,pretty "join"] + joinCond (Just (JoinOn e)) = pretty "on" <+> scalarExpr d e joinCond (Just (JoinUsing es)) = - text "using" <+> parens (commaSep $ map name es) - joinCond Nothing = empty + pretty "using" <+> parens (commaSep $ map name es) + joinCond Nothing = mempty -maybeScalarExpr :: Dialect -> String -> Maybe ScalarExpr -> Doc +maybeScalarExpr :: Dialect -> String -> Maybe ScalarExpr -> Doc a maybeScalarExpr d k = me - (\e -> sep [text k + (\e -> sep [pretty k ,nest (length k + 1) $ scalarExpr d e]) -grpBy :: Dialect -> [GroupingExpr] -> Doc -grpBy _ [] = empty -grpBy d gs = sep [text "group by" - ,nest 9 $ commaSep $ map ge gs] +grpBy :: Dialect -> [GroupingExpr] -> Doc a +grpBy _ [] = mempty +grpBy d gs = sep [pretty "group by" + ,nest 9 $ commaSep $ map ge gs] where ge (SimpleGroup e) = scalarExpr d e ge (GroupingParens g) = parens (commaSep $ map ge g) - ge (Cube es) = text "cube" <> parens (commaSep $ map ge es) - ge (Rollup es) = text "rollup" <> parens (commaSep $ map ge es) - ge (GroupingSets es) = text "grouping sets" <> parens (commaSep $ map ge es) + ge (Cube es) = pretty "cube" <> parens (commaSep $ map ge es) + ge (Rollup es) = pretty "rollup" <> parens (commaSep $ map ge es) + ge (GroupingSets es) = pretty "grouping sets" <> parens (commaSep $ map ge es) -orderBy :: Dialect -> [SortSpec] -> Doc -orderBy _ [] = empty -orderBy dia os = sep [text "order by" +orderBy :: Dialect -> [SortSpec] -> Doc a +orderBy _ [] = mempty +orderBy dia os = sep [pretty "order by" ,nest 9 $ commaSep $ map f os] where f (SortSpec e d n) = scalarExpr dia e <+> (case d of - Asc -> text "asc" - Desc -> text "desc" - DirDefault -> empty) + Asc -> pretty "asc" + Desc -> pretty "desc" + DirDefault -> mempty) <+> (case n of - NullsOrderDefault -> empty - NullsFirst -> text "nulls" <+> text "first" - NullsLast -> text "nulls" <+> text "last") + NullsOrderDefault -> mempty + NullsFirst -> pretty "nulls" <+> pretty "first" + NullsLast -> pretty "nulls" <+> pretty "last") -- = statements -statement :: Dialect -> Statement -> Doc +statement :: Dialect -> Statement -> Doc a -- == ddl statement _ (CreateSchema nm) = - text "create" <+> text "schema" <+> names nm + pretty "create" <+> pretty "schema" <+> names nm statement d (CreateTable nm cds) = - text "create" <+> text "table" <+> names nm + pretty "create" <+> pretty "table" <+> names nm <+> parens (commaSep $ map cd cds) where cd (TableConstraintDef n con) = - maybe empty (\s -> text "constraint" <+> names s) n + maybe mempty (\s -> pretty "constraint" <+> names s) n <+> tableConstraint d con cd (TableColumnDef cd') = columnDef d cd' @@ -489,17 +506,17 @@ statement d (AlterTable t act) = <+> alterTableAction d act statement _ (DropSchema nm db) = - text "drop" <+> text "schema" <+> names nm <+> dropBehav db + pretty "drop" <+> pretty "schema" <+> names nm <+> dropBehav db statement d (CreateDomain nm ty def cs) = - text "create" <+> text "domain" <+> names nm + pretty "create" <+> pretty "domain" <+> names nm <+> typeName ty - <+> maybe empty (\def' -> text "default" <+> scalarExpr d def') def + <+> maybe mempty (\def' -> pretty "default" <+> scalarExpr d def') def <+> sep (map con cs) where con (cn, e) = - maybe empty (\cn' -> text "constraint" <+> names cn') cn - <+> text "check" <> parens (scalarExpr d e) + maybe mempty (\cn' -> pretty "constraint" <+> names cn') cn + <+> pretty "check" <> parens (scalarExpr d e) statement d (AlterDomain nm act) = texts ["alter","domain"] @@ -509,15 +526,15 @@ statement d (AlterDomain nm act) = a (ADSetDefault v) = texts ["set","default"] <+> scalarExpr d v a (ADDropDefault) = texts ["drop","default"] a (ADAddConstraint cnm e) = - text "add" - <+> maybe empty (\cnm' -> text "constraint" <+> names cnm') cnm - <+> text "check" <> parens (scalarExpr d e) + pretty "add" + <+> maybe mempty (\cnm' -> pretty "constraint" <+> names cnm') cnm + <+> pretty "check" <> parens (scalarExpr d e) a (ADDropConstraint cnm) = texts ["drop", "constraint"] <+> names cnm statement _ (DropDomain nm db) = - text "drop" <+> text "domain" <+> names nm <+> dropBehav db + pretty "drop" <+> pretty "domain" <+> names nm <+> dropBehav db statement _ (CreateSequence nm sgos) = texts ["create","sequence"] <+> names nm @@ -528,22 +545,22 @@ statement _ (AlterSequence nm sgos) = <+> sep (map sequenceGeneratorOption sgos) statement _ (DropSequence nm db) = - text "drop" <+> text "sequence" <+> names nm <+> dropBehav db + pretty "drop" <+> pretty "sequence" <+> names nm <+> dropBehav db statement d (CreateAssertion nm ex) = texts ["create","assertion"] <+> names nm - <+> text "check" <+> parens (scalarExpr d ex) + <+> pretty "check" <+> parens (scalarExpr d ex) statement _ (DropAssertion nm db) = - text "drop" <+> text "assertion" <+> names nm <+> dropBehav db + pretty "drop" <+> pretty "assertion" <+> names nm <+> dropBehav db statement _ (CreateIndex un nm tbl cols) = texts (if un then ["create","unique","index"] else ["create","index"]) <+> names nm - <+> text "on" + <+> pretty "on" <+> names tbl <+> parens (commaSep $ map name cols) @@ -552,51 +569,51 @@ statement _ (CreateIndex un nm tbl cols) = statement d (SelectStatement q) = queryExpr d q statement d (Delete t a w) = - text "delete" <+> text "from" - <+> names t <+> maybe empty (\x -> text "as" <+> name x) a + pretty "delete" <+> pretty "from" + <+> names t <+> maybe mempty (\x -> pretty "as" <+> name x) a <+> maybeScalarExpr d "where" w statement _ (Truncate t ir) = - text "truncate" <+> text "table" <+> names t + pretty "truncate" <+> pretty "table" <+> names t <+> case ir of - DefaultIdentityRestart -> empty - ContinueIdentity -> text "continue" <+> text "identity" - RestartIdentity -> text "restart" <+> text "identity" + DefaultIdentityRestart -> mempty + ContinueIdentity -> pretty "continue" <+> pretty "identity" + RestartIdentity -> pretty "restart" <+> pretty "identity" statement d (Insert t cs s) = - text "insert" <+> text "into" <+> names t - <+> maybe empty (\cs' -> parens (commaSep $ map name cs')) cs + pretty "insert" <+> pretty "into" <+> names t + <+> maybe mempty (\cs' -> parens (commaSep $ map name cs')) cs <+> case s of - DefaultInsertValues -> text "default" <+> text "values" + DefaultInsertValues -> pretty "default" <+> pretty "values" InsertQuery q -> queryExpr d q statement d (Update t a sts whr) = - text "update" <+> names t - <+> maybe empty (\x -> text "as" <+> name x) a - <+> text "set" <+> commaSep (map sc sts) + pretty "update" <+> names t + <+> maybe mempty (\x -> pretty "as" <+> name x) a + <+> pretty "set" <+> commaSep (map sc sts) <+> maybeScalarExpr d "where" whr where - sc (Set tg v) = names tg <+> text "=" <+> scalarExpr d v - sc (SetMultiple ts vs) = parens (commaSep $ map names ts) <+> text "=" + sc (Set tg v) = names tg <+> pretty "=" <+> scalarExpr d v + sc (SetMultiple ts vs) = parens (commaSep $ map names ts) <+> pretty "=" <+> parens (commaSep $ map (scalarExpr d) vs) statement _ (DropTable n b) = - text "drop" <+> text "table" <+> names n <+> dropBehav b + pretty "drop" <+> pretty "table" <+> names n <+> dropBehav b statement d (CreateView r nm al q co) = - text "create" <+> (if r then text "recursive" else empty) - <+> text "view" <+> names nm - <+> (maybe empty (\al' -> parens $ commaSep $ map name al')) al - <+> text "as" + pretty "create" <+> (if r then pretty "recursive" else mempty) + <+> pretty "view" <+> names nm + <+> (maybe mempty (\al' -> parens $ commaSep $ map name al')) al + <+> pretty "as" <+> queryExpr d q <+> case co of - Nothing -> empty + Nothing -> mempty Just DefaultCheckOption -> texts ["with", "check", "option"] Just CascadedCheckOption -> texts ["with", "cascaded", "check", "option"] Just LocalCheckOption -> texts ["with", "local", "check", "option"] statement _ (DropView n b) = - text "drop" <+> text "view" <+> names n <+> dropBehav b + pretty "drop" <+> pretty "view" <+> names n <+> dropBehav b -- == transactions @@ -605,36 +622,36 @@ statement _ StartTransaction = texts ["start", "transaction"] statement _ (Savepoint nm) = - text "savepoint" <+> name nm + pretty "savepoint" <+> name nm statement _ (ReleaseSavepoint nm) = texts ["release", "savepoint"] <+> name nm statement _ Commit = - text "commit" + pretty "commit" statement _ (Rollback mn) = - text "rollback" - <+> maybe empty (\n -> texts ["to","savepoint"] <+> name n) mn + pretty "rollback" + <+> maybe mempty (\n -> texts ["to","savepoint"] <+> name n) mn -- == access control statement _ (GrantPrivilege pas po rs go) = - text "grant" <+> commaSep (map privAct pas) - <+> text "on" <+> privObj po - <+> text "to" <+> commaSep (map name rs) + pretty "grant" <+> commaSep (map privAct pas) + <+> pretty "on" <+> privObj po + <+> pretty "to" <+> commaSep (map name rs) <+> grantOpt go where grantOpt WithGrantOption = texts ["with","grant","option"] - grantOpt WithoutGrantOption = empty + grantOpt WithoutGrantOption = mempty statement _ (GrantRole rs trs ao) = - text "grant" <+> commaSep (map name rs) - <+> text "to" <+> commaSep (map name trs) + pretty "grant" <+> commaSep (map name rs) + <+> pretty "to" <+> commaSep (map name trs) <+> adminOpt ao where adminOpt WithAdminOption = texts ["with","admin","option"] - adminOpt WithoutAdminOption = empty + adminOpt WithoutAdminOption = mempty statement _ (CreateRole nm) = texts ["create","role"] <+> name nm @@ -643,29 +660,29 @@ statement _ (DropRole nm) = texts ["drop","role"] <+> name nm statement _ (RevokePrivilege go pas po rs db) = - text "revoke" + pretty "revoke" <+> grantOptFor go <+> commaSep (map privAct pas) - <+> text "on" <+> privObj po - <+> text "from" <+> commaSep (map name rs) + <+> pretty "on" <+> privObj po + <+> pretty "from" <+> commaSep (map name rs) <+> dropBehav db where grantOptFor GrantOptionFor = texts ["grant","option","for"] - grantOptFor NoGrantOptionFor = empty + grantOptFor NoGrantOptionFor = mempty statement _ (RevokeRole ao rs trs db) = - text "revoke" + pretty "revoke" <+> adminOptFor ao <+> commaSep (map name rs) - <+> text "from" <+> commaSep (map name trs) + <+> pretty "from" <+> commaSep (map name trs) <+> dropBehav db where adminOptFor AdminOptionFor = texts ["admin","option","for"] - adminOptFor NoAdminOptionFor = empty + adminOptFor NoAdminOptionFor = mempty -statement _ (StatementComment cs) = vcat $ map comment cs -statement _ EmptyStatement = empty +statement _ (StatementComment cs) = vsep $ map comment cs +statement _ EmptyStatement = mempty {- @@ -675,79 +692,81 @@ statement _ EmptyStatement = empty == extras -} -dropBehav :: DropBehaviour -> Doc -dropBehav DefaultDropBehaviour = empty -dropBehav Cascade = text "cascade" -dropBehav Restrict = text "restrict" +dropBehav :: DropBehaviour -> Doc a +dropBehav DefaultDropBehaviour = mempty +dropBehav Cascade = pretty "cascade" +dropBehav Restrict = pretty "restrict" -columnDef :: Dialect -> ColumnDef -> Doc +columnDef :: Dialect -> ColumnDef -> Doc a columnDef d (ColumnDef n t mdef cons) = name n <+> typeName t <+> case mdef of - Nothing -> empty + Nothing -> mempty Just (DefaultClause def) -> - text "default" <+> scalarExpr d def + pretty "default" <+> scalarExpr d def Just (GenerationClause e) -> texts ["generated","always","as"] <+> parens (scalarExpr d e) Just (IdentityColumnSpec w o) -> - text "generated" + pretty "generated" <+> (case w of - GeneratedAlways -> text "always" - GeneratedByDefault -> text "by" <+> text "default") - <+> text "as" <+> text "identity" + GeneratedAlways -> pretty "always" + GeneratedByDefault -> pretty "by" <+> pretty "default") + <+> pretty "as" <+> pretty "identity" <+> (case o of - [] -> empty + [] -> mempty os -> parens (sep $ map sequenceGeneratorOption os)) <+> sep (map cdef cons) where cdef (ColConstraintDef cnm con) = - maybe empty (\s -> text "constraint" <+> names s) cnm + maybe mempty (\s -> pretty "constraint" <+> names s) cnm <+> pcon con pcon ColNotNullConstraint = texts ["not","null"] - pcon ColUniqueConstraint = text "unique" + pcon ColNullableConstraint = texts ["null"] + pcon ColUniqueConstraint = pretty "unique" pcon (ColPrimaryKeyConstraint autoincrement) = texts $ ["primary","key"] ++ ["autoincrement"|autoincrement] - pcon (ColCheckConstraint v) = text "check" <+> parens (scalarExpr d v) + --pcon ColPrimaryKeyConstraint = texts ["primary","key"] + pcon (ColCheckConstraint v) = pretty "check" <+> parens (scalarExpr d v) pcon (ColReferencesConstraint tb c m u del) = - text "references" + pretty "references" <+> names tb - <+> maybe empty (\c' -> parens (name c')) c + <+> maybe mempty (\c' -> parens (name c')) c <+> refMatch m <+> refAct "update" u <+> refAct "delete" del -sequenceGeneratorOption :: SequenceGeneratorOption -> Doc +sequenceGeneratorOption :: SequenceGeneratorOption -> Doc a sequenceGeneratorOption (SGODataType t) = - text "as" <+> typeName t + pretty "as" <+> typeName t sequenceGeneratorOption (SGORestart mi) = - text "restart" <+> maybe empty (\mi' -> texts ["with", show mi']) mi + pretty "restart" <+> maybe mempty (\mi' -> texts ["with", show mi']) mi sequenceGeneratorOption (SGOStartWith i) = texts ["start", "with", show i] sequenceGeneratorOption (SGOIncrementBy i) = texts ["increment", "by", show i] sequenceGeneratorOption (SGOMaxValue i) = texts ["maxvalue", show i] sequenceGeneratorOption SGONoMaxValue = texts ["no", "maxvalue"] sequenceGeneratorOption (SGOMinValue i) = texts ["minvalue", show i] sequenceGeneratorOption SGONoMinValue = texts ["no", "minvalue"] -sequenceGeneratorOption SGOCycle = text "cycle" -sequenceGeneratorOption SGONoCycle = text "no cycle" +sequenceGeneratorOption SGOCycle = pretty "cycle" +sequenceGeneratorOption SGONoCycle = pretty "no cycle" -refMatch :: ReferenceMatch -> Doc +refMatch :: ReferenceMatch -> Doc a refMatch m = case m of - DefaultReferenceMatch -> empty + DefaultReferenceMatch -> mempty MatchFull -> texts ["match", "full"] MatchPartial -> texts ["match","partial"] MatchSimple -> texts ["match", "simple"] -refAct :: String -> ReferentialAction -> Doc +refAct :: String -> ReferentialAction -> Doc a refAct t a = case a of - DefaultReferentialAction -> empty + DefaultReferentialAction -> mempty RefCascade -> texts ["on", t, "cascade"] RefSetNull -> texts ["on", t, "set", "null"] RefSetDefault -> texts ["on", t, "set", "default"] RefRestrict -> texts ["on", t, "restrict"] RefNoAction -> texts ["on", t, "no", "action"] -alterTableAction :: Dialect -> AlterTableAction -> Doc +alterTableAction :: Dialect -> AlterTableAction -> Doc a alterTableAction d (AddColumnDef cd) = texts ["add", "column"] <+> columnDef d cd @@ -782,8 +801,8 @@ alterTableAction _ (DropColumn n b) = <+> dropBehav b alterTableAction d (AddTableConstraintDef n con) = - text "add" - <+> maybe empty (\s -> text "constraint" <+> names s) n + pretty "add" + <+> maybe mempty (\s -> pretty "constraint" <+> names s) n <+> tableConstraint d con alterTableAction _ (DropTableConstraintDef n b) = @@ -792,57 +811,63 @@ alterTableAction _ (DropTableConstraintDef n b) = <+> dropBehav b -tableConstraint :: Dialect -> TableConstraint -> Doc +tableConstraint :: Dialect -> TableConstraint -> Doc a tableConstraint _ (TableUniqueConstraint ns) = - text "unique" <+> parens (commaSep $ map name ns) + pretty "unique" <+> parens (commaSep $ map name ns) tableConstraint _ (TablePrimaryKeyConstraint ns) = texts ["primary","key"] <+> parens (commaSep $ map name ns) tableConstraint _ (TableReferencesConstraint cs t tcs m u del) = texts ["foreign", "key"] <+> parens (commaSep $ map name cs) - <+> text "references" + <+> pretty "references" <+> names t - <+> maybe empty (\c' -> parens (commaSep $ map name c')) tcs + <+> maybe mempty (\c' -> parens (commaSep $ map name c')) tcs <+> refMatch m <+> refAct "update" u <+> refAct "delete" del -tableConstraint d (TableCheckConstraint v) = text "check" <+> parens (scalarExpr d v) +tableConstraint d (TableCheckConstraint v) = pretty "check" <+> parens (scalarExpr d v) -privAct :: PrivilegeAction -> Doc +privAct :: PrivilegeAction -> Doc a privAct PrivAll = texts ["all","privileges"] -privAct (PrivSelect cs) = text "select" <+> maybeColList cs -privAct (PrivInsert cs) = text "insert" <+> maybeColList cs -privAct (PrivUpdate cs) = text "update" <+> maybeColList cs -privAct (PrivReferences cs) = text "references" <+> maybeColList cs -privAct PrivDelete = text "delete" -privAct PrivUsage = text "usage" -privAct PrivTrigger = text "trigger" -privAct PrivExecute = text "execute" +privAct (PrivSelect cs) = pretty "select" <+> maybeColList cs +privAct (PrivInsert cs) = pretty "insert" <+> maybeColList cs +privAct (PrivUpdate cs) = pretty "update" <+> maybeColList cs +privAct (PrivReferences cs) = pretty "references" <+> maybeColList cs +privAct PrivDelete = pretty "delete" +privAct PrivUsage = pretty "usage" +privAct PrivTrigger = pretty "trigger" +privAct PrivExecute = pretty "execute" -maybeColList :: [Name] -> Doc +maybeColList :: [Name] -> Doc a maybeColList cs = if null cs - then empty + then mempty else parens (commaSep $ map name cs) -privObj :: PrivilegeObject -> Doc +privObj :: PrivilegeObject -> Doc a privObj (PrivTable nm) = names nm -privObj (PrivDomain nm) = text "domain" <+> names nm -privObj (PrivType nm) = text "type" <+> names nm -privObj (PrivSequence nm) = text "sequence" <+> names nm +privObj (PrivDomain nm) = pretty "domain" <+> names nm +privObj (PrivType nm) = pretty "type" <+> names nm +privObj (PrivSequence nm) = pretty "sequence" <+> names nm privObj (PrivFunction nm) = texts ["specific", "function"] <+> names nm -- = utils -commaSep :: [Doc] -> Doc +commaSep :: [Doc a] -> Doc a commaSep ds = sep $ punctuate comma ds -me :: (a -> Doc) -> Maybe a -> Doc -me = maybe empty +me :: (b -> Doc a) -> Maybe b -> Doc a +me = maybe mempty -comment :: Comment -> Doc -comment (BlockComment str) = text "/*" <+> text str <+> text "*/" +comment :: Comment -> Doc a +comment (BlockComment str) = pretty "/*" <+> pretty str <+> pretty "*/" -texts :: [String] -> Doc -texts ts = sep $ map text ts +texts :: [String] -> Doc a +texts ts = sep $ map pretty ts + +-- regular pretty completely defeats the type checker when you want +-- to change the ast and get type errors, instead it just produces +-- incorrect code. +pretty :: String -> Doc a +pretty = P.pretty . T.pack diff --git a/simple-sql-parser.cabal b/simple-sql-parser.cabal index 32bad3a..002f529 100644 --- a/simple-sql-parser.cabal +++ b/simple-sql-parser.cabal @@ -41,7 +41,8 @@ common shared-properties build-depends: base >=4 && <5, parsec >=3.1 && <3.2, mtl >=2.1 && <2.4, - pretty >= 1.1 && < 1.2 + prettyprinter >= 1.7 && < 1.8, + text >= 2.1 && < 2.2 ghc-options: -Wall