1
0
mirror of https://github.com/hasura/graphql-engine.git synced 2024-12-22 23:11:41 +03:00
graphql-engine/server/src-lib/Hasura/Backends/MSSQL/ToQuery.hs
Samir Talwar 342391f39d Upgrade Ormolu to v0.5.
This upgrades the version of Ormolu required by the HGE repository to v0.5.0.1, and reformats all code accordingly.

Ormolu v0.5 reformats code that uses infix operators. This is mostly useful, adding newlines and indentation to make it clear which operators are applied first, but in some cases, it's unpleasant. To make this easier on the eyes, I had to do the following:

* Add a few fixity declarations (search for `infix`)
* Add parentheses to make precedence clear, allowing Ormolu to keep everything on one line
* Rename `relevantEq` to `(==~)` in  and set it to `infix 4`
* Add a few _.ormolu_ files (thanks to @hallettj for helping me get started), mostly for Autodocodec operators that don't have explicit fixity declarations

In general, I think these changes are quite reasonable. They mostly affect indentation.

PR-URL: https://github.com/hasura/graphql-engine-mono/pull/6675
GitOrigin-RevId: cd47d87f1d089fb0bc9dcbbe7798dbceedcd7d83
2022-11-02 20:55:13 +00:00

825 lines
27 KiB
Haskell

{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | MSSQL ToQuery
--
-- Convert the simple T-SQL AST to an SQL query, ready to be passed to the odbc
-- package's query/exec functions.
--
-- We define a custom prettyprinter with the type 'Printer'.
--
-- If you'd like to trace and see what a 'Printer' looks like as SQL, you can use something like:
-- > ltraceM "sql" (ODBC.renderQuery (toQueryPretty myPrinter))
module Hasura.Backends.MSSQL.ToQuery
( fromSelect,
fromReselect,
toQueryFlat,
toQueryPretty,
fromInsert,
fromMerge,
fromSetIdentityInsert,
fromDelete,
fromUpdate,
fromSelectIntoTempTable,
fromInsertValuesIntoTempTable,
dropTempTableQuery,
fromRawUnescapedText,
fromTableName,
(<+>),
Printer (..),
)
where
import Data.Aeson (ToJSON (..))
import Data.HashMap.Strict qualified as HM
import Data.List (intersperse)
import Data.String
import Data.Text qualified as T
import Data.Text.Extended qualified as T
import Data.Text.Lazy qualified as L
import Data.Text.Lazy.Builder qualified as L
import Database.ODBC.SQLServer
import Hasura.Backends.MSSQL.Types
import Hasura.Prelude hiding (GT, LT)
--------------------------------------------------------------------------------
-- * Types
data Printer
= SeqPrinter [Printer]
| SepByPrinter Printer [Printer]
| NewlinePrinter
| QueryPrinter Query
| IndentPrinter Int Printer
deriving (Show, Eq)
instance IsString Printer where
fromString = QueryPrinter . fromString
(<+>) :: Printer -> Printer -> Printer
(<+>) x y = SeqPrinter [x, y]
(<+>?) :: Printer -> Maybe Printer -> Printer
(<+>?) x Nothing = x
(<+>?) x (Just y) = SeqPrinter [x, y]
(?<+>) :: Maybe Printer -> Printer -> Printer
(?<+>) Nothing x = x
(?<+>) (Just x) y = SeqPrinter [x, y]
--------------------------------------------------------------------------------
-- * Instances
-- This is a debug instance, only here because it avoids a circular
-- dependency between this module and Types/Instances.
instance ToJSON Expression where
toJSON = toJSON . T.toTxt . toQueryFlat . fromExpression
--------------------------------------------------------------------------------
-- * Printer generators
fromExpression :: Expression -> Printer
fromExpression =
\case
CastExpression e t dataLength ->
"CAST("
<+> fromExpression e
<+> " AS "
<+> fromString (T.unpack $ scalarTypeDBName dataLength t)
<+> ")"
JsonQueryExpression e -> "JSON_QUERY(" <+> fromExpression e <+> ")"
JsonValueExpression e path ->
"JSON_VALUE(" <+> fromExpression e <+> fromPath path <+> ")"
ValueExpression value -> QueryPrinter $ toSql value
AndExpression xs ->
case xs of
[] -> truePrinter
_ ->
SepByPrinter
(NewlinePrinter <+> "AND ")
(fmap (\x -> "(" <+> fromExpression x <+> ")") (toList xs))
OrExpression xs ->
case xs of
[] -> falsePrinter
_ ->
SepByPrinter
(NewlinePrinter <+> "OR ")
(fmap (\x -> "(" <+> fromExpression x <+> ")") (toList xs))
NotExpression expression -> "NOT " <+> fromExpression expression
ExistsExpression sel -> "EXISTS (" <+> fromSelect sel <+> ")"
IsNullExpression expression ->
"(" <+> fromExpression expression <+> ") IS NULL"
IsNotNullExpression expression ->
"(" <+> fromExpression expression <+> ") IS NOT NULL"
ColumnExpression fieldName -> fromFieldName fieldName
ToStringExpression e -> "CONCAT(" <+> fromExpression e <+> ", '')"
SelectExpression s -> "(" <+> IndentPrinter 1 (fromSelect s) <+> ")"
OpExpression op x y ->
"("
<+> fromExpression x
<+> ") "
<+> fromOp op
<+> " ("
<+> fromExpression y
<+> ")"
MethodApplicationExpression ex methodAppExp -> fromMethodApplicationExpression ex methodAppExp
FunctionApplicationExpression funAppExp -> fromFunctionApplicationExpression funAppExp
ListExpression xs -> SepByPrinter ", " $ fromExpression <$> xs
STOpExpression op e str ->
"("
<+> fromExpression e
<+> ")."
<+> fromString (show op)
<+> "("
<+> fromExpression str
<+> ") = 1"
ConditionalExpression condition trueExpression falseExpression ->
"(CASE WHEN("
<+> fromExpression condition
<+> ") THEN "
<+> fromExpression trueExpression
<+> " ELSE "
<+> fromExpression falseExpression
<+> " END)"
DefaultExpression -> "DEFAULT"
fromMethodApplicationExpression :: Expression -> MethodApplicationExpression -> Printer
fromMethodApplicationExpression ex methodAppExp =
case methodAppExp of
MethExpSTAsText -> fromApp "STAsText" []
where
fromApp :: Text -> [Expression] -> Printer
fromApp method args =
fromExpression ex
<+> "."
<+> fromString (T.unpack method)
<+> "("
<+> SeqPrinter (map fromExpression args)
<+> ")"
fromFunctionApplicationExpression :: FunctionApplicationExpression -> Printer
fromFunctionApplicationExpression funAppExp = case funAppExp of
(FunExpISNULL x y) -> fromApp "ISNULL" [x, y]
where
fromApp :: Text -> [Expression] -> Printer
fromApp function args =
fromString (T.unpack function)
<+> "("
<+> SepByPrinter ", " (map fromExpression args)
<+> ")"
fromOp :: Op -> Printer
fromOp =
\case
LT -> "<"
GT -> ">"
GTE -> ">="
LTE -> "<="
IN -> "IN"
NIN -> "NOT IN"
LIKE -> "LIKE"
NLIKE -> "NOT LIKE"
EQ' -> "="
NEQ' -> "!="
fromPath :: JsonPath -> Printer
fromPath path =
", " <+> string path
where
string =
fromExpression
. ValueExpression
. TextValue
. L.toStrict
. L.toLazyText
. go
go =
\case
RootPath -> "$"
IndexPath r i -> go r <> "[" <> L.fromString (show i) <> "]"
FieldPath r f -> go r <> ".\"" <> L.fromText f <> "\""
fromFieldName :: FieldName -> Printer
fromFieldName (FieldName {..}) =
fromNameText fieldNameEntity <+> "." <+> fromNameText fieldName
fromInserted :: Inserted -> Printer
fromInserted Inserted = "INSERTED"
fromDeleted :: Deleted -> Printer
fromDeleted Deleted = "DELETED"
fromOutputColumn :: Printer -> OutputColumn -> Printer
fromOutputColumn prefix (OutputColumn columnName) =
prefix <+> "." <+> fromNameText (columnNameText columnName)
fromOutput :: (t -> Printer) -> Output t -> Printer
fromOutput typePrinter (Output ty outputColumns) =
"OUTPUT " <+> SepByPrinter ", " (map (fromOutputColumn (typePrinter ty)) outputColumns)
fromInsertOutput :: InsertOutput -> Printer
fromInsertOutput = fromOutput fromInserted
fromDeleteOutput :: DeleteOutput -> Printer
fromDeleteOutput = fromOutput fromDeleted
fromUpdateOutput :: UpdateOutput -> Printer
fromUpdateOutput = fromOutput fromInserted
fromValues :: Values -> Printer
fromValues (Values values) =
"( " <+> SepByPrinter ", " (map fromExpression values) <+> " )"
fromValuesList :: [Values] -> Printer
fromValuesList valuesList =
"VALUES " <+> SepByPrinter ", " (map fromValues valuesList)
fromInsert :: Insert -> Printer
fromInsert Insert {..} =
SepByPrinter
NewlinePrinter
$ ["INSERT INTO " <+> fromTableName insertTable]
<> [ "(" <+> SepByPrinter ", " (map (fromNameText . columnNameText) insertColumns) <+> ")"
| not (null insertColumns)
]
<> [ fromInsertOutput insertOutput,
"INTO " <+> fromTempTable insertTempTable,
if null insertColumns
then "VALUES " <+> SepByPrinter ", " (map (const "(DEFAULT)") insertValues)
else fromValuesList insertValues
]
fromSetValue :: SetValue -> Printer
fromSetValue = \case
SetON -> "ON"
SetOFF -> "OFF"
fromSetIdentityInsert :: SetIdentityInsert -> Printer
fromSetIdentityInsert SetIdentityInsert {..} =
SepByPrinter
" "
[ "SET IDENTITY_INSERT",
tableName,
fromSetValue setValue
]
where
tableName =
case setTable of
RegularTableName name -> fromTableName name
TemporaryTableName name -> fromTempTableName name
-- | Generate a statement to insert values into temporary table.
fromInsertValuesIntoTempTable :: InsertValuesIntoTempTable -> Printer
fromInsertValuesIntoTempTable InsertValuesIntoTempTable {..} =
SepByPrinter
NewlinePrinter
[ "INSERT INTO " <+> fromTempTableName ivittTempTableName,
"(" <+> SepByPrinter ", " (map (fromNameText . columnNameText) ivittColumns) <+> ")",
fromValuesList ivittValues
]
-- | Alias for the source table in a MERGE statement. Used when pretty printing MERGE statments.
mergeSourceAlias :: Text
mergeSourceAlias = "source"
-- | Alias for the target table in a MERGE statement. Used when pretty printing MERGE statments.
mergeTargetAlias :: Text
mergeTargetAlias = "target"
-- | USING section of a MERGE statement. Used in 'fromMerge'.
fromMergeUsing :: MergeUsing -> Printer
fromMergeUsing MergeUsing {..} =
"USING (" <+> fromSelect selectSubQuery <+> ") AS " <+> fromNameText mergeSourceAlias
where
selectSubQuery :: Select
selectSubQuery =
let alias = "merge_temptable"
columnNameToProjection ColumnName {columnNameText} =
-- merge_temptable.column_name AS column_name
FieldNameProjection $
Aliased
{ aliasedThing = FieldName columnNameText alias,
aliasedAlias = columnNameText
}
in emptySelect
{ selectProjections = map columnNameToProjection mergeUsingColumns,
selectFrom = Just (FromTempTable $ Aliased mergeUsingTempTable alias) -- FROM temp_table AS merge_temptable
}
-- | ON section of a MERGE statement. Used in 'fromMerge'.
fromMergeOn :: MergeOn -> Printer
fromMergeOn MergeOn {..} =
"ON (" <+> onExpression <+> ")"
where
onExpression
| null mergeOnColumns =
falsePrinter
| otherwise =
(fromExpression . AndExpression) (map matchColumn mergeOnColumns)
matchColumn :: ColumnName -> Expression
matchColumn ColumnName {..} =
let sourceColumn = ColumnExpression $ FieldName columnNameText mergeSourceAlias
targetColumn = ColumnExpression $ FieldName columnNameText mergeTargetAlias
in OpExpression EQ' sourceColumn targetColumn
-- | WHEN MATCHED section of a MERGE statement. Used in 'fromMerge'.
fromMergeWhenMatched :: MergeWhenMatched -> Printer
fromMergeWhenMatched (MergeWhenMatched updateColumns updateCondition updatePreset) =
if null updates
then ""
else
"WHEN MATCHED AND "
<+> fromExpression updateCondition
<+> " THEN UPDATE "
<+> fromUpdateSet updates
where
updates = updateSet <> HM.map UpdateSet updatePreset
updateSet :: UpdateSet
updateSet =
HM.fromList $
map
( \cn@ColumnName {..} ->
( cn,
UpdateSet $ ColumnExpression $ FieldName columnNameText mergeSourceAlias
)
)
updateColumns
-- | WHEN NOT MATCHED section of a MERGE statement. Used in 'fromMerge'.
fromMergeWhenNotMatched :: MergeWhenNotMatched -> Printer
fromMergeWhenNotMatched (MergeWhenNotMatched insertColumns) =
SepByPrinter
NewlinePrinter
[ "WHEN NOT MATCHED THEN INSERT (" <+> SepByPrinter ", " (map fromColumnName insertColumns) <+> ")",
fromValuesList [Values columnsFromSource]
]
where
columnsFromSource =
insertColumns <&> \ColumnName {..} -> ColumnExpression $ FieldName columnNameText mergeSourceAlias
-- | Generate a MERGE SQL statement
fromMerge :: Merge -> Printer
fromMerge Merge {..} =
SepByPrinter
NewlinePrinter
[ "MERGE " <+> fromAliased (fmap fromTableName mergeTableAsTarget),
fromMergeUsing mergeUsing,
fromMergeOn mergeOn,
fromMergeWhenMatched mergeWhenMatched,
fromMergeWhenNotMatched mergeWhenNotMatched,
fromInsertOutput mergeInsertOutput,
"INTO " <+> fromTempTable mergeOutputTempTable,
";" -- Always, a Merge statement should end with a ";"
]
where
mergeTableAsTarget :: Aliased TableName
mergeTableAsTarget = Aliased mergeTargetTable mergeTargetAlias
-- | Generate a delete statement
--
-- > Delete
-- > (Aliased (TableName "table" "schema") "alias")
-- > [ColumnName "id", ColumnName "name"]
-- > (Where [OpExpression EQ' (ValueExpression (IntValue 1)) (ValueExpression (IntValue 1))])
--
-- Becomes:
--
-- > DELETE [alias] OUTPUT DELETED.[id], DELETED.[name] INTO #deleted([id], [name]) FROM [schema].[table] AS [alias] WHERE ((1) = (1))
fromDelete :: Delete -> Printer
fromDelete Delete {deleteTable, deleteOutput, deleteTempTable, deleteWhere} =
SepByPrinter
NewlinePrinter
[ "DELETE " <+> fromNameText (aliasedAlias deleteTable),
fromDeleteOutput deleteOutput,
"INTO " <+> fromTempTable deleteTempTable,
"FROM " <+> fromAliased (fmap fromTableName deleteTable),
fromWhere deleteWhere
]
-- | Generate an update statement
--
-- > Update
-- > (Aliased (TableName "table" "schema") "alias")
-- > (fromList [(ColumnName "name", ValueExpression (TextValue "updated_name"))])
-- > (Output Inserted)
-- > (TempTable (TempTableName "updated") [ColumnName "id", ColumnName "name"])
-- > (Where [OpExpression EQ' (ColumnName "id") (ValueExpression (IntValue 1))])
--
-- Becomes:
--
-- > UPDATE [alias] SET [alias].[name] = 'updated_name' OUTPUT INSERTED.[id], INSERTED.[name] INTO
-- > #updated([id], [name]) FROM [schema].[table] AS [alias] WHERE (id = 1)
fromUpdate :: Update -> Printer
fromUpdate Update {..} =
SepByPrinter
NewlinePrinter
[ "UPDATE " <+> fromNameText (aliasedAlias updateTable),
fromUpdateSet updateSet,
fromUpdateOutput updateOutput,
"INTO " <+> fromTempTable updateTempTable,
"FROM " <+> fromAliased (fmap fromTableName updateTable),
fromWhere updateWhere
]
fromUpdateSet :: UpdateSet -> Printer
fromUpdateSet setColumns =
let updateColumnValue (column, updateOp) =
fromColumnName column <+> fromUpdateOperator (fromExpression <$> updateOp)
in "SET " <+> SepByPrinter ", " (map updateColumnValue (HM.toList setColumns))
where
fromUpdateOperator :: UpdateOperator Printer -> Printer
fromUpdateOperator = \case
UpdateSet p -> " = " <+> p
UpdateInc p -> " += " <+> p
-- | Converts `SelectIntoTempTable`.
--
-- > SelectIntoTempTable (TempTableName "deleted") [UnifiedColumn "id" IntegerType, UnifiedColumn "name" TextType] (TableName "table" "schema")
--
-- Becomes:
--
-- > SELECT [id], [name] INTO #deleted([id], [name]) FROM [schema].[table] WHERE (1<>1) UNION ALL SELECT [id], [name] FROM [schema].[table];
--
-- We add the `UNION ALL` part to avoid copying identity constraints, and we cast columns with types such as `timestamp`
-- which are non-insertable to a different type.
fromSelectIntoTempTable :: SelectIntoTempTable -> Printer
fromSelectIntoTempTable SelectIntoTempTable {sittTempTableName, sittColumns, sittFromTableName, sittConstraints} =
SepByPrinter
NewlinePrinter
$ [ "SELECT "
<+> columns,
"INTO " <+> fromTempTableName sittTempTableName,
"FROM " <+> fromTableName sittFromTableName,
"WHERE " <+> falsePrinter
]
<> case sittConstraints of
RemoveConstraints ->
[ "UNION ALL SELECT " <+> columns,
"FROM " <+> fromTableName sittFromTableName,
"WHERE " <+> falsePrinter
]
KeepConstraints ->
[]
where
-- column names separated by commas
columns =
SepByPrinter
("," <+> NewlinePrinter)
(map columnNameFromUnifiedColumn sittColumns)
-- column name with potential modifications of types
columnNameFromUnifiedColumn (UnifiedColumn columnName columnType) =
case columnType of
-- The "timestamp" is type synonym for "rowversion" and it is just an incrementing number and does not preserve a date or a time.
-- So, the "timestamp" type is neither insertable nor explicitly updatable. Its values are unique binary numbers within a database.
-- We're using "binary" type instead so that we can copy a timestamp row value safely into the temporary table.
-- See https://docs.microsoft.com/en-us/sql/t-sql/data-types/rowversion-transact-sql for more details.
TimestampType -> "CAST(" <+> fromColumnName columnName <+> " AS binary(8)) AS " <+> fromColumnName columnName
_ -> fromColumnName columnName
-- | @TempTableName "deleted"@ becomes @\#deleted@
fromTempTableName :: TempTableName -> Printer
fromTempTableName (TempTableName v) = QueryPrinter (fromString . T.unpack $ "#" <> v)
fromTempTable :: TempTable -> Printer
fromTempTable (TempTable table columns) =
fromTempTableName table <+> parens (SepByPrinter ", " (map fromColumnName columns))
-- | @TempTableName "temp_table" is converted to "DROP TABLE #temp_table"
dropTempTableQuery :: TempTableName -> Printer
dropTempTableQuery tempTableName =
QueryPrinter "DROP TABLE " <+> fromTempTableName tempTableName
fromSelect :: Select -> Printer
fromSelect Select {..} = fmap fromWith selectWith ?<+> result
where
result =
SepByPrinter
NewlinePrinter
$ [ "SELECT "
<+> IndentPrinter
7
( SepByPrinter
("," <+> NewlinePrinter)
(map fromProjection (toList selectProjections))
)
]
<> ["FROM " <+> IndentPrinter 5 (fromFrom f) | Just f <- [selectFrom]]
<> [ SepByPrinter
NewlinePrinter
( map
( \Join {..} ->
SeqPrinter
[ "OUTER APPLY (",
IndentPrinter 13 (fromJoinSource joinSource),
") ",
NewlinePrinter,
"AS ",
fromJoinAlias joinJoinAlias
]
)
selectJoins
),
fromWhere selectWhere,
fromOrderBys selectTop selectOffset selectOrderBy,
fromFor selectFor
]
fromWith :: With -> Printer
fromWith (With withSelects) =
"WITH " <+> SepByPrinter ", " (map fromAliasedSelect (toList withSelects)) <+> NewlinePrinter
where
fromAliasedSelect Aliased {..} =
fromNameText aliasedAlias <+> " AS " <+> "( " <+> fromSelect aliasedThing <+> " )"
fromJoinSource :: JoinSource -> Printer
fromJoinSource =
\case
JoinSelect sel -> fromSelect sel
JoinReselect reselect -> fromReselect reselect
fromReselect :: Reselect -> Printer
fromReselect Reselect {..} = result
where
result =
SepByPrinter
NewlinePrinter
[ "SELECT "
<+> IndentPrinter
7
( SepByPrinter
("," <+> NewlinePrinter)
(map fromProjection (toList reselectProjections))
),
fromWhere reselectWhere,
fromFor reselectFor
]
fromOrderBys ::
Top -> Maybe Expression -> Maybe (NonEmpty OrderBy) -> Printer
fromOrderBys NoTop Nothing Nothing = "" -- An ORDER BY is wasteful if not needed.
fromOrderBys top moffset morderBys =
SeqPrinter
[ "ORDER BY ",
IndentPrinter
9
( SepByPrinter
NewlinePrinter
[ case morderBys of
-- If you ORDER BY 1, a text field will signal an
-- error. What we want instead is to just order by
-- nothing, but also satisfy the syntactic
-- requirements. Thus ORDER BY (SELECT NULL).
--
-- This won't create consistent orderings, but that's
-- why you should specify an order_by in your GraphQL
-- query anyway, to define the ordering.
Nothing -> "(SELECT NULL) /* ORDER BY is required for OFFSET */"
Just orderBys ->
SepByPrinter
("," <+> NewlinePrinter)
(concatMap fromOrderBy (toList orderBys)),
case (top, moffset) of
(NoTop, Nothing) -> ""
(NoTop, Just offset) ->
"OFFSET " <+> fromExpression offset <+> " ROWS"
(Top n, Nothing) ->
"OFFSET 0 ROWS FETCH NEXT "
<+> QueryPrinter (toSql (IntValue n))
<+> " ROWS ONLY"
(Top n, Just offset) ->
"OFFSET "
<+> fromExpression offset
<+> " ROWS FETCH NEXT "
<+> QueryPrinter (toSql (IntValue n))
<+> " ROWS ONLY"
]
)
]
fromOrderBy :: OrderBy -> [Printer]
fromOrderBy OrderBy {..} =
[ fromNullsOrder orderByFieldName orderByNullsOrder,
-- Above: This doesn't do anything when using text, ntext or image
-- types. See below on CAST commentary.
wrapNullHandling (fromFieldName orderByFieldName)
<+> " "
<+> fromOrder orderByOrder
]
where
wrapNullHandling inner =
case orderByType of
Just TextType -> castTextish inner
Just WtextType -> castTextish inner
-- Above: For some types, we have to do null handling manually
-- ourselves:
_ -> inner
-- Direct quote from SQL Server error response:
--
-- > The text, ntext, and image data types cannot be compared or
-- > sorted, except when using IS NULL or LIKE operator.
--
-- So we cast it to a varchar, maximum length.
castTextish inner = "CAST(" <+> inner <+> " AS VARCHAR(MAX))"
fromOrder :: Order -> Printer
fromOrder =
\case
AscOrder -> "ASC"
DescOrder -> "DESC"
fromNullsOrder :: FieldName -> NullsOrder -> Printer
fromNullsOrder fieldName =
\case
NullsAnyOrder -> ""
NullsFirst -> "IIF(" <+> fromFieldName fieldName <+> " IS NULL, 0, 1)"
NullsLast -> "IIF(" <+> fromFieldName fieldName <+> " IS NULL, 1, 0)"
fromJoinAlias :: JoinAlias -> Printer
fromJoinAlias JoinAlias {..} =
fromNameText joinAliasEntity
<+>? fmap (\name -> "(" <+> fromNameText name <+> ")") joinAliasField
fromFor :: For -> Printer
fromFor =
\case
NoFor -> ""
JsonFor ForJson {jsonCardinality} ->
"FOR JSON PATH, INCLUDE_NULL_VALUES"
<+> case jsonCardinality of
JsonArray -> ""
JsonSingleton -> ", WITHOUT_ARRAY_WRAPPER"
fromProjection :: Projection -> Printer
fromProjection =
\case
ExpressionProjection aliasedExpression ->
fromAliased (fmap fromExpression aliasedExpression)
FieldNameProjection aliasedFieldName ->
fromAliased (fmap fromFieldName aliasedFieldName)
AggregateProjection aliasedAggregate ->
fromAliased (fmap fromAggregate aliasedAggregate)
StarProjection -> "*"
fromAggregate :: Aggregate -> Printer
fromAggregate =
\case
CountAggregate countable -> "COUNT(" <+> fromCountable countable <+> ")"
OpAggregate op args ->
QueryPrinter (rawUnescapedText op)
<+> "("
<+> SepByPrinter ", " (map fromExpression (toList args))
<+> ")"
TextAggregate text -> fromExpression (ValueExpression (TextValue text))
fromCountable :: Countable FieldName -> Printer
fromCountable =
\case
StarCountable -> "*"
NonNullFieldCountable field -> fromFieldName field
DistinctCountable field -> "DISTINCT " <+> fromFieldName field
fromWhere :: Where -> Printer
fromWhere =
\case
Where expressions
| Just whereExp <- collapseWhere (AndExpression expressions) ->
"WHERE " <+> IndentPrinter 6 (fromExpression whereExp)
| otherwise -> ""
-- | Drop useless examples like this from the output:
--
-- WHERE (((1<>1))
-- AND ((1=1)))
-- AND ((1=1))
--
-- And
--
-- WHERE ((1<>1))
--
-- They're redundant, but make the output less readable.
collapseWhere :: Expression -> Maybe Expression
collapseWhere = go
where
go =
\case
ValueExpression (BoolValue True) -> Nothing
AndExpression xs ->
case mapMaybe go xs of
[] -> Nothing
ys -> pure (AndExpression ys)
e -> pure e
fromFrom :: From -> Printer
fromFrom =
\case
FromQualifiedTable aliasedQualifiedTableName ->
fromAliased (fmap fromTableName aliasedQualifiedTableName)
FromOpenJson openJson -> fromAliased (fmap fromOpenJson openJson)
FromSelect select -> fromAliased (fmap (parens . fromSelect) select)
FromIdentifier identifier -> fromNameText identifier
FromTempTable aliasedTempTable -> fromAliased (fmap fromTempTableName aliasedTempTable)
fromOpenJson :: OpenJson -> Printer
fromOpenJson OpenJson {openJsonExpression, openJsonWith} =
SepByPrinter
NewlinePrinter
[ "OPENJSON("
<+> IndentPrinter 9 (fromExpression openJsonExpression)
<+> ")",
case openJsonWith of
Nothing -> ""
Just openJsonWith' ->
"WITH ("
<+> IndentPrinter
5
( SepByPrinter
("," <+> NewlinePrinter)
(fromJsonFieldSpec <$> toList openJsonWith')
)
<+> ")"
]
fromJsonFieldSpec :: JsonFieldSpec -> Printer
fromJsonFieldSpec =
\case
StringField name mPath -> fromNameText name <+> " NVARCHAR(MAX)" <+> quote mPath
JsonField name mPath -> fromJsonFieldSpec (StringField name mPath) <+> " AS JSON"
ScalarField fieldType fieldLength name mPath ->
fromNameText name
<+> " "
<+> fromString (T.unpack $ scalarTypeDBName fieldLength fieldType)
<+> quote mPath
where
quote mPath = maybe "" ((\p -> " '" <+> p <+> "'") . go) mPath
go = \case
RootPath -> "$"
IndexPath r i -> go r <+> "[" <+> fromString (show i) <+> "]"
FieldPath r f -> go r <+> ".\"" <+> fromString (T.unpack f) <+> "\""
fromTableName :: TableName -> Printer
fromTableName (TableName tableName (SchemaName tableSchema)) =
fromNameText tableSchema <+> "." <+> fromNameText tableName
fromAliased :: Aliased Printer -> Printer
fromAliased Aliased {..} =
aliasedThing
<+> ((" AS " <+>) . fromNameText) aliasedAlias
fromColumnName :: ColumnName -> Printer
fromColumnName (ColumnName colname) = fromNameText colname
fromNameText :: Text -> Printer
fromNameText t = QueryPrinter (rawUnescapedText ("[" <> t <> "]"))
fromRawUnescapedText :: Text -> Printer
fromRawUnescapedText t = QueryPrinter (rawUnescapedText t)
truePrinter :: Printer
truePrinter = "(1=1)"
falsePrinter :: Printer
falsePrinter = "(1<>1)"
parens :: Printer -> Printer
parens p = "(" <+> IndentPrinter 1 p <+> ")"
--------------------------------------------------------------------------------
-- * Basic printing API
-- | Pretty-prints a 'Printer' as one line, converting 'NewlinePrinter' to space.
toQueryFlat :: Printer -> Query
toQueryFlat = go 0
where
go level =
\case
QueryPrinter q -> q
SeqPrinter xs -> mconcat (filter notEmpty (map (go level) xs))
SepByPrinter x xs ->
mconcat
(intersperse (go level x) (filter notEmpty (map (go level) xs)))
NewlinePrinter -> " "
IndentPrinter n p -> go (level + n) p
notEmpty = (/= mempty) . renderQuery
-- | Pretty-prints a 'Printer' as multiple lines as defined by the printer.
toQueryPretty :: Printer -> Query
toQueryPretty = go 0
where
go level =
\case
QueryPrinter q -> q
SeqPrinter xs -> mconcat (filter notEmpty (map (go level) xs))
SepByPrinter x xs ->
mconcat
(intersperse (go level x) (filter notEmpty (map (go level) xs)))
NewlinePrinter -> "\n" <> indentation level
IndentPrinter n p -> go (level + n) p
indentation n = rawUnescapedText (T.replicate n " ")
notEmpty = (/= mempty) . renderQuery