module Database.Relational.Query.Internal.Sub
( SubQuery (..)
, SetOp (..), BinOp (..), Qualifier (..)
, Qualified (..), qualifier, unQualify, qualify
, NodeAttr (..), ProductTree (..)
, Node (..), nodeAttr, nodeTree
, JoinProduct, QueryProductTree
, ProductTreeBuilder, ProductBuilder
, CaseClause (..), WhenClauses(..)
, caseSearch, case'
, UntypedProjection, untypedProjectionWidth, ProjectionUnit (..)
, Projection, untypeProjection, typedProjection, projectionWidth
, projectFromColumns, projectFromScalarSubQuery
, QueryRestriction
) where
import Prelude hiding (and, product)
import Data.DList (DList)
import Data.Foldable (Foldable)
import Data.Traversable (Traversable)
import Database.Relational.Query.Internal.Config (Config)
import Database.Relational.Query.Internal.ContextType (Flat, Aggregated)
import Database.Relational.Query.Internal.SQL (StringSQL)
import Database.Relational.Query.Internal.BaseSQL (Duplication (..), OrderingTerm)
import Database.Relational.Query.Internal.GroupingSQL (AggregateElem)
import Database.Relational.Query.Internal.UntypedTable (Untyped)
data SetOp = Union | Except | Intersect deriving Show
newtype BinOp = BinOp (SetOp, Duplication) deriving Show
data SubQuery = Table Untyped
| Flat Config
UntypedProjection Duplication JoinProduct (QueryRestriction Flat)
[OrderingTerm]
| Aggregated Config
UntypedProjection Duplication JoinProduct (QueryRestriction Flat)
[AggregateElem] (QueryRestriction Aggregated) [OrderingTerm]
| Bin BinOp SubQuery SubQuery
deriving Show
newtype Qualifier = Qualifier Int deriving Show
data Qualified a =
Qualified Qualifier a
deriving (Show, Functor, Foldable, Traversable)
qualifier :: Qualified a -> Qualifier
qualifier (Qualified q _) = q
unQualify :: Qualified a -> a
unQualify (Qualified _ a) = a
qualify :: Qualifier -> a -> Qualified a
qualify = Qualified
data NodeAttr = Just' | Maybe deriving Show
type QS = Qualified SubQuery
type QueryRestrictionBuilder = DList (Projection Flat (Maybe Bool))
data ProductTree rs
= Leaf QS
| Join !(Node rs) !(Node rs) !rs
deriving (Show, Functor)
data Node rs = Node !NodeAttr !(ProductTree rs) deriving (Show, Functor)
nodeAttr :: Node rs -> NodeAttr
nodeAttr (Node a _) = a where
nodeTree :: Node rs -> ProductTree rs
nodeTree (Node _ t) = t
type QueryProductTree = ProductTree (QueryRestriction Flat)
type ProductTreeBuilder = ProductTree QueryRestrictionBuilder
type ProductBuilder = Node QueryRestrictionBuilder
type JoinProduct = Maybe QueryProductTree
data WhenClauses =
WhenClauses [(UntypedProjection, UntypedProjection)] UntypedProjection
deriving Show
data CaseClause
= CaseSearch WhenClauses
| CaseSimple UntypedProjection WhenClauses
deriving Show
data ProjectionUnit
= RawColumn StringSQL
| SubQueryRef (Qualified Int)
| Scalar SubQuery
| Case CaseClause Int
deriving Show
type UntypedProjection = [ProjectionUnit]
untypedProjectionWidth :: UntypedProjection -> Int
untypedProjectionWidth = length
newtype Projection c t =
Projection
{ untypeProjection :: UntypedProjection } deriving Show
typedProjection :: UntypedProjection -> Projection c t
typedProjection = Projection
projectionWidth :: Projection c r -> Int
projectionWidth = length . untypeProjection
projectFromColumns :: [StringSQL]
-> Projection c r
projectFromColumns = typedProjection . map RawColumn
projectFromScalarSubQuery :: SubQuery -> Projection c t
projectFromScalarSubQuery = typedProjection . (:[]) . Scalar
whenClauses :: String
-> [(Projection c a, Projection c b)]
-> Projection c b
-> WhenClauses
whenClauses eTag ws0 e = d ws0
where
d [] = error $ eTag ++ ": Empty when clauses!"
d ws@(_:_) =
WhenClauses [ (untypeProjection p, untypeProjection r) | (p, r) <- ws ]
$ untypeProjection e
caseSearch :: [(Projection c (Maybe Bool), Projection c a)]
-> Projection c a
-> Projection c a
caseSearch ws e =
typedProjection [ Case c i | i <- [0 .. projectionWidth e 1] ]
where
c = CaseSearch $ whenClauses "caseSearch" ws e
case' :: Projection c a
-> [(Projection c a, Projection c b)]
-> Projection c b
-> Projection c b
case' v ws e =
typedProjection [ Case c i | i <- [0 .. projectionWidth e 1] ]
where
c = CaseSimple (untypeProjection v) $ whenClauses "case'" ws e
type QueryRestriction c = [Projection c (Maybe Bool)]