content: 
  -- | 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 #-}
  {-# LANGUAGE LambdaCase #-}
  module Language.SQL.SimpleSQL.Pretty
      (prettyQueryExpr
      ,prettyScalarExpr
      ,prettyStatement
      ,prettyStatements
      ) where
  
  {-
  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.
  -}
  
  import Prettyprinter (Doc
                       ,nest
                       ,punctuate
                       ,comma
                       ,squotes
                       ,vsep
                       ,layoutPretty
                       ,defaultLayoutOptions
                       ,brackets
                       ,align
                       ,hcat
                       ,line
                       )
  import qualified Prettyprinter as P
  import Prettyprinter.Internal.Type (Doc(Empty))
  
  import Prettyprinter.Render.Text (renderStrict)
  
  import Data.Maybe (maybeToList, catMaybes)
  
  import qualified Data.Text as T
  import Data.Text (Text)
  
  import Language.SQL.SimpleSQL.Syntax
  import Language.SQL.SimpleSQL.Dialect
  
  
  -- | Convert a query expr ast to Text.
  prettyQueryExpr :: Dialect -> QueryExpr -> Text
  prettyQueryExpr d = render . queryExpr d
  
  -- | Convert a value expr ast to Text.
  prettyScalarExpr :: Dialect -> ScalarExpr -> Text
  prettyScalarExpr d = render . scalarExpr d
  
  -- | A terminating semicolon.
  terminator :: Doc a
  terminator = pretty ";" <> line
  
  -- | Convert a statement ast to Text.
  prettyStatement :: Dialect -> Statement -> Text
  prettyStatement _ EmptyStatement = render terminator
  prettyStatement d s = render (statement d s)
  
  -- | Convert a list of statements to Text. A semicolon
  -- is inserted after each statement.
  prettyStatements :: Dialect -> [Statement] -> Text
  prettyStatements d = render . vsep . map prettyStatementWithSemicolon
    where
      prettyStatementWithSemicolon :: Statement -> Doc a
      prettyStatementWithSemicolon s = statement d s <> terminator
  
  render :: Doc a -> Text
  render = renderStrict . layoutPretty defaultLayoutOptions
  
  -- = scalar expressions
  
  scalarExpr :: Dialect -> ScalarExpr -> Doc a
  scalarExpr _ (StringLit s e t) = pretty s <> pretty t <> pretty e
  
  scalarExpr _ (NumLit s) = pretty s
  scalarExpr _ (IntervalLit s v f t) =
      pretty "interval"
      <+> me (\x -> pretty $ case x of
                               Plus -> "+"
                               Minus -> "-") s
      <+> squotes (pretty v)
      <+> intervalTypeField f
      <+> me (\x -> pretty "to" <+> intervalTypeField x) t
  scalarExpr _ (Iden i) = names i
  scalarExpr _ Star = pretty "*"
  scalarExpr _ (QStar nms) = names nms <> pretty ".*"
  scalarExpr _ Parameter = pretty "?"
  scalarExpr _ (PositionalArg n) = pretty $ T.cons '$' $ showText n
  scalarExpr _ (HostParameter p 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 -> pretty "distinct"
                    All -> pretty "all"
                    SQDefault -> mempty)
                 <+> commaSep (map (scalarExpr dia) es)
                 <+> orderBy dia od))
      <+> 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 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)
      <+> pretty "over"
      <+> parens ((case pb of
                      [] -> mempty
                      _ -> pretty "partition by" <+> align
                                     (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 <+> pretty "between" <+> fpd fps
          <+> pretty "and" <+> fpd fpe
      rsd rs = case rs of
                   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 <+> nest (T.length (unnames nm) - 3) (sep
            [scalarExpr dia b
            ,pretty "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 (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 vsep them
      -- nicely
      case ands e of
        (e':es) -> vsep (scalarExpr d e'
                         : map ((names op <+>) . scalarExpr d) es)
        [] -> 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 <> 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 $ [pretty "case" <+> me (scalarExpr dia) t]
            <> map w ws
            <> maybeToList (fmap e els)
            <> [pretty "end"]
    where
      w (t0,t1) =
        pretty "when" <+> align (sep [commaSep $ map (scalarExpr dia) t0
                                     ,pretty "then" <+> align (scalarExpr dia t1)])
      e el = pretty "else" <+> align (scalarExpr dia el)
  scalarExpr d (Parens e) =
      parens (scalarExpr d e)
  scalarExpr d (Cast e tn) =
      pretty "cast" <> parens (sep [scalarExpr d e
                                   ,pretty "as"
                                   ,typeName tn])
  
  scalarExpr _ (TypedLit tn s) =
      typeName tn <+> squotes (pretty s)
  
  scalarExpr d (SubQueryExpr ty qe) =
      (case ty of
          SqSq -> mempty
          SqExists -> pretty "exists"
          SqUnique -> pretty "unique"
      ) <+> parens (queryExpr d qe)
  
  scalarExpr d (QuantifiedComparison v c cp sq) =
      scalarExpr d v
      <+> names c
      <+> pretty (case cp of
                      CPAny -> "any"
                      CPSome -> "some"
                      CPAll -> "all")
      <+> parens (queryExpr d sq)
  
  scalarExpr d (Match v u sq) =
      scalarExpr d v
      <+> 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 mempty else pretty "not")
      <+> pretty "in"
      <+> parens (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) =
      pretty "array" <> parens (queryExpr d q)
  
  scalarExpr d (MultisetCtor es) =
      pretty "multiset" <> brackets (commaSep $ map (scalarExpr d) es)
  
  scalarExpr d (MultisetQueryCtor q) =
      pretty "multiset" <> parens (queryExpr d q)
  
  scalarExpr d (MultisetBinOp a c q b) =
      sep
      [scalarExpr d a
      ,pretty "multiset"
      ,pretty $ case c of
                  Union -> "union"
                  Intersect -> "intersect"
                  Except -> "except"
      ,case q of
           SQDefault -> mempty
           All -> pretty "all"
           Distinct -> pretty "distinct"
      ,scalarExpr d b]
  
  {-scalarExpr d (Escape v e) =
      scalarExpr d v <+> pretty "escape" <+> pretty [e]
  
  scalarExpr d (UEscape v e) =
      scalarExpr d v <+> pretty "uescape" <+> pretty [e]-}
  
  scalarExpr d (Collate v c) =
      scalarExpr d v <+> pretty "collate" <+> names c
  
  scalarExpr _ (NextValueFor ns) =
      pretty "next value for" <+> names ns
  
  scalarExpr d (VEComment cmt v) =
      vsep $ map comment cmt <> [scalarExpr d v]
  
  scalarExpr _ (OdbcLiteral t s) =
      pretty "{" <> lt t <+> squotes (pretty s) <> pretty "}"
    where
      lt OLDate = pretty "d"
      lt OLTime = pretty "t"
      lt OLTimestamp = pretty "ts"
  
  scalarExpr d (OdbcFunc e) =
      pretty "{fn" <+> scalarExpr d e <> pretty "}"
  
  scalarExpr d (Convert t e Nothing) =
      pretty "convert(" <> typeName t <> pretty "," <+> scalarExpr d e <> pretty ")"
  scalarExpr d (Convert t e (Just i)) =
      pretty "convert(" <> typeName t <> pretty "," <+> scalarExpr d e <> pretty "," <+> pretty (showText i) <> pretty ")"
  
  unname :: Name -> Text
  unname (Name Nothing n) = n
  unname (Name (Just (s,e)) n) =
      s <> n <> e
  
  unnames :: [Name] -> Text
  unnames ns = T.intercalate "." $ map unname ns
  
  
  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 a
  names ns = hcat $ punctuate (pretty ".") $ map name ns
  
  typeName :: TypeName -> Doc a
  typeName (TypeName t) = names t
  typeName (PrecTypeName t a) = names t <+> parens (pretty $ showText a)
  typeName (PrecScaleTypeName t a b) =
      names t <+> parens (pretty (showText a) <+> comma <+> pretty (showText b))
  typeName (PrecLengthTypeName t i m u) =
      names t
      <> parens (pretty (showText i)
                 <> me (\case
                             PrecK -> pretty "K"
                             PrecM -> pretty "M"
                             PrecG -> pretty "G"
                             PrecT -> pretty "T"
                             PrecP -> pretty "P") m
                 <+> me (\case
                         PrecCharacters -> pretty "CHARACTERS"
                         PrecOctets -> pretty "OCTETS") u)
  typeName (CharTypeName t i cs col) =
      (names t
      <> me (\x -> parens (pretty $ showText x)) i)
      <+> (if null cs
           then mempty
           else pretty "character set" <+> names cs)
      <+> (if null col
           then mempty
           else pretty "collate" <+> names col)
  typeName (TimeTypeName t i tz) =
      (names t
      <> me (\x -> parens (pretty $ showText x)) i)
      <+> pretty (if tz
                then "with time zone"
                else "without time zone")
  typeName (RowTypeName cs) =
      pretty "row" <> parens (commaSep $ map f cs)
    where
      f (n,t) = name n <+> typeName t
  typeName (IntervalTypeName f t) =
      pretty "interval"
      <+> intervalTypeField f
      <+> me (\x -> pretty "to" <+> intervalTypeField x) t
  
  typeName (ArrayTypeName tn sz) =
      typeName tn <+> pretty "array" <+> me (brackets . pretty . showText) sz
  
  typeName (MultisetTypeName tn) =
      typeName tn <+> pretty "multiset"
  
  intervalTypeField :: IntervalTypeField -> Doc a
  intervalTypeField (Itf n p) =
      pretty n
      <+> me (\(x,x1) ->
               parens (pretty (showText x)
                       <+> me (\y -> sep [comma,pretty (showText y)]) x1)) p
  
  
  -- = query expressions
  
  queryExpr :: Dialect -> QueryExpr -> Doc a
  queryExpr dia (Select d sl fr wh gb hv od off fe) =
    sep [pretty "select" <+> align (sep
            [case d of
                 SQDefault -> mempty
                 All -> pretty "all"
                 Distinct -> pretty "distinct"
            ,selectList dia sl])
        ,from dia fr
        ,maybeScalarExpr dia "where" wh
        ,grpBy dia gb
        ,maybeScalarExpr dia "having" hv
        ,orderBy dia od
        ,me (\e -> pretty "offset" <+> scalarExpr dia e <+> pretty "rows") off
        ,fetchFirst
        ]
    where
      fetchFirst =
        me (\e -> if diLimit dia
                  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
        ,pretty (case ct of
                  Union -> "union"
                  Intersect -> "intersect"
                  Except -> "except")
         <+> case d of
                 SQDefault -> mempty
                 All -> pretty "all"
                 Distinct -> pretty "distinct"
         <+> case c of
                 Corresponding -> pretty "corresponding"
                 Respectively -> mempty
        ,queryExpr dia q2]
  queryExpr d (With rc withs qe) =
    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
                                  <+> me (parens . commaSep . map name) cols
  
  
  queryExpr d (Values vs) =
      pretty "values"
      <+> nest 7 (commaSep (map (parens . commaSep . map (scalarExpr d)) vs))
  queryExpr _ (Table t) = pretty "table" <+> names t
  queryExpr d (QueryExprParens qe) = parens (queryExpr d qe)
  queryExpr d (QEComment cmt v) =
      vsep $ map comment cmt <> [queryExpr d v]
  
  
  alias :: Alias -> Doc a
  alias (Alias nm cols) =
      pretty "as" <+> name nm
      <+> me (parens . commaSep . map name) cols
  
  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 = pretty "as" <+> name al
  
  from :: Dialect -> [TableRef] -> Doc a
  from _ [] = mempty
  from d ts =
      pretty "from" <+> align (vsep (punctuate comma $ map tr ts))
    where
      tr (TRSimple t) = names 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]
      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 pretty "natural" else mempty
             ,joinText jt <+> tr t1
             ,joinCond jc]
      tr (TROdbc t) = pretty "{oj" <+> tr t <+> pretty "}"
      joinText jt =
        sep [case jt of
                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)) =
          pretty "using" <+> parens (commaSep $ map name es)
      joinCond Nothing = mempty
  
  maybeScalarExpr :: Dialect -> Text -> Maybe ScalarExpr -> Doc a
  maybeScalarExpr d k = me
        (\e -> pretty k <+> align (scalarExpr d e))
  
  grpBy :: Dialect -> [GroupingExpr] -> Doc a
  grpBy _ [] = mempty
  grpBy d gs = pretty "group by" <+> align (commaSep $ map ge gs)
    where
      ge (SimpleGroup e) = scalarExpr d e
      ge (GroupingParens g) = parens (commaSep $ map ge g)
      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 a
  orderBy _ [] = mempty
  orderBy dia os = pretty "order by" <+> align (commaSep $ map f os)
    where
      f (SortSpec e d n) =
          scalarExpr dia e
          <+> (case d of
                    Asc -> pretty "asc"
                    Desc -> pretty "desc"
                    DirDefault -> mempty)
          <+> (case n of
                  NullsOrderDefault -> mempty
                  NullsFirst -> pretty "nulls" <+> pretty "first"
                  NullsLast -> pretty "nulls" <+> pretty "last")
  
  -- = statements
  
  statement :: Dialect -> Statement -> Doc a
  
  
  -- == ddl
  
  statement _ (CreateSchema nm) =
      pretty "create" <+> pretty "schema" <+> names nm
  
  statement d (CreateTable nm cds withoutRowid) =
      pretty "create" <+> pretty "table" <+> names nm
      <+> parens (commaSep $ map cd cds)
      <+> (if withoutRowid then texts [ "without", "rowid" ] else mempty)
    where
      cd (TableConstraintDef n con) =
          maybe mempty (\s -> pretty "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) =
      pretty "drop" <+> pretty "schema" <+> names nm <+> dropBehav db
  
  statement d (CreateDomain nm ty def cs) =
      pretty "create" <+> pretty "domain" <+> names nm
      <+> typeName ty
      <+> maybe mempty (\def' -> pretty "default" <+> scalarExpr d def') def
      <+> sep (map con cs)
    where
      con (cn, e) =
          maybe mempty (\cn' -> pretty "constraint" <+> names cn') cn
          <+> pretty "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) =
          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) =
      pretty "drop" <+> pretty "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) =
      pretty "drop" <+> pretty "sequence" <+> names nm <+> dropBehav db
  
  
  statement d (CreateAssertion nm ex) =
    texts ["create","assertion"] <+> names nm
    <+> pretty "check" <+> parens (scalarExpr d ex)
  
  statement _ (DropAssertion nm 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
    <+> pretty "on"
    <+> names tbl
    <+> parens (commaSep $ map name cols)
  
  -- == dml
  
  statement d (SelectStatement q) = queryExpr d q
  
  statement d (Delete t a w) =
      pretty "delete" <+> pretty "from"
      <+> names t <+> maybe mempty (\x -> pretty "as" <+> name x) a
      <+> maybeScalarExpr d "where" w
  
  statement _ (Truncate t ir) =
      pretty "truncate" <+> pretty "table" <+> names t
      <+> case ir of
              DefaultIdentityRestart -> mempty
              ContinueIdentity -> pretty "continue" <+> pretty "identity"
              RestartIdentity -> pretty "restart" <+> pretty "identity"
  
  statement d (Insert t cs s) =
      pretty "insert" <+> pretty "into" <+> names t
      <+> maybe mempty (\cs' -> parens (commaSep $ map name cs')) cs
      <+> case s of
              DefaultInsertValues -> pretty "default" <+> pretty "values"
              InsertQuery q -> queryExpr d q
  
  statement d (Update t a sts whr) =
      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 <+> pretty "=" <+> scalarExpr d v
      sc (SetMultiple ts vs) = parens (commaSep $ map names ts) <+> pretty "="
                               <+> parens (commaSep $ map (scalarExpr d) vs)
  
  statement _ (DropTable n b) =
      pretty "drop" <+> pretty "table" <+> names n <+> dropBehav b
  
  statement d (CreateView r nm al q co) =
      pretty "create" <+> (if r then pretty "recursive" else mempty)
      <+> pretty "view" <+> names nm
      <+> maybe mempty (parens . commaSep . map name) al
      <+> pretty "as"
      <+> queryExpr d q
      <+> case co of
              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) =
      pretty "drop" <+> pretty "view" <+> names n <+> dropBehav b
  
  
  -- == transactions
  
  statement _ StartTransaction =
      texts ["start", "transaction"]
  
  statement _ (Savepoint nm) =
      pretty "savepoint" <+> name nm
  
  statement _ (ReleaseSavepoint nm) =
      texts ["release", "savepoint"] <+> name nm
  
  statement _ Commit =
      pretty "commit"
  
  statement _ (Rollback mn) =
      pretty "rollback"
      <+> maybe mempty (\n -> texts ["to","savepoint"] <+> name n) mn
  
  -- == access control
  
  statement _ (GrantPrivilege pas po rs go) =
      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 = mempty
  
  statement _ (GrantRole rs trs ao) =
      pretty "grant" <+> commaSep (map name rs)
      <+> pretty "to" <+> commaSep (map name trs)
      <+> adminOpt ao
    where
      adminOpt WithAdminOption = texts ["with","admin","option"]
      adminOpt WithoutAdminOption = mempty
  
  statement _ (CreateRole nm) =
      texts ["create","role"] <+> name nm
  
  statement _ (DropRole nm) =
      texts ["drop","role"] <+> name nm
  
  statement _ (RevokePrivilege go pas po rs db) =
      pretty "revoke"
      <+> grantOptFor go
      <+> commaSep (map privAct pas)
      <+> pretty "on" <+> privObj po
      <+> pretty "from" <+> commaSep (map name rs)
      <+> dropBehav db
    where
      grantOptFor GrantOptionFor = texts ["grant","option","for"]
      grantOptFor NoGrantOptionFor = mempty
  
  statement _ (RevokeRole ao rs trs db) =
      pretty "revoke"
      <+> adminOptFor ao
      <+> commaSep (map name rs)
      <+> pretty "from" <+> commaSep (map name trs)
      <+> dropBehav db
    where
      adminOptFor AdminOptionFor = texts ["admin","option","for"]
      adminOptFor NoAdminOptionFor = mempty
  
  
  statement _ (StatementComment cs) = vsep $ map comment cs
  statement _ EmptyStatement = mempty
  
  
  {-
  == sessions
  
  
  == extras
  -}
  
  dropBehav :: DropBehaviour -> Doc a
  dropBehav DefaultDropBehaviour = mempty
  dropBehav Cascade = pretty "cascade"
  dropBehav Restrict = pretty "restrict"
  
  columnDef :: Dialect -> ColumnDef -> Doc a
  columnDef d (ColumnDef n t cons) =
        name n <+> maybe mempty typeName t
        <+> sep (map cdef cons)
    where
      cdef (ColConstraintDef cnm con) =
          maybe mempty (\s -> pretty "constraint" <+> names s) cnm
          <+> pcon con
      pcon ColNotNullConstraint = texts ["not","null"]
      pcon ColNullableConstraint = texts ["null"]
      pcon ColUniqueConstraint = pretty "unique"
      pcon (ColPrimaryKeyConstraint autoincrement) =
        texts $ ["primary","key"] <> ["autoincrement"|autoincrement]
      --pcon ColPrimaryKeyConstraint = texts ["primary","key"]
      pcon (ColCheckConstraint v) = pretty "check" <+> parens (scalarExpr d v)
      pcon (ColReferencesConstraint tb c m u del) =
          pretty "references"
          <+> names tb
          <+> maybe mempty (parens . name) c
          <+> refMatch m
          <+> refAct "update" u
          <+> refAct "delete" del
      pcon (ColDefaultClause clause) = case clause of
          DefaultClause def ->
              pretty "default" <+> scalarExpr d def
          GenerationClause e ->
              texts ["generated","always","as"] <+> parens (scalarExpr d e)
          IdentityColumnSpec w o ->
              pretty "generated"
              <+> (case w of
                      GeneratedAlways -> pretty "always"
                      GeneratedByDefault -> pretty "by" <+> pretty "default")
              <+> pretty "as" <+> pretty "identity"
              <+> (case o of
                      [] -> mempty
                      os -> parens (sep $ map sequenceGeneratorOption os))
  
  sequenceGeneratorOption :: SequenceGeneratorOption -> Doc a
  sequenceGeneratorOption (SGODataType t) =
      pretty "as" <+> typeName t
  sequenceGeneratorOption (SGORestart mi) =
      pretty "restart" <+> maybe mempty (\mi' -> texts ["with", showText mi']) mi
  sequenceGeneratorOption (SGOStartWith i) = texts ["start",  "with", showText i]
  sequenceGeneratorOption (SGOIncrementBy i) = texts ["increment", "by", showText i]
  sequenceGeneratorOption (SGOMaxValue i) = texts ["maxvalue", showText i]
  sequenceGeneratorOption SGONoMaxValue = texts ["no", "maxvalue"]
  sequenceGeneratorOption (SGOMinValue i) = texts ["minvalue", showText i]
  sequenceGeneratorOption SGONoMinValue = texts ["no", "minvalue"]
  sequenceGeneratorOption SGOCycle = pretty "cycle"
  sequenceGeneratorOption SGONoCycle = pretty "no cycle"
  
  refMatch :: ReferenceMatch -> Doc a
  refMatch m = case m of
                       DefaultReferenceMatch -> mempty
                       MatchFull -> texts ["match", "full"]
                       MatchPartial -> texts ["match","partial"]
                       MatchSimple -> texts ["match", "simple"]
  
  refAct :: Text -> ReferentialAction -> Doc a
  refAct t a = case a of
                       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 a
  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) =
      pretty "add"
      <+> maybe mempty (\s -> pretty "constraint" <+> names s) n
      <+> tableConstraint d con
  
  alterTableAction _ (DropTableConstraintDef n b) =
      texts ["drop", "constraint"]
      <+> names n
      <+> dropBehav b
  
  
  tableConstraint :: Dialect -> TableConstraint -> Doc a
  tableConstraint _ (TableUniqueConstraint 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)
          <+> pretty "references"
          <+> names t
          <+> maybe mempty (\c' -> parens (commaSep $ map name c')) tcs
          <+> refMatch m
          <+> refAct "update" u
          <+> refAct "delete" del
  tableConstraint d (TableCheckConstraint v) = pretty "check" <+> parens (scalarExpr d v)
  
  
  privAct :: PrivilegeAction -> Doc a
  privAct PrivAll = texts ["all","privileges"]
  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 a
  maybeColList cs =
      if null cs
      then mempty
      else parens (commaSep $ map name cs)
  
  privObj :: PrivilegeObject -> Doc a
  privObj (PrivTable nm) = 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 a] -> Doc a
  commaSep ds = sep $ punctuate comma ds
  
  me :: (b -> Doc a) -> Maybe b -> Doc a
  me = maybe mempty
  
  comment :: Comment -> Doc a
  comment (BlockComment str) = pretty "/*" <+> pretty str <+> pretty "*/"
  
  texts :: [Text] -> 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 :: Text -> Doc a
  pretty = P.pretty
  
  showText :: Show a => a -> Text
  showText = T.pack . show
  
  -- restore the correct behaviour of mempty
  -- this doesn't quite work when you chain <> and <+> together,
  -- so use parens in those cases
  
  sep :: [Doc a] -> Doc a
  sep = P.sep . filter isEmpty
    where
      isEmpty Empty = False
      isEmpty _ = True
  
  (<+>) :: Doc a -> Doc a -> Doc a
  (<+>) a b = case (a,b) of
      (Empty, Empty) -> Empty
      (Empty, x) -> x
      (x, Empty) -> x
      _ ->  a P.<+> b
  
  parens :: Doc a -> Doc a
  parens a = P.parens (align a)
  