simple-sql-parser/Language/SQL/SimpleSQL/Pretty.lhs

> -- | These is the pretty printing functions, which produce SQL
> -- source from ASTs. The code attempts to format the output in a
> -- readable way.
> module Language.SQL.SimpleSQL.Pretty
>     (prettyQueryExpr
>     ,prettyScalarExpr
>     ,prettyStatement
>     ,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 Data.Maybe (maybeToList, catMaybes)
> import Data.List (intercalate)


> import Language.SQL.SimpleSQL.Syntax
> import Language.SQL.SimpleSQL.Dialect


> -- | Convert a query expr ast to concrete syntax.
> prettyQueryExpr :: Dialect -> QueryExpr -> String
> prettyQueryExpr d = render . queryExpr d

> -- | Convert a value expr ast to concrete syntax.
> prettyScalarExpr :: Dialect -> ScalarExpr -> String
> prettyScalarExpr d = render . scalarExpr d

> -- | A terminating semicolon.
> terminator :: Doc
> terminator = text ";\n"

> -- | Convert a statement ast to concrete syntax.
> prettyStatement :: Dialect -> Statement -> String
> prettyStatement _ EmptyStatement = render terminator
> 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
>   where
>     prettyStatementWithSemicolon :: Statement -> Doc
>     prettyStatementWithSemicolon s = statement d s <> terminator

= scalar expressions

> scalarExpr :: Dialect -> ScalarExpr -> Doc
> scalarExpr _ (StringLit s e t) = text s <> text t <> text e

> scalarExpr _ (NumLit s) = text s
> scalarExpr _ (IntervalLit s v f t) =
>     text "interval"
>     <+> me (\x -> text $ case x of
>                              Plus -> "+"
>                              Minus -> "-") s
>     <+> quotes (text v)
>     <+> intervalTypeField f
>     <+> me (\x -> text "to" <+> intervalTypeField x) t
> scalarExpr _ (Iden i) = names i
> scalarExpr _ Star = text "*"
> scalarExpr _ Parameter = text "?"
> scalarExpr _ (PositionalArg n) = text $ "$" ++ show n
> scalarExpr _ (HostParameter p i) =
>     text p
>     <+> me (\i' -> text "indicator" <+> text 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)
>                <+> commaSep (map (scalarExpr dia) es)
>                <+> orderBy dia od)
>     <+> me (\x -> text "filter"
>                   <+> parens (text "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)

> scalarExpr d (WindowApp f es pb od fr) =
>     names f <> parens (commaSep $ map (scalarExpr d) es)
>     <+> text "over"
>     <+> parens ((case pb of
>                     [] -> empty
>                     _ -> text "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 = 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"

> 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]

> scalarExpr d (SpecialOp [Name Nothing "rowctor"] as) =
>     parens $ commaSep $ map (scalarExpr d) as

> scalarExpr d (SpecialOp nm es) =
>   names nm <+> parens (commaSep $ map (scalarExpr d) 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))

> 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
>     -- nicely
>     case ands e of
>       (e':es) -> vcat (scalarExpr d e'
>                        : map ((names op <+>) . scalarExpr d) es)
>       [] -> empty -- 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 (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]
>           ++ map w ws
>           ++ maybeToList (fmap e els)
>           ++ [text "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)
> scalarExpr d (Parens e) = parens $ scalarExpr d e
> scalarExpr d (Cast e tn) =
>     text "cast" <> parens (sep [scalarExpr d e
>                                ,text "as"
>                                ,typeName tn])

> scalarExpr _ (TypedLit tn s) =
>     typeName tn <+> quotes (text s)

> scalarExpr d (SubQueryExpr ty qe) =
>     (case ty of
>         SqSq -> empty
>         SqExists -> text "exists"
>         SqUnique -> text "unique"
>     ) <+> parens (queryExpr d qe)

> scalarExpr d (QuantifiedComparison v c cp sq) =
>     scalarExpr d v
>     <+> names c
>     <+> (text $ case cp of
>              CPAny -> "any"
>              CPSome -> "some"
>              CPAll -> "all")
>     <+> parens (queryExpr d sq)

> scalarExpr d (Match v u sq) =
>     scalarExpr d v
>     <+> text "match"
>     <+> (if u then text "unique" else empty)
>     <+> parens (queryExpr d sq)

> scalarExpr d (In b se x) =
>     scalarExpr d se <+>
>     (if b then empty else text "not")
>     <+> text "in"
>     <+> parens (nest (if b then 3 else 7) $
>                  case x of
>                      InList es -> commaSep $ map (scalarExpr d) es
>                      InQueryExpr qe -> queryExpr d qe)

> scalarExpr d (Array v es) =
>     scalarExpr d v <> brackets (commaSep $ map (scalarExpr d) es)

> scalarExpr d (ArrayCtor q) =
>     text "array" <> parens (queryExpr d q)

> scalarExpr d (MultisetCtor es) =
>     text "multiset" <> brackets (commaSep $ map (scalarExpr d) es)

> scalarExpr d (MultisetQueryCtor q) =
>     text "multiset" <> parens (queryExpr d q)

> scalarExpr d (MultisetBinOp a c q b) =
>     sep
>     [scalarExpr d a
>     ,text "multiset"
>     ,text $ case c of
>                 Union -> "union"
>                 Intersect -> "intersect"
>                 Except -> "except"
>     ,case q of
>          SQDefault -> empty
>          All -> text "all"
>          Distinct -> text "distinct"
>     ,scalarExpr d b]

> {-scalarExpr d (Escape v e) =
>     scalarExpr d v <+> text "escape" <+> text [e]

> scalarExpr d (UEscape v e) =
>     scalarExpr d v <+> text "uescape" <+> text [e]-}

> scalarExpr d (Collate v c) =
>     scalarExpr d v <+> text "collate" <+> names c

> scalarExpr _ (NextValueFor ns) =
>     text "next value for" <+> names ns

> scalarExpr d (VEComment cmt v) =
>     vcat $ map comment cmt ++ [scalarExpr d v]

> scalarExpr _ (OdbcLiteral t s) =
>     text "{" <> lt t <+> quotes (text s) <> text "}"
>   where
>     lt OLDate = text "d"
>     lt OLTime = text "t"
>     lt OLTimestamp = text "ts"

> scalarExpr d (OdbcFunc e) =
>     text "{fn" <+> scalarExpr d e <> text "}"

> scalarExpr d (Convert t e Nothing) =
>     text "convert(" <> typeName t <> text "," <+> scalarExpr d e <> text ")"
> scalarExpr d (Convert t e (Just i)) =
>     text "convert(" <> typeName t <> text "," <+> scalarExpr d e <> text "," <+> text (show i) <> text ")"

> unname :: Name -> String
> unname (Name Nothing n) = n
> unname (Name (Just (s,e)) n) =
>     s ++ n ++ e

> 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

> names :: [Name] -> Doc
> names ns = hcat $ punctuate (text ".") $ map name ns

> typeName :: TypeName -> Doc
> typeName (TypeName t) = names t
> typeName (PrecTypeName t a) = names t <+> parens (text $ show a)
> typeName (PrecScaleTypeName t a b) =
>     names t <+> parens (text (show a) <+> comma <+> text (show b))
> typeName (PrecLengthTypeName t i m u) =
>     names t
>     <> parens (text (show i)
>                <> me (\x -> case x of
>                            PrecK -> text "K"
>                            PrecM -> text "M"
>                            PrecG -> text "G"
>                            PrecT -> text "T"
>                            PrecP -> text "P") m
>                <+> me (\x -> case x of
>                        PrecCharacters -> text "CHARACTERS"
>                        PrecOctets -> text "OCTETS") u)
> typeName (CharTypeName t i cs col) =
>     names t
>     <> me (\x -> parens (text $ show x)) i
>     <+> (if null cs
>          then empty
>          else text "character set" <+> names cs)
>     <+> (if null col
>          then empty
>          else text "collate" <+> names col)
> typeName (TimeTypeName t i tz) =
>     names t
>     <> me (\x -> parens (text $ show x)) i
>     <+> text (if tz
>               then "with time zone"
>               else "without time zone")
> typeName (RowTypeName cs) =
>     text "row" <> parens (commaSep $ map f cs)
>   where
>     f (n,t) = name n <+> typeName t
> typeName (IntervalTypeName f t) =
>     text "interval"
>     <+> intervalTypeField f
>     <+> me (\x -> text "to" <+> intervalTypeField x) t

> typeName (ArrayTypeName tn sz) =
>     typeName tn <+> text "array" <+> me (brackets . text . show) sz

> typeName (MultisetTypeName tn) =
>     typeName tn <+> text "multiset"

> intervalTypeField :: IntervalTypeField -> Doc
> intervalTypeField (Itf n p) =
>     text n
>     <+> me (\(x,x1) ->
>              parens (text (show x)
>                      <+> me (\y -> (sep [comma,text (show y)])) x1)) p


= query expressions

> queryExpr :: Dialect -> QueryExpr -> Doc
> queryExpr dia (Select d sl fr wh gb hv od off fe) =
>   sep [text "select"
>       ,case d of
>           SQDefault -> empty
>           All -> text "all"
>           Distinct -> text "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
>       ,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

> queryExpr dia (QueryExprSetOp q1 ct d c q2) =
>   sep [queryExpr dia q1
>       ,text (case ct of
>                 Union -> "union"
>                 Intersect -> "intersect"
>                 Except -> "except")
>        <+> case d of
>                SQDefault -> empty
>                All -> text "all"
>                Distinct -> text "distinct"
>        <+> case c of
>                Corresponding -> text "corresponding"
>                Respectively -> empty
>       ,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))
>            ,queryExpr d qe]
>   where
>     withAlias (Alias nm cols) = name nm
>                                 <+> me (parens . commaSep . map name) cols


> queryExpr d (Values vs) =
>     text "values"
>     <+> nest 7 (commaSep (map (parens . commaSep . map (scalarExpr d)) vs))
> queryExpr _ (Table t) = text "table" <+> names t
> queryExpr d (QEComment cmt v) =
>     vcat $ map comment cmt ++ [queryExpr d v]


> alias :: Alias -> Doc
> alias (Alias nm cols) =
>     text "as" <+> name nm
>     <+> me (parens . commaSep . map name) cols

> selectList :: Dialect -> [(ScalarExpr,Maybe Name)] -> Doc
> selectList d is = commaSep $ map si is
>   where
>     si (e,al) = scalarExpr d e <+> me als al
>     als al = text "as" <+> name al

> from :: Dialect -> [TableRef] -> Doc
> from _ [] = empty
> from d ts =
>     sep [text "from"
>         ,nest 5 $ vcat $ punctuate comma $ map tr ts]
>   where
>     tr (TRSimple t) = names t
>     tr (TRLateral t) = text "lateral" <+> tr t
>     tr (TRFunction f as) =
>         names f <> parens (commaSep $ map (scalarExpr d) as)
>     tr (TRAlias t a) = sep [tr t, alias a]
>     tr (TRParens t) = parens $ tr t
>     tr (TRQueryExpr q) = parens $ queryExpr d q
>     tr (TRJoin t0 b jt t1 jc) =
>        sep [tr t0
>            ,if b then text "natural" else empty
>            ,joinText jt <+> tr t1
>            ,joinCond jc]
>     tr (TROdbc t) = text "{oj" <+> tr t <+> text "}"
>     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
>     joinCond (Just (JoinUsing es)) =
>         text "using" <+> parens (commaSep $ map name es)
>     joinCond Nothing = empty

> maybeScalarExpr :: Dialect -> String -> Maybe ScalarExpr -> Doc
> maybeScalarExpr d k = me
>       (\e -> sep [text 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]
>   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)

> orderBy :: Dialect -> [SortSpec] -> Doc
> orderBy _ [] = empty
> orderBy dia os = sep [text "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)
>         <+> (case n of
>                 NullsOrderDefault -> empty
>                 NullsFirst -> text "nulls" <+> text "first"
>                 NullsLast -> text "nulls" <+> text "last")

= statements

> statement :: Dialect -> Statement -> Doc


== ddl

> statement _ (CreateSchema nm) =
>     text "create" <+> text "schema" <+> names nm

> statement d (CreateTable nm cds) =
>     text "create" <+> text "table" <+> names nm
>     <+> parens (commaSep $ map cd cds)
>   where
>     cd (TableConstraintDef n con) =
>         maybe empty (\s -> text "constraint" <+> names s) n
>         <+> tableConstraint d con
>     cd (TableColumnDef cd') = columnDef d cd'

> statement d (AlterTable t act) =
>     texts ["alter","table"] <+> names t
>     <+> alterTableAction d act

> statement _ (DropSchema nm db) =
>     text "drop" <+> text "schema" <+> names nm <+> dropBehav db

> statement d (CreateDomain nm ty def cs) =
>     text "create" <+> text "domain" <+> names nm
>     <+> typeName ty
>     <+> maybe empty (\def' -> text "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)

> statement d (AlterDomain nm act) =
>     texts ["alter","domain"]
>     <+> names nm
>     <+> a act
>   where
>     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)
>     a (ADDropConstraint cnm) = texts ["drop", "constraint"]
>                                <+> names cnm


> statement _ (DropDomain nm db) =
>     text "drop" <+> text "domain" <+> names nm <+> dropBehav db

> statement _ (CreateSequence nm sgos) =
>   texts ["create","sequence"] <+> names nm
>   <+> sep (map sequenceGeneratorOption sgos)

> statement _ (AlterSequence nm sgos) =
>   texts ["alter","sequence"] <+> names nm
>   <+> sep (map sequenceGeneratorOption sgos)

> statement _ (DropSequence nm db) =
>     text "drop" <+> text "sequence" <+> names nm <+> dropBehav db


> statement d (CreateAssertion nm ex) =
>   texts ["create","assertion"] <+> names nm
>   <+> text "check" <+> parens (scalarExpr d ex)

> statement _ (DropAssertion nm db) =
>     text "drop" <+> text "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"
>   <+> names tbl
>   <+> parens (commaSep $ map name cols)

== dml

> 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
>     <+> maybeScalarExpr d "where" w

> statement _ (Truncate t ir) =
>     text "truncate" <+> text "table" <+> names t
>     <+> case ir of
>             DefaultIdentityRestart -> empty
>             ContinueIdentity -> text "continue" <+> text "identity"
>             RestartIdentity -> text "restart" <+> text "identity"

> statement d (Insert t cs s) =
>     text "insert" <+> text "into" <+> names t
>     <+> maybe empty (\cs' -> parens (commaSep $ map name cs')) cs
>     <+> case s of
>             DefaultInsertValues -> text "default" <+> text "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)
>     <+> 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 "="
>                              <+> parens (commaSep $ map (scalarExpr d) vs)

> statement _ (DropTable n b) =
>     text "drop" <+> text "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"
>     <+> queryExpr d q
>     <+> case co of
>             Nothing -> empty
>             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


== transactions

> statement _ StartTransaction =
>     texts ["start", "transaction"]

> statement _ (Savepoint nm) =
>     text "savepoint" <+> name nm

> statement _ (ReleaseSavepoint nm) =
>     texts ["release", "savepoint"] <+> name nm

> statement _ Commit =
>     text "commit"

> statement _ (Rollback mn) =
>     text "rollback"
>     <+> maybe empty (\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)
>     <+> grantOpt go
>   where
>     grantOpt WithGrantOption = texts ["with","grant","option"]
>     grantOpt WithoutGrantOption = empty

> statement _ (GrantRole rs trs ao) =
>     text "grant" <+> commaSep (map name rs)
>     <+> text "to" <+> commaSep (map name trs)
>     <+> adminOpt ao
>   where
>     adminOpt WithAdminOption = texts ["with","admin","option"]
>     adminOpt WithoutAdminOption = empty

> statement _ (CreateRole nm) =
>     texts ["create","role"] <+> name nm

> statement _ (DropRole nm) =
>     texts ["drop","role"] <+> name nm

> statement _ (RevokePrivilege go pas po rs db) =
>     text "revoke"
>     <+> grantOptFor go
>     <+> commaSep (map privAct pas)
>     <+> text "on" <+> privObj po
>     <+> text "from" <+> commaSep (map name rs)
>     <+> dropBehav db
>   where
>     grantOptFor GrantOptionFor = texts ["grant","option","for"]
>     grantOptFor NoGrantOptionFor = empty

> statement _ (RevokeRole ao rs trs db) =
>     text "revoke"
>     <+> adminOptFor ao
>     <+> commaSep (map name rs)
>     <+> text "from" <+> commaSep (map name trs)
>     <+> dropBehav db
>   where
>     adminOptFor AdminOptionFor = texts ["admin","option","for"]
>     adminOptFor NoAdminOptionFor = empty


> statement _ (StatementComment cs) = vcat $ map comment cs
> statement _ EmptyStatement = empty


== sessions


== extras

> dropBehav :: DropBehaviour -> Doc
> dropBehav DefaultDropBehaviour = empty
> dropBehav Cascade = text "cascade"
> dropBehav Restrict = text "restrict"


> columnDef :: Dialect -> ColumnDef -> Doc
> columnDef d (ColumnDef n t mdef cons) =
>       name n <+> typeName t
>       <+> case mdef of
>              Nothing -> empty
>              Just (DefaultClause def) ->
>                  text "default" <+> scalarExpr d def
>              Just (GenerationClause e) ->
>                  texts ["generated","always","as"] <+> parens (scalarExpr d e)
>              Just (IdentityColumnSpec w o) ->
>                  text "generated"
>                  <+> (case w of
>                          GeneratedAlways -> text "always"
>                          GeneratedByDefault -> text "by" <+> text "default")
>                  <+> text "as" <+> text "identity"
>                  <+> (case o of
>                          [] -> empty
>                          os -> parens (sep $ map sequenceGeneratorOption os))
>       <+> sep (map cdef cons)
>   where
>     cdef (ColConstraintDef cnm con) =
>         maybe empty (\s -> text "constraint" <+> names s) cnm
>         <+> pcon con
>     pcon ColNotNullConstraint = texts ["not","null"]
>     pcon ColUniqueConstraint = text "unique"
>     pcon ColPrimaryKeyConstraint = texts ["primary","key"]
>     pcon (ColCheckConstraint v) = text "check" <+> parens (scalarExpr d v)
>     pcon (ColReferencesConstraint tb c m u del) =
>         text "references"
>         <+> names tb
>         <+> maybe empty (\c' -> parens (name c')) c
>         <+> refMatch m
>         <+> refAct "update" u
>         <+> refAct "delete" del

> sequenceGeneratorOption :: SequenceGeneratorOption -> Doc
> sequenceGeneratorOption (SGODataType t) =
>     text "as" <+> typeName t
> sequenceGeneratorOption (SGORestart mi) =
>     text "restart" <+> maybe empty (\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"

> refMatch :: ReferenceMatch -> Doc
> refMatch m = case m of
>                      DefaultReferenceMatch -> empty
>                      MatchFull -> texts ["match", "full"]
>                      MatchPartial -> texts ["match","partial"]
>                      MatchSimple -> texts ["match", "simple"]

> refAct :: String -> ReferentialAction -> Doc
> refAct t a = case a of
>                      DefaultReferentialAction -> empty
>                      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 d (AddColumnDef cd) =
>     texts ["add", "column"] <+> columnDef d cd

> alterTableAction d (AlterColumnSetDefault n v) =
>     texts ["alter", "column"]
>     <+> name n
>     <+> texts ["set","default"] <+> scalarExpr d v
> alterTableAction _ (AlterColumnDropDefault n) =
>     texts ["alter", "column"]
>     <+> name n
>     <+> texts ["drop","default"]

> alterTableAction _ (AlterColumnSetNotNull n) =
>     texts ["alter", "column"]
>     <+> name n
>     <+> texts ["set","not","null"]

> alterTableAction _ (AlterColumnDropNotNull n) =
>     texts ["alter", "column"]
>     <+> name n
>     <+> texts ["drop","not","null"]

> alterTableAction _ (AlterColumnSetDataType n t) =
>     texts ["alter", "column"]
>     <+> name n
>     <+> texts ["set","data","Type"]
>     <+> typeName t

> alterTableAction _ (DropColumn n b) =
>     texts ["drop", "column"]
>     <+> name n
>     <+> dropBehav b

> alterTableAction d (AddTableConstraintDef n con) =
>     text "add"
>     <+> maybe empty (\s -> text "constraint" <+> names s) n
>     <+> tableConstraint d con

> alterTableAction _ (DropTableConstraintDef n b) =
>     texts ["drop", "constraint"]
>     <+> names n
>     <+> dropBehav b


> tableConstraint :: Dialect -> TableConstraint -> Doc
> tableConstraint _ (TableUniqueConstraint ns) =
>          text "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"
>         <+> names t
>         <+> maybe empty (\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)


> privAct :: PrivilegeAction -> Doc
> 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"

> maybeColList :: [Name] -> Doc
> maybeColList cs =
>     if null cs
>     then empty
>     else parens (commaSep $ map name cs)

> privObj :: PrivilegeObject -> Doc
> 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 (PrivFunction nm) = texts ["specific", "function"] <+> names nm

= utils

> commaSep :: [Doc] -> Doc
> commaSep ds = sep $ punctuate comma ds

> me :: (a -> Doc) -> Maybe a -> Doc
> me = maybe empty

> comment :: Comment -> Doc
> comment (BlockComment str) = text "/*" <+> text str <+> text "*/"

> texts :: [String] -> Doc
> texts ts = sep $ map text ts