>
>
> module Database.HsSqlPpp.Pretty (
>
> printStatements
> ,printStatementsAnn
> ,printQueryExpr
>
> ,printScalarExpr
> ,printQueryExprNice
> )
> where
>
> import Text.PrettyPrint
> import Data.Char
>
> import Data.Maybe
>
> import Database.HsSqlPpp.Ast
> import Database.HsSqlPpp.Annotation
> import Database.HsSqlPpp.Catalog
> import Database.HsSqlPpp.Utils.Utils
--------------------------------------------------------------------------------
Public functions
>
> printStatements :: StatementList -> String
> printStatements = printStatementsAnn (const "")
>
>
>
>
> printStatementsAnn :: (Annotation -> String) -> StatementList -> String
> printStatementsAnn f ast = render $ vcat (map (convStatement False True f) ast) <> text "\n"
>
> printQueryExpr :: QueryExpr -> String
> printQueryExpr ast = render (convQueryExpr False True True ast <> statementEnd True)
>
> printScalarExpr :: ScalarExpr -> String
> printScalarExpr = render . convExp False
>
>
> printQueryExprNice :: QueryExpr -> String
> printQueryExprNice ast = render (convQueryExpr True True True ast <> statementEnd True)
-------------------------------------------------------------------------------
Conversion routines - convert Sql asts into Docs
>
>
> convStatement :: Bool -> Bool -> (Annotation -> String) -> Statement -> Doc
>
>
>
> convStatement nice se ca (QueryStatement ann s) =
> convPa ca ann <+>
> convQueryExpr nice True True s <> statementEnd se
>
> --dml
>
> convStatement nice se pa (Insert ann tb atts idata rt) =
> convPa pa ann <+>
> text "insert into" <+> convDqi tb
> <+> ifNotEmpty (parens . sepCsvMap text) atts
> $+$ convQueryExpr nice True True idata
> $+$ convReturning nice rt
> <> statementEnd se
>
> convStatement nice se ca (Update ann tb scs fr wh rt) =
> convPa ca ann <+>
> text "update" <+> convDqi tb <+> text "set"
> <+> sepCsvMap (convSet nice) scs
> <+> ifNotEmpty (\_ -> text "from" <+> sepCsvMap (convTref nice) fr) fr
> <+> convWhere nice wh
> $+$ convReturning nice rt <> statementEnd se
>
> convStatement nice se ca (Delete ann tbl us wh rt) =
> convPa ca ann <+>
> text "delete from" <+> convDqi tbl
> <+> ifNotEmpty (\_ -> text "using" <+> sepCsvMap (convTref nice) us) us
> <+> convWhere nice wh
> $+$ convReturning nice rt
> <> statementEnd se
>
> convStatement _nice se ca (Truncate ann names ri casc) =
> convPa ca ann <+>
> text "truncate"
> <+> sepCsvMap text names
> <+> text (case ri of
> RestartIdentity -> "restart identity"
> ContinueIdentity -> "continue identity")
> <+> convCasc casc
> <> statementEnd se
>
>
>
> convStatement nice se ca (CreateTable ann tbl atts cns) =
> convPa ca ann <+>
> text "create table"
> <+> text tbl <+> lparen
> $+$ nest 2 (vcat (csv (map convAttDef atts ++ map (convCon nice) cns)))
> $+$ rparen <> statementEnd se
> where
> convAttDef (AttributeDef _ n t def cons) =
> text n <+> convTypeName t
> <+> maybeConv (\e -> text "default" <+> convExp nice e) def
> <+> hsep (map cCons cons)
> cCons (NullConstraint _ cn) =
> mname cn <+> text "null"
> cCons (NotNullConstraint _ cn) =
> mname cn <+> text "not null"
> cCons (RowCheckConstraint _ cn ew) =
> mname cn <+> text "check" <+> parens (convExp nice ew)
> cCons (RowUniqueConstraint _ cn) =
> mname cn <+> text "unique"
> cCons (RowPrimaryKeyConstraint _ cn) =
> mname cn <+> text "primary key"
> cCons (RowReferenceConstraint _ cn tb att ondel onupd) =
> mname cn <+> text "references" <+> text tb
> <+> maybeConv (parens . text) att
> <+> text "on delete" <+> convCasc ondel
> <+> text "on update" <+> convCasc onupd
>
> convStatement nice se ca (AlterTable ann name act) =
> convPa ca ann <+>
> text "alter table" <+> text name
> <+> hcatCsvMap convAct act <> statementEnd se
> where
> convAct (AlterColumnDefault _ nm def) =
> text "alter column" <+> text nm
> <+> text "set default" <+> convExp nice def
> convAct (AddConstraint _ con) =
> text "add " <+> convCon nice con
>
> convStatement _nice se ca (CreateSequence ann nm incr _ _ start cache) =
> convPa ca ann <+>
> text "create sequence" <+> text nm <+>
> text "increment" <+> text (show incr) <+>
> text "no minvalue" <+>
> text "no maxvalue" <+>
> text "start" <+> text (show start) <+>
> text "cache" <+> text (show cache) <> statementEnd se
>
> convStatement _nice se ca (AlterSequence ann nm o) =
> convPa ca ann <+>
> text "alter sequence" <+> text nm
> <+> text "owned by" <+> convDqi o <> statementEnd se
>
> convStatement nice se ca (CreateTableAs ann t sel) =
> convPa ca ann <+>
> text "create table"
> <+> text t <+> text "as"
> $+$ convQueryExpr nice True True sel
> <> statementEnd se
>
> convStatement nice se ca (CreateFunction ann name args retType rep lang body vol) =
> convPa ca ann <+>
> text ("create " ++ (case rep of
> Replace -> "or replace "
> _ -> "") ++ "function")
> <+> text name
> <+> parens (sepCsvMap convParamDef args)
> <+> text "returns" <+> convTypeName retType <+> text "as" <+> text "$$"
> $+$ convFnBody body
> $+$ text "$$" <+> text "language"
> <+> text (case lang of
> Sql -> "sql"
> Plpgsql -> "plpgsql")
> <+> text (case vol of
> Volatile -> "volatile"
> Stable -> "stable"
> Immutable -> "immutable")
> <> statementEnd se
> where
> convFnBody (SqlFnBody ann1 sts) =
> convPa ca ann1 <+>
> convNestedStatements nice ca sts
> convFnBody (PlpgsqlFnBody ann1 blk) =
> convPa ca ann1 <+>
> convStatement nice True ca blk
> convParamDef (ParamDef _ n t) = text n <+> convTypeName t
> convParamDef (ParamDefTp _ t) = convTypeName t
>
> convStatement nice se ca (Block ann lb decls sts) =
> convPa ca ann <+>
> convLabel lb <>
> ifNotEmpty (\l -> text "declare"
> $+$ nest 2 (vcat $ map convVarDef l)) decls
> $+$ text "begin"
> $+$ convNestedStatements nice ca sts
> $+$ text "end" <> statementEnd se
> where
> convVarDef (VarDef _ n t v) =
> text n <+> convTypeName t
> <+> maybeConv (\x -> text ":=" <+> convExp nice x) v <> semi
> convVarDef (VarAlias _ n n1) =
> text n <+> text "alias for" <+> text n1 <> semi
> convVarDef (ParamAlias _ n p) =
> text n <+> text "alias for $" <> text (show p) <> semi
>
>
> convStatement nice se ca (CreateView ann name cols sel) =
> convPa ca ann <+>
> text "create view" <+> text name
> <> case cols of
> Nothing -> empty
> Just cs -> parens (sepCsvMap text cs)
> <+> text "as"
> $+$ nest 2 (convQueryExpr nice True True sel) <> statementEnd se
>
> convStatement nice se ca (CreateDomain ann name tp n ex) =
> convPa ca ann <+>
> text "create domain" <+> text name <+> text "as"
> <+> convTypeName tp <+> cname <+> checkExp ex <> statementEnd se
> where
> checkExp = maybeConv (\e -> text "check" <+> parens (convExp nice e))
> cname = if n == ""
> then empty
> else text "constraint" <+> text n
>
> convStatement _nice se ca (DropFunction ann ifExists fns casc) =
> convPa ca ann <+>
> text "drop function"
> <+> convIfExists ifExists
> <+> sepCsvMap doFunction fns
> <+> convCasc casc
> <> statementEnd se
> where
> doFunction (name,types) =
> text name <> parens (sepCsvMap convTypeName types)
>
> convStatement _nice se ca (DropSomething ann dropType ifExists names casc) =
> convPa ca ann <+>
> text "drop"
> <+> text (case dropType of
> Table -> "table"
> View -> "view"
> Domain -> "domain"
> Type -> "type")
> <+> convIfExists ifExists
> <+> sepCsvMap text names
> <+> convCasc casc
> <> statementEnd se
>
> convStatement _nice se ca (CreateType ann name atts) =
> convPa ca ann <+>
> text "create type" <+> text name <+> text "as" <+> lparen
> $+$ nest 2 (vcat (csv
> (map (\(TypeAttDef _ n t) -> text n <+> convTypeName t) atts)))
> $+$ rparen <> statementEnd se
>
> convStatement _nice se ca (CreateLanguage ann name) =
> convPa ca ann <+>
> text "create language" <+> text name <> statementEnd se
>
> convStatement nice se ca (CreateTrigger ann name wh events tbl firing fnName fnArgs) =
> convPa ca ann <+>
> text "create trigger" <+> text name
> <+> text (case wh of
> TriggerBefore -> "before"
> TriggerAfter -> "after")
> <+> evs
> <+> text "on" <+> text tbl
> <+> text "for" <+> text (case firing of
> EachRow -> "row"
> EachStatement -> "statement")
> <+> text "execute procedure" <+> text fnName
> <> parens (sepCsvMap (convExp nice) fnArgs) <> statementEnd se
> where
> evs = sep $ punctuate (text " or ") $ map
> (text . (\e -> case e of
> TInsert -> "insert"
> TUpdate -> "update"
> TDelete -> "delete")) events
>
>
>
> convStatement _nice se ca (NullStatement ann) =
> convPa ca ann <+> text "null" <> statementEnd se
> convStatement _nice se ca (ExitStatement ann lb) =
> convPa ca ann <+> text "exit"
> <+> maybe empty text lb <> statementEnd se
>
> convStatement _ _se _ca (Into _ann _str _into (QueryStatement _annq _s)) = error "no select into"
> convStatement nice se ca (Into ann str into st) =
> convPa ca ann <+>
> convStatement nice False ca st
> <+> text "into"
> <> (if str
> then empty <+> text "strict"
> else empty)
> <+> sepCsvMap (convExp nice) into
> <> statementEnd se
>
> convStatement nice se ca (Assignment ann name val) =
> convPa ca ann <+>
> convExp nice name <+> text ":=" <+> convExp nice val <> statementEnd se
>
> convStatement nice se ca (Return ann ex) =
> convPa ca ann <+>
> text "return" <+> maybeConv (convExp nice) ex <> statementEnd se
>
> convStatement nice se ca (ReturnNext ann ex) =
> convPa ca ann <+>
> text "return" <+> text "next" <+> convExp nice ex <> statementEnd se
>
> convStatement nice se ca (ReturnQuery ann sel) =
> convPa ca ann <+>
> text "return" <+> text "query"
> <+> convQueryExpr nice True True sel <> statementEnd se
>
> convStatement nice se ca (Raise ann rt st exps) =
> convPa ca ann <+>
> text "raise"
> <+> case rt of
> RNotice -> text "notice"
> RException -> text "exception"
> RError -> text "error"
> <+> convExp nice (StringLit emptyAnnotation st)
> <> ifNotEmpty (\e -> comma <+> csvExp nice e) exps
> <> statementEnd se
>
> convStatement nice se ca (ForQueryStatement ann lb i sel stmts) =
> convPa ca ann <+>
> convLabel lb <>
> text "for" <+> convExp nice i <+> text "in"
> <+> convQueryExpr nice True True sel <+> text "loop"
> $+$ convNestedStatements nice ca stmts
> $+$ text "end loop" <> statementEnd se
>
> convStatement nice se ca (ForIntegerStatement ann lb var st en stmts) =
> convPa ca ann <+>
> convLabel lb <>
> text "for" <+> convExp nice var <+> text "in"
> <+> convExp nice st <+> text ".." <+> convExp nice en <+> text "loop"
> $+$ convNestedStatements nice ca stmts
> $+$ text "end loop" <> statementEnd se
>
> convStatement nice se ca (WhileStatement ann lb ex stmts) =
> convPa ca ann <+>
> convLabel lb <>
> text "while" <+> convExp nice ex <+> text "loop"
> $+$ convNestedStatements nice ca stmts
> $+$ text "end loop" <> statementEnd se
> convStatement nice se ca (LoopStatement ann lb stmts) =
> convPa ca ann <+>
> convLabel lb <>
> text "loop"
> $+$ convNestedStatements nice ca stmts
> $+$ text "end loop" <> statementEnd se
>
> convStatement _nice se ca (ContinueStatement ann lb) =
> convPa ca ann <+> text "continue"
> <+> maybe empty text lb <> statementEnd se
> convStatement nice se ca (Perform ann f@(FunCall _ _ _)) =
> convPa ca ann <+>
> text "perform" <+> convExp nice f <> statementEnd se
> convStatement _ _ _ (Perform _ x) =
> error $ "internal error: convStatement not supported for " ++ show x
>
> convStatement _nice se ca (Copy ann tb cols src) =
> convPa ca ann <+>
> text "copy" <+> text tb
> <+> ifNotEmpty (parens . sepCsvMap text) cols
> <+> text "from"
> <+> case src of
> CopyFilename s -> quotes $ text s <> statementEnd se
> Stdin -> text "stdin" <> text ";"
>
> convStatement _ _ ca (CopyData ann s) =
> convPa ca ann <+>
> text s <> text "\\." <> newline
>
> convStatement nice se ca (If ann conds els) =
> convPa ca ann <+>
> text "if" <+> convCond (head conds)
> $+$ vcat (map (\c -> text "elseif" <+> convCond c) $ tail conds)
> $+$ ifNotEmpty (\e -> text "else" $+$ convNestedStatements nice ca e) els
> $+$ text "end if" <> statementEnd se
> where
> convCond (ex, sts) = convExp nice ex <+> text "then"
> $+$ convNestedStatements nice ca sts
> convStatement nice se ca (Execute ann s) =
> convPa ca ann <+>
> text "execute" <+> convExp nice s <> statementEnd se
>
>
> convStatement nice se ca (CaseStatementSimple ann c conds els) =
> convPa ca ann <+>
> text "case" <+> convExp nice c
> $+$ nest 2 (
> vcat (map (uncurry convWhenSt) conds)
> $+$ convElseSt els
> ) $+$ text "end case" <> statementEnd se
> where
> convWhenSt ex sts = text "when" <+> sepCsvMap (convExp nice) ex
> <+> text "then" $+$ convNestedStatements nice ca sts
> convElseSt = ifNotEmpty (\s -> text "else"
> $+$ convNestedStatements nice ca s)
> convStatement nice se ca (CaseStatement ann conds els) =
> convPa ca ann <+>
> text "case"
> $+$ nest 2 (
> vcat (map (uncurry convWhenSt) conds)
> $+$ convElseSt els
> ) $+$ text "end case" <> statementEnd se
> where
> convWhenSt ex sts = text "when" <+> sepCsvMap (convExp nice) ex
> <+> text "then" $+$ convNestedStatements nice ca sts
> convElseSt = ifNotEmpty (\s -> text "else"
> $+$ convNestedStatements nice ca s)
>
>
>
> convStatement _nice se _ (Set _ n vs) =
> text "set" <+> text n <+> text "="
> <+> sepCsvMap (text . dv) vs <> statementEnd se
> where
> dv (SetStr _ s) = "'" ++ s ++ "'"
> dv (SetId _ i) = i
> dv (SetNum _ nm) = show nm
>
> convStatement _nice se _ (Notify _ n) =
> text "notify" <+> text n <> statementEnd se
>
> statementEnd :: Bool -> Doc
> statementEnd b = if b
> then semi <> newline
> else empty
-------------------------------------------------------------------------------
Statement components
>
>
> convQueryExpr :: Bool -> Bool -> Bool -> QueryExpr -> Doc
> convQueryExpr nice writeSelect _ (Select _ dis l tb wh grp hav
> order lim off) =
> (text (if writeSelect then "select" else "")
> <+> (case dis of
> Dupes -> empty
> Distinct -> text "distinct"))
> $+$ nest 2 (vcat $ catMaybes
> [Just $ nest 2 $ convSelList nice l
> ,Just $ if null tb
> then empty
> else text "from" $+$ nest 2 (sepCsvMap (convTref nice) tb)
> ,Just $ convWhere nice wh
> ,case grp of
> [] -> Nothing
> g -> Just $ text "group by" $+$ nest 2 (sepCsvMap (convExp nice) g)
> ,flip fmap hav $ \h -> text "having" $+$ nest 2 (convExp nice h)
> ,case order of
> [] -> Nothing
> o -> Just $ text "order by"
> $+$ nest 2 (sepCsvMap (\(oe,od) -> convExp nice oe
> <+> convDir od) o)
> ,flip fmap lim $ \lm -> text "limit" <+> convExp nice lm
> ,flip fmap off $ \offs -> text "offset" <+> convExp nice offs
> ])
>
> convQueryExpr nice writeSelect topLev (CombineQueryExpr _ tp s1 s2) =
> let p = convQueryExpr nice writeSelect False s1
> $+$ (case tp of
> Except -> text "except"
> Union -> text "union"
> UnionAll -> text "union" <+> text "all"
> Intersect -> text "intersect")
> $+$ convQueryExpr nice True False s2
> in if topLev then p else parens p
> convQueryExpr nice _ _ (Values _ expss) =
> text "values" $$ nest 2 (vcat $ csv $ map (parens . csvExp nice) expss)
> convQueryExpr nice _ _ (WithQueryExpr _ wqs ex) =
> text "with" $$ nest 2 (vcat $ csv $ map pwq wqs)
> $+$ convQueryExpr nice True False ex
> where
> pwq (WithQuery _ nm cs ex1) =
> text nm <> case cs of
> Nothing -> empty
> Just cs' -> parens $ sepCsvMap text cs'
> <+> text "as"
> <+> parens (convQueryExpr nice True False ex1)
>
> convTref :: Bool -> TableRef -> Doc
> convTref nice (Tref _ f@(SQIdentifier _ t) (TableAlias _ ta))
> | nice, last t == ta = convDqi f
>
> convTref nice (Tref _ f@(SQIdentifier _ t) (FullAlias _ ta _))
> | nice, last t == ta = convDqi f
> convTref nice (Tref _ f a) = convDqi f <+> convTrefAlias nice a
> convTref nice (JoinTref _ t1 nat jt t2 ex a) =
> parens (convTref nice t1
> $+$ (case nat of
> Natural -> text "natural"
> Unnatural -> empty)
> <+> text (case jt of
> Inner -> "inner"
> Cross -> "cross"
> LeftOuter -> "left outer"
> RightOuter -> "right outer"
> FullOuter -> "full outer")
> <+> text "join"
> <+> convTref nice t2
> <+> maybeConv (nest 2 . convJoinScalarExpr) ex
> <+> convTrefAlias nice a)
> where
> convJoinScalarExpr (JoinOn _ e) = text "on" <+> convExp nice e
> convJoinScalarExpr (JoinUsing _ ids) =
> text "using" <+> parens (sepCsvMap text ids)
>
> convTref nice (SubTref _ sub alias) =
> parens (convQueryExpr nice True True sub)
> <+> text "as" <+> convTrefAlias nice alias
> convTref nice (FunTref _ f@(FunCall _ _ _) a) = convExp nice f <+> convTrefAlias nice a
> convTref _nice (FunTref _ x _) =
> error $ "internal error: node not supported in function tref: "
> ++ show x
>
> convTrefAlias :: Bool -> TableAlias -> Doc
> convTrefAlias _ (NoAlias _) = empty
> convTrefAlias _ (TableAlias _ t) = text t
>
>
> convTrefAlias nice (FullAlias _ t s) =
> text t <> (if nice
> then empty
> else parens (sepCsvMap text s))
> convDir :: Direction -> Doc
> convDir d = text $ case d of
> Asc -> "asc"
> Desc -> "desc"
>
> convWhere :: Bool -> Maybe ScalarExpr -> Doc
> convWhere nice (Just ex) = text "where" $+$ nest 2 (convExp nice ex)
> convWhere _ Nothing = empty
>
> convSelList :: Bool -> SelectList -> Doc
> convSelList nice (SelectList _ ex) =
> sepCsvMap convSelItem ex
>
> where
>
> convSelItem (SelectItem _ ex1@(QIdentifier _ _ i) nm) | nice, i == nm = convExpSl nice ex1
> convSelItem (SelectItem _ ex1@(Identifier _ i) nm) | nice, i == nm = convExpSl nice ex1
> convSelItem (SelectItem _ ex1 nm) = convExpSl nice ex1 <+> text "as" <+> text nm
> convSelItem (SelExp _ e) = convExpSl nice e
>
> convCasc :: Cascade -> Doc
> convCasc casc = text $ case casc of
> Cascade -> "cascade"
> Restrict -> "restrict"
>
> convDqi :: SQIdentifier -> Doc
> convDqi (SQIdentifier _ is) = hcat $ punctuate (text ".") $ map text is
>
>
> convCon :: Bool -> Constraint -> Doc
> convCon _nice (UniqueConstraint _ n c) =
> mname n <+> text "unique"
> <+> parens (sepCsvMap text c)
> convCon _nice (PrimaryKeyConstraint _ n p) =
> mname n <+>
> text "primary key"
> <+> parens (sepCsvMap text p)
> convCon nice (CheckConstraint _ n c) =
> mname n <+> text "check" <+> parens (convExp nice c)
> convCon _nice (ReferenceConstraint _ n at tb rat ondel onupd) =
> mname n <+>
> text "foreign key" <+> parens (sepCsvMap text at)
> <+> text "references" <+> text tb
> <+> ifNotEmpty (parens . sepCsvMap text) rat
> <+> text "on update" <+> convCasc onupd
> <+> text "on delete" <+> convCasc ondel
>
> mname :: String -> Doc
> mname n = if n == ""
> then empty
> else text "constraint" <+> text n
>
> convReturning :: Bool -> Maybe SelectList -> Doc
> convReturning nice l = case l of
> Nothing -> empty
> Just ls -> nest 2 (text "returning" <+> convSelList nice ls)
>
> convIfExists :: IfExists -> Doc
> convIfExists i = case i of
> Require -> empty
> IfExists -> text "if exists"
>
>
>
> convNestedStatements :: Bool -> (Annotation -> String) -> StatementList -> Doc
> convNestedStatements nice pa = nest 2 . vcat . map (convStatement nice True pa)
>
> convTypeName :: TypeName -> Doc
> convTypeName (SimpleTypeName _ s) = text s
> convTypeName (PrecTypeName _ s i) = text s <> parens(integer i)
> convTypeName (Prec2TypeName _ s i i1) = text s <> parens (sepCsv [integer i, integer i1])
> convTypeName (ArrayTypeName _ t) = convTypeName t <> text "[]"
> convTypeName (SetOfTypeName _ t) = text "setof" <+> convTypeName t
>
>
>
> convExp :: Bool -> ScalarExpr -> Doc
> convExp _ (Identifier _ i) =
> if quotesNeeded
> then text $ "\"" ++ i ++ "\""
> else text i
> where
>
>
> quotesNeeded = case i of
> x:_ | not (isLetter x || x `elem` "_*") -> True
> _ | all okChar i -> False
> | otherwise -> True
> where
> okChar x =isAlphaNum x || x `elem` "*_."
> convExp nice (QIdentifier a i1@(Identifier _ _) i) = convExp nice i1 <> text "." <> convExp nice (Identifier a i)
> convExp nice (QIdentifier a e i) = parens (convExp nice e) <> text "." <> convExp nice (Identifier a i)
>
> convExp _ (NumberLit _ n) = text n
> convExp _ (StringLit _ s) =
> text "'" <> text replaceQuotes <> text "'"
> where
> replaceQuotes = replace "'" "''" s
>
> convExp nice (FunCall _ n es) =
>
> case n of
> "!and" | nice, [a,b] <- es -> doLeftAnds a b
> "!arrayctor" -> text "array" <> brackets (csvExp nice es)
> "!between" -> convExp nice (head es) <+> text "between"
> <+> parens (convExp nice (es !! 1))
> <+> text "and"
> <+> parens (convExp nice (es !! 2))
> "!substring" -> text "substring"
> <> parens (convExp nice (head es)
> <+> text "from" <+> convExp nice (es !! 1)
> <+> text "for" <+> convExp nice (es !! 2))
> "!arraysub" -> case es of
> (Identifier _ i : es1) -> text i
> <> brackets (csvExp nice es1)
> _ -> parens (convExp nice (head es))
> <> brackets (csvExp nice (tail es))
> "!rowctor" -> text "row" <> parens (sepCsvMap (convExp nice) es)
> "."
>
> | [a,b] <- es -> convExp nice a <> text "." <> convExp nice b
> _ | isOperatorName n ->
> case forceRight (getOperatorType defaultTemplate1Catalog n) of
> BinaryOp ->
> let e1d = convExp nice (head es)
> opd = text $ filterKeyword n
> e2d = convExp nice (es !! 1)
> in parens (if n `elem` ["!and", "!or"]
> then vcat [e1d, opd <+> e2d]
> else e1d <+> opd <+> e2d)
> PrefixOp -> parens (text (if n == "u-"
> then "-"
> else filterKeyword n)
> <+> parens (convExp nice (head es)))
> PostfixOp -> parens (convExp nice (head es)
> <+> text (filterKeyword n))
> | otherwise -> text n <> parens (csvExp nice es)
> where
> filterKeyword t = case t of
> "!and" -> "and"
> "!or" -> "or"
> "!not" -> "not"
> "!isnull" -> "is null"
> "!isnotnull" -> "is not null"
> "!like" -> "like"
> "!notlike" -> "not like"
> x -> x
>
> doLeftAnds a b = let as = and' a
> in vcat ((convExp nice (head as)
> : map (\x -> text "and" <+> convExp nice x) (tail as))
> ++ [text "and" <+> convExp nice b])
> and' a = case a of
> FunCall _ "!and" [x,y] -> and' x ++ and' y
> _ -> [a]
>
> convExp _ (BooleanLit _ b) = bool b
> convExp nice (InPredicate _ att t lst) =
> convExp nice att <+> (if not t then text "not" else empty) <+> text "in"
> <+> parens (case lst of
> InList _ expr -> csvExp nice expr
> InQueryExpr _ sel -> convQueryExpr nice True True sel)
> convExp nice (LiftOperator _ op flav args) =
> convExp nice (head args) <+> text op
> <+> text (case flav of
> LiftAny -> "any"
> LiftAll -> "all")
> <+> parens (convExp nice $ head $ tail args)
> convExp nice (ScalarSubQuery _ s) = parens (convQueryExpr nice True True s)
> convExp _ (NullLit _) = text "null"
> convExp nice (WindowFn _ fn part order asc frm) =
> convExp nice fn <+> text "over"
> <+> parens (if hp || ho
> then (if hp
> then text "partition by" <+> csvExp nice part
> else empty)
> <+> (if ho
> then text "order by" <+> csvExp nice order
> <+> convDir asc
> else empty)
> <+> convFrm
> else empty)
> where
> hp = not (null part)
> ho = not (null order)
> convFrm = case frm of
> FrameUnboundedPreceding -> text "range unbounded preceding"
> FrameUnboundedFull -> text "range between unbounded preceding and unbounded following"
> FrameRowsUnboundedPreceding -> text "rows unbounded preceding"
>
> convExp nice (Case _ whens els) =
> text "case"
> $+$ nest 2 (vcat (map convWhen whens)
> $+$ maybeConv (\e -> text "else" <+> convExp nice e) els)
> $+$ text "end"
> where
> convWhen (ex1, ex2) =
> text "when" <+> sepCsvMap (convExp nice) ex1
> <+> text "then" <+> convExp nice ex2
>
> convExp nice (CaseSimple _ val whens els) =
> text "case" <+> convExp nice val
> $+$ nest 2 (vcat (map convWhen whens)
> $+$ maybeConv (\e -> text "else" <+> convExp nice e) els)
> $+$ text "end"
> where
> convWhen (ex1, ex2) =
> text "when" <+> sepCsvMap (convExp nice) ex1
> <+> text "then" <+> convExp nice ex2
>
> convExp _ (PositionalArg _ a) = text "$" <> integer a
> convExp _ (Placeholder _) = text "?"
> convExp nice (Exists _ s) =
> text "exists" <+> parens (convQueryExpr nice True True s)
> convExp nice (Cast _ ex t) = text "cast" <> parens (convExp nice ex
> <+> text "as"
> <+> convTypeName t)
> convExp nice (TypedStringLit a t s) =
> convTypeName t <+> convExp nice (StringLit a s)
> convExp nice (Interval a v f p) =
> text "interval" <+> convExp nice (StringLit a v)
> <+> convIntervalField <+> convPrec
> where
> convIntervalField =
> text $ case f of
> IntervalYear -> "year"
> IntervalMonth -> "month"
> IntervalDay -> "day"
> IntervalHour -> "hour"
> IntervalMinute -> "minute"
> IntervalSecond -> "second"
> IntervalYearToMonth -> "year to month"
> IntervalDayToHour -> "day to hour"
> IntervalDayToMinute -> "day to minute"
> IntervalDayToSecond -> "day to second"
> IntervalHourToMinute -> "hour to minute"
> IntervalHourToSecond -> "hour to second"
> IntervalMinuteToSecond -> "minute to second"
> convPrec = case p of
> Nothing -> empty
> Just i -> parens (int i)
> convExp nice (Extract _ f e) =
> text "extract"
> <> parens (text convField <+> text "from" <+> convExp nice e)
> where
> convField =
> case f of
> ExtractCentury -> "century"
> ExtractDay -> "day"
> ExtractDecade -> "decade"
> ExtractDow -> "dow"
> ExtractDoy -> "doy"
> ExtractEpoch -> "epoch"
> ExtractHour -> "hour"
> ExtractIsodow -> "isodow"
> ExtractIsoyear -> "isoyear"
> ExtractMicroseconds -> "microseconds"
> ExtractMillennium -> "millennium"
> ExtractMilliseconds -> "milliseconds"
> ExtractMinute -> "minute"
> ExtractMonth -> "month"
> ExtractQuarter -> "quarter"
> ExtractSecond -> "second"
> ExtractTimezone -> "timezone"
> ExtractTimezoneHour -> "timezone_hour"
> ExtractTimezoneMinute -> "timezone_minute"
> ExtractWeek -> "week"
> ExtractYear -> "year"
> convExpSl :: Bool -> ScalarExpr -> Doc
> convExpSl nice (FunCall _ "." es) | [a@(Identifier _ _), b] <- es =
> parens (convExpSl nice a) <> text "." <> convExpSl nice b
> convExpSl nice x = convExp nice x
>
> convSet :: Bool -> ScalarExpr -> Doc
> convSet nice (FunCall _ "=" [Identifier _ a, e]) =
> text a <+> text "=" <+> convExp nice e
> convSet nice (FunCall _ "=" [a, b]) | (FunCall _ "!rowctor" is1) <- a
> ,(FunCall _ "!rowctor" is2) <- b =
> rsNoRow is1 <+> text "=" <+> rsNoRow is2
> where
> rsNoRow is = parens (sepCsvMap (convExp nice) is)
> convSet _ a = error $ "bad expression in set in update: " ++ show a
>
> --utils
>
>
>
> csvExp :: Bool -> [ScalarExpr] -> Doc
> csvExp nice = hcatCsvMap (convExp nice)
>
> maybeConv :: (t -> Doc) -> Maybe t -> Doc
> maybeConv f c =
> case c of
> Nothing -> empty
> Just a -> f a
>
> csv :: [Doc] -> [Doc]
> csv = punctuate comma
>
> hcatCsv :: [Doc] -> Doc
> hcatCsv = hcat . csv
> sepCsv :: [Doc] -> Doc
> sepCsv = sep . csv
>
> ifNotEmpty :: ([a] -> Doc) -> [a] -> Doc
> ifNotEmpty c l = if null l then empty else c l
>
> hcatCsvMap :: (a -> Doc) -> [a] -> Doc
> hcatCsvMap ex = hcatCsv . map ex
> sepCsvMap :: (a -> Doc) -> [a] -> Doc
> sepCsvMap ex = sepCsv . map ex
>
>
>
> bool :: Bool -> Doc
> bool b = if b then text "true" else text "false"
>
> newline :: Doc
> newline = text "\n"
>
> convPa :: (Annotation -> String) -> Annotation -> Doc
> convPa ca a = let s = ca a
> in if s == ""
> then empty
> else text "/*\n" <+> text s
> <+> text "*/\n"
> convLabel :: Maybe String -> Doc
> convLabel =
> maybe empty (\l -> text "<<"
> <+> text l
> <+> text ">>" <> text "\n")