module Database.Relational.Query.Component
(
ColumnSQL, columnSQL, columnSQL', showsColumnSQL,
NameConfig (..),
SchemaNameMode (..),
Config ( productUnitSupport
, chunksInsertSize
, schemaNameMode
, normalizedTableName
, verboseAsCompilerWarning
, nameConfig
, identifierQuotation),
defaultConfig,
ProductUnitSupport (..), Duplication (..), IdentifierQuotation (..),
showsDuplication,
AggregateColumnRef,
AggregateBitKey, AggregateSet, AggregateElem,
aggregateColumnRef, aggregateEmpty,
aggregatePowerKey, aggregateGroupingSet,
aggregateRollup, aggregateCube, aggregateSets,
composeGroupBy, composePartitionBy,
AggregateKey, aggregateKeyProjection, aggregateKeyElement, unsafeAggregateKey,
Order (..), OrderColumn, OrderingTerm, OrderingTerms,
composeOrderBy,
AssignColumn, AssignTerm, Assignment, Assignments, composeSets, composeValues,
composeOver,
) where
import Data.Monoid (Monoid (..), (<>))
import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, showStringSQL, rowConsStringSQL)
import Language.SQL.Keyword (Keyword(..), (|*|), (.=.))
import qualified Language.SQL.Keyword as SQL
import Language.Haskell.TH.Name.CamelCase (VarName, varCamelcaseName)
import qualified Database.Record.TH as RecordTH
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 NameConfig =
NameConfig
{ recordConfig :: RecordTH.NameConfig
, relationVarName :: String -> String -> VarName
}
instance Show NameConfig where
show = const "<NameConfig>"
data SchemaNameMode
= SchemaQualified
| SchemaNotQualified
deriving (Eq, Show)
data Config =
Config
{ productUnitSupport :: !ProductUnitSupport
, chunksInsertSize :: !Int
, schemaNameMode :: !SchemaNameMode
, normalizedTableName :: !Bool
, verboseAsCompilerWarning :: !Bool
, nameConfig :: !NameConfig
, identifierQuotation :: !IdentifierQuotation
} deriving Show
defaultConfig :: Config
defaultConfig =
Config { productUnitSupport = PUSupported
, chunksInsertSize = 256
, schemaNameMode = SchemaQualified
, normalizedTableName = True
, verboseAsCompilerWarning = False
, nameConfig = NameConfig { recordConfig = RecordTH.defaultNameConfig
, relationVarName = const varCamelcaseName
}
, identifierQuotation = NoQuotation
}
data ProductUnitSupport = PUSupported | PUNotSupported deriving Show
data IdentifierQuotation = NoQuotation | Quotation Char deriving Show
data Duplication = All | Distinct deriving Show
showsDuplication :: Duplication -> StringSQL
showsDuplication = dup where
dup All = ALL
dup Distinct = DISTINCT
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)
newtype AggregateKey a = AggregateKey (a, AggregateElem)
aggregateKeyProjection :: AggregateKey a -> a
aggregateKeyProjection (AggregateKey (p, _c)) = p
aggregateKeyElement :: AggregateKey a -> AggregateElem
aggregateKeyElement (AggregateKey (_p, c)) = c
unsafeAggregateKey :: (a, AggregateElem) -> AggregateKey a
unsafeAggregateKey = AggregateKey
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
composeValues :: Assignments -> StringSQL
composeValues as = rowConsStringSQL [ showsColumnSQL c | c <- cs ] <> VALUES <>
rowConsStringSQL [ showsColumnSQL c | c <- vs ] where
(cs, vs) = unzip as
composeOver :: [AggregateColumnRef] -> OrderingTerms -> StringSQL
composeOver pts ots =
OVER <> SQL.paren (composePartitionBy pts <> composeOrderBy ots)