module Database.Relational.Query.Component (
ColumnSQL, columnSQL, columnSQL', showsColumnSQL,
Config (productUnitSupport, chunksInsertSize, normalizedTableName),
defaultConfig,
ProductUnitSupport (..), Duplication (..),
showsDuplication,
QueryRestriction, composeWhere, composeHaving,
AggregateColumnRef,
AggregateBitKey, AggregateSet, AggregateElem,
aggregateColumnRef, aggregateEmpty,
aggregatePowerKey, aggregateGroupingSet,
aggregateRollup, aggregateCube, aggregateSets,
composeGroupBy, composePartitionBy,
Order (..), OrderColumn, OrderingTerm, OrderingTerms,
composeOrderBy,
AssignColumn, AssignTerm, Assignment, Assignments, composeSets,
composeOver
) where
import Data.Monoid (Monoid (..), (<>))
import qualified Database.Relational.Query.Context as Context
import Database.Relational.Query.Expr (Expr, exprAnd)
import Database.Relational.Query.Expr.Unsafe (sqlExpr)
import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, showStringSQL)
import Language.SQL.Keyword (Keyword(..), (|*|), (.=.))
import qualified Language.SQL.Keyword as SQL
newtype ColumnSQL' a = ColumnSQL a
instance Functor ColumnSQL' where
fmap f (ColumnSQL c) = ColumnSQL $ f c
type ColumnSQL = ColumnSQL' StringSQL
columnSQL :: String -> ColumnSQL
columnSQL = columnSQL' . stringSQL
columnSQL' :: StringSQL -> ColumnSQL
columnSQL' = ColumnSQL
stringFromColumnSQL :: ColumnSQL -> String
stringFromColumnSQL = showStringSQL . showsColumnSQL
showsColumnSQL :: ColumnSQL -> StringSQL
showsColumnSQL (ColumnSQL c) = c
instance Show ColumnSQL where
show = stringFromColumnSQL
data Config =
Config
{ productUnitSupport :: ProductUnitSupport
, chunksInsertSize :: Int
, normalizedTableName :: Bool
} deriving Show
defaultConfig :: Config
defaultConfig = Config { productUnitSupport = PUSupported
, chunksInsertSize = 256
, normalizedTableName = True
}
data ProductUnitSupport = PUSupported | PUNotSupported deriving Show
data Duplication = All | Distinct deriving Show
showsDuplication :: Duplication -> StringSQL
showsDuplication = dup where
dup All = ALL
dup Distinct = DISTINCT
type QueryRestriction c = [Expr c Bool]
composeRestrict :: Keyword -> QueryRestriction c -> StringSQL
composeRestrict k = d where
d [] = mempty
d e@(_:_) = k <> sqlExpr (foldr1 exprAnd e)
composeWhere :: QueryRestriction Context.Flat -> StringSQL
composeWhere = composeRestrict WHERE
composeHaving :: QueryRestriction Context.Aggregated -> StringSQL
composeHaving = composeRestrict HAVING
type AggregateColumnRef = ColumnSQL
newtype AggregateBitKey = AggregateBitKey [AggregateColumnRef] deriving Show
newtype AggregateSet = AggregateSet [AggregateElem] deriving Show
data AggregateElem = ColumnRef AggregateColumnRef
| Rollup [AggregateBitKey]
| Cube [AggregateBitKey]
| GroupingSets [AggregateSet]
deriving Show
aggregateColumnRef :: AggregateColumnRef -> AggregateElem
aggregateColumnRef = ColumnRef
aggregatePowerKey :: [AggregateColumnRef] -> AggregateBitKey
aggregatePowerKey = AggregateBitKey
aggregateGroupingSet :: [AggregateElem] -> AggregateSet
aggregateGroupingSet = AggregateSet
aggregateRollup :: [AggregateBitKey] -> AggregateElem
aggregateRollup = Rollup
aggregateCube :: [AggregateBitKey] -> AggregateElem
aggregateCube = Cube
aggregateSets :: [AggregateSet] -> AggregateElem
aggregateSets = GroupingSets
aggregateEmpty :: [AggregateElem]
aggregateEmpty = []
showsAggregateColumnRef :: AggregateColumnRef -> StringSQL
showsAggregateColumnRef = showsColumnSQL
commaed :: [StringSQL] -> StringSQL
commaed = SQL.fold (|*|)
pComma :: (a -> StringSQL) -> [a] -> StringSQL
pComma qshow = SQL.paren . commaed . map qshow
showsAggregateBitKey :: AggregateBitKey -> StringSQL
showsAggregateBitKey (AggregateBitKey ts) = pComma showsAggregateColumnRef ts
composeGroupBy :: [AggregateElem] -> StringSQL
composeGroupBy = d where
d [] = mempty
d es@(_:_) = GROUP <> BY <> rec es
keyList op ss = op <> pComma showsAggregateBitKey ss
rec = commaed . map showsE
showsGs (AggregateSet s) = SQL.paren $ rec s
showsE (ColumnRef t) = showsAggregateColumnRef t
showsE (Rollup ss) = keyList ROLLUP ss
showsE (Cube ss) = keyList CUBE ss
showsE (GroupingSets ss) = GROUPING <> SETS <> pComma showsGs ss
composePartitionBy :: [AggregateColumnRef] -> StringSQL
composePartitionBy = d where
d [] = mempty
d ts@(_:_) = PARTITION <> BY <> commaed (map showsAggregateColumnRef ts)
data Order = Asc | Desc deriving Show
type OrderColumn = ColumnSQL
type OrderingTerm = (Order, OrderColumn)
type OrderingTerms = [OrderingTerm]
composeOrderBy :: OrderingTerms -> StringSQL
composeOrderBy = d where
d [] = mempty
d ts@(_:_) = ORDER <> BY <> commaed (map showsOt ts)
showsOt (o, e) = showsColumnSQL e <> order o
order Asc = ASC
order Desc = DESC
type AssignColumn = ColumnSQL
type AssignTerm = ColumnSQL
type Assignment = (AssignColumn, AssignTerm)
type Assignments = [Assignment]
composeSets :: Assignments -> StringSQL
composeSets as = assigns where
assignList = foldr (\ (col, term) r ->
(showsColumnSQL col .=. showsColumnSQL term) : r)
[] as
assigns | null assignList = error "Update assignment list is null!"
| otherwise = SET <> commaed assignList
composeOver :: [AggregateColumnRef] -> OrderingTerms -> StringSQL
composeOver pts ots =
OVER <> SQL.paren (composePartitionBy pts <> composeOrderBy ots)