module Database.HaskellDB.Query (
Rel(..), Attr(..), Table(..), Query, Expr(..), OrderExpr
, ToPrimExprs, ConstantRecord
, ShowConstant(..), ExprC(..), ProjectExpr, ProjectRec, InsertRec
, ExprAggr(..), ExprDefault(..)
, copy, copyAll, RelToRec
, (.==.) , (.<>.), (.<.), (.<=.), (.>.), (.>=.)
, (.&&.) , (.||.)
, (.*.), (./.), (.+.), (.-.), (.%.), (.++.)
, (<<), (<<-)
, project, restrict, table, unique
, union, intersect, divide, minus
, _not, like, _in, cat, _length
, isNull, notNull
, fromNull, fromVal
, constant, constVal, constNull, constExpr
, param, namedParam, Args, func, cast
, toStr, coerce , select
, count, _sum, _max, _min, avg , literal
, stddev, stddevP, variance, varianceP
, asc, desc, order , top
, _case , _default
, runQuery, runQueryRel, unQuery
, subQuery
, attribute, attributeName, tableName, baseTable, emptyTable
, exprs, labels, tableRec
, constantRecord
) where
import Database.HaskellDB.HDBRec
import Database.HaskellDB.PrimQuery
import Database.HaskellDB.BoundedString
import Database.HaskellDB.BoundedList
import System.Time (CalendarTime)
infix 8 `like`, `_in`
infixl 7 .*., ./., .%.
infixl 6 .+.,.-.
infix 6 <<, <<-
infixr 5 .++.
infix 4 .==., .<>., .<., .<=., .>., .>=.
infixr 3 .&&.
infixr 2 .||.
data Rel r = Rel Alias Scheme
newtype Expr a = Expr PrimExpr
deriving (Read, Show)
newtype ExprAggr a = ExprAggr PrimExpr deriving (Read, Show)
newtype ExprDefault a = ExprDefault PrimExpr deriving (Read, Show)
data Table r = Table TableName Assoc
data Attr f a = Attr Attribute
type Alias = Int
type QState = (Alias,PrimQuery)
data Query a = Query (QState -> (a,QState))
scheme :: Rel r -> Scheme
scheme (Rel _ s) = s
attributeName :: Attr f a -> Attribute
attributeName (Attr name) = name
class ExprC e where
primExpr :: e a -> PrimExpr
instance ExprC Expr where primExpr ~(Expr e) = e
instance ExprC ExprAggr where primExpr ~(ExprAggr e) = e
instance ExprC ExprDefault where primExpr ~(ExprDefault e) = e
class ExprC e => InsertExpr e
instance InsertExpr Expr
instance InsertExpr ExprDefault
class InsertRec r er | r -> er
instance InsertRec RecNil RecNil
instance (InsertExpr e, InsertRec r er) =>
InsertRec (RecCons f (e a) r) (RecCons f (Expr a) er)
class ExprC e => ProjectExpr e
instance ProjectExpr Expr
instance ProjectExpr ExprAggr
class ProjectRec r er | r -> er
instance ProjectRec RecNil RecNil
instance (ProjectExpr e, ProjectRec r er) =>
ProjectRec (RecCons f (e a) r) (RecCons f (Expr a) er)
( << ) :: Attr f a
-> e a
-> Record (RecCons f (e a) RecNil)
_ << x = RecCons x
( <<- ) :: ShowConstant a =>
Attr f a
-> a
-> Record (RecCons f (Expr a) RecNil)
f <<- x = f << constant x
copy :: (HasField f r) => Attr f a -> Rel r -> Record (RecCons f (Expr a) RecNil)
copy attr tbl = attr << tbl ! attr
copyAll :: (RelToRec r) => Rel r -> Record r
copyAll = relToRec
class RelToRec a where
relToRec :: Rel a -> Record a
instance RelToRec RecNil where
relToRec v = \_ -> unRel v
where
unRel :: Rel r -> r
unRel = error "unRel RelToRec RecNil"
instance (RelToRec rest, FieldTag f) => RelToRec (RecCons f (Expr a) rest) where
relToRec t@(Rel v s) = copy (attr . fieldT $ t) t # relToRec (restT t)
where
attr :: FieldTag f => f -> Attr f a
attr = Attr . fieldName
fieldT :: Rel (RecCons f a rest) -> f
fieldT = error "fieldT"
restT :: Rel (RecCons f a rest) -> Rel rest
restT _ = Rel v s
instance HasField f r => Select (Attr f a) (Rel r) (Expr a) where
(!) rel attr = select attr rel
select :: HasField f r => Attr f a -> Rel r -> Expr a
select (Attr attribute) (Rel alias scheme)
= Expr (AttrExpr (fresh alias attribute))
project :: (ShowLabels r, ToPrimExprs r, ProjectRec r er) => Record r -> Query (Rel er)
project r
= do
alias <- newAlias
let scheme = labels r
assoc = zip (map (fresh alias) scheme) (exprs r)
updatePrimQuery (extend assoc)
return (Rel alias scheme)
restrict :: Expr Bool -> Query ()
restrict (Expr primExpr) = updatePrimQuery_ (Restrict primExpr)
unique :: Query ()
unique = Query (\(i, primQ) ->
case nonAggr primQ of
[] -> ((), (i + 1, primQ))
newCols -> ((), (i + 1, Group newCols primQ)))
where
nonAggr :: PrimQuery -> Assoc
nonAggr p = map toAttrExpr . filter (not . isAggregate . snd) . projected $ p
toAttrExpr (col, _) = (col, AttrExpr col)
projected :: PrimQuery -> Assoc
projected (Project cols q) = cols
projected (Restrict _ q) = projected q
projected (Binary _ q1 q2) = projected q1 ++ projected q2
projected (BaseTable tblName cols) = zip cols (map AttrExpr cols)
projected (Special _ q) = projected q
projected (Group _ _) = []
projected Empty = []
binrel :: RelOp -> Query (Rel r) -> Query (Rel r) -> Query (Rel r)
binrel op (Query q1) (Query q2)
= Query (\(i,primQ) ->
let (Rel a1 scheme1,(j,primQ1)) = q1 (i,primQ)
(Rel a2 scheme2,(alias,primQ2)) = q2 (j,primQ)
scheme = scheme1
assoc1 = zip (map (fresh alias) scheme1)
(map (AttrExpr . fresh a1) scheme1)
assoc2 = zip (map (fresh alias) scheme2)
(map (AttrExpr . fresh a2) scheme2)
r1 = Project assoc1 primQ1
r2 = Project assoc2 primQ2
r = Binary op r1 r2
in
(Rel alias scheme,(alias + 1, times r primQ)) )
union :: Query (Rel r) -> Query (Rel r) -> Query (Rel r)
union = binrel Union
intersect :: Query (Rel r) -> Query (Rel r) -> Query (Rel r)
intersect = binrel Intersect
divide :: Query (Rel r) -> Query (Rel r) -> Query (Rel r)
divide = binrel Divide
minus :: Query (Rel r) -> Query (Rel r) -> Query (Rel r)
minus = binrel Difference
table :: (ShowRecRow r) => Table r -> Query (Rel r)
table (Table name assoc)
= do
alias <- newAlias
let newAssoc = map (\(attr,expr) -> (fresh alias attr,expr)) assoc
scheme = map fst assoc
q = Project newAssoc (BaseTable name scheme)
updatePrimQuery (times q)
return (Rel alias scheme)
tableName :: Table t -> TableName
tableName (Table n _) = n
tableRec :: Table (Record r) -> Record r
tableRec = error "tableRec should never be evaluated."
baseTable :: (ShowLabels r, ToPrimExprs r) => TableName -> Record r -> Table r
baseTable t r = Table t (zip (labels r) (exprs r))
emptyTable :: TableName -> Table (Record RecNil)
emptyTable t = Table t []
attribute :: String -> Expr a
attribute name = Expr (AttrExpr name)
namedParam :: Name
-> Expr a
-> Expr a
namedParam n (Expr def) = Expr (ParamExpr (Just n) def)
param :: Expr a
-> Expr a
param (Expr def) = Expr (ParamExpr Nothing def)
unop :: UnOp -> Expr a -> Expr b
unop op (Expr primExpr)
= Expr (UnExpr op primExpr)
binop :: BinOp -> Expr a -> Expr b -> Expr c
binop op (Expr primExpr1) (Expr primExpr2)
= Expr (BinExpr op primExpr1 primExpr2)
(.==.) :: Eq a => Expr a -> Expr a -> Expr Bool
(.==.) = binop OpEq
(.<>.) :: Eq a => Expr a -> Expr a -> Expr Bool
(.<>.) = binop OpNotEq
(.<.) :: Ord a => Expr a -> Expr a -> Expr Bool
(.<.) = binop OpLt
(.<=.) :: Ord a => Expr a -> Expr a -> Expr Bool
(.<=.) = binop OpLtEq
(.>.) :: Ord a => Expr a -> Expr a -> Expr Bool
(.>.) = binop OpGt
(.>=.) :: Ord a => Expr a -> Expr a -> Expr Bool
(.>=.) = binop OpGtEq
_not :: Expr Bool -> Expr Bool
_not = unop OpNot
(.&&.):: Expr Bool -> Expr Bool -> Expr Bool
(.&&.) = binop OpAnd
(.||.) :: Expr Bool -> Expr Bool -> Expr Bool
(.||.) = binop OpOr
like :: Expr String -> Expr String -> Expr Bool
like = binop OpLike
_in :: Eq a => Expr a -> [Expr a] -> Expr Bool
_in (Expr x) ys = Expr (BinExpr OpIn x (ListExpr [y | Expr y <- ys]))
cat :: Expr String -> Expr String -> Expr String
cat = binop OpCat
(.++.) :: Expr String -> Expr String -> Expr String
(.++.) = cat
_length :: Expr String -> Expr Int
_length = unop OpLength
numop :: Num a => BinOp -> Expr a -> Expr a -> Expr a
numop = binop
(.+.) :: Num a => Expr a -> Expr a -> Expr a
(.+.) = numop OpPlus
(.-.) :: Num a => Expr a -> Expr a -> Expr a
(.-.) = numop OpMinus
(.*.) :: Num a => Expr a -> Expr a -> Expr a
(.*.) = numop OpMul
(./.) :: Num a => Expr a -> Expr a -> Expr a
(./.) = numop OpDiv
(.%.) :: Num a => Expr a -> Expr a -> Expr a
(.%.) = numop OpMod
isNull :: Expr a -> Expr Bool
isNull = unop OpIsNull
notNull :: Expr a -> Expr Bool
notNull = unop OpIsNotNull
_case :: [(Expr Bool, Expr a)]
-> Expr a
-> Expr a
_case cs (Expr el) = Expr (CaseExpr [ (c,e) | (Expr c, Expr e) <- cs] el)
class BStrToStr s d where
toStr :: s -> d
instance (Size n) => BStrToStr (Expr (BoundedString n)) (Expr String) where
toStr (Expr e) = (Expr e)
instance (Size n) => BStrToStr (Expr (Maybe (BoundedString n))) (Expr (Maybe String)) where
toStr (Expr m) = (Expr m)
instance BStrToStr (Expr (Maybe String)) (Expr (Maybe String)) where
toStr (Expr m) = (Expr m)
instance BStrToStr (Expr String) (Expr String) where
toStr (Expr m) = (Expr m)
class Args a where
arg_ :: String -> [PrimExpr] -> a
class IsExpr a
instance (IsExpr tail) => IsExpr (Expr a -> tail)
instance IsExpr (Expr a)
instance (IsExpr tail, Args tail) => Args (Expr a -> tail) where
arg_ name exprs = \(Expr prim) -> arg_ name (prim : exprs)
instance Args (Expr a) where
arg_ name exprs = Expr (FunExpr name (reverse exprs))
instance Args (Expr a -> ExprAggr c) where
arg_ name exprs = \(Expr prim) -> ExprAggr (AggrExpr (AggrOther name) prim)
func :: (Args a) => String -> a
func name = arg_ name []
_default :: ExprDefault a
_default = ExprDefault (ConstExpr DefaultLit)
class ShowConstant a where
showConstant :: a -> Literal
instance ShowConstant String where
showConstant = StringLit
instance ShowConstant Int where
showConstant = IntegerLit . fromIntegral
instance ShowConstant Integer where
showConstant = IntegerLit
instance ShowConstant Double where
showConstant = DoubleLit
instance ShowConstant Bool where
showConstant = BoolLit
instance ShowConstant CalendarTime where
showConstant = DateLit
instance ShowConstant a => ShowConstant (Maybe a) where
showConstant = maybe NullLit showConstant
instance Size n => ShowConstant (BoundedString n) where
showConstant = showConstant . fromBounded
constant :: ShowConstant a => a -> Expr a
constant x = Expr (ConstExpr (showConstant x))
literal :: String -> Expr a
literal x = Expr (ConstExpr (OtherLit x))
fromNull :: Expr a
-> Expr (Maybe a)
-> Expr a
fromNull d x@(Expr px) = _case [(isNull x, d)] (Expr px)
fromVal :: ShowConstant a => a
-> Expr (Maybe a)
-> Expr a
fromVal = fromNull . constant
constExpr :: Expr a -> Expr (Maybe a)
constExpr (Expr x) = (Expr x)
constVal :: ShowConstant a => a -> Expr (Maybe a)
constVal x = constant (Just x)
constNull :: Expr (Maybe a)
constNull = Expr (ConstExpr NullLit)
cast :: String
-> Expr a
-> Expr b
cast typ (Expr expr) = Expr (CastExpr typ expr)
coerce :: Expr a
-> Expr b
coerce (Expr e) = Expr e
class ConstantRecord r cr | r -> cr where
constantRecord :: r -> cr
instance ConstantRecord r cr => ConstantRecord (Record r) (Record cr) where
constantRecord r = \n -> constantRecord (r n)
instance ConstantRecord RecNil RecNil where
constantRecord RecNil = RecNil
instance (ShowConstant a, ConstantRecord r cr)
=> ConstantRecord (RecCons f a r) (RecCons f (Expr a) cr) where
constantRecord ~(RecCons x rs) = RecCons (constant x) (constantRecord rs)
aggregate :: AggrOp -> Expr a -> ExprAggr b
aggregate op (Expr primExpr) = ExprAggr (AggrExpr op primExpr)
count :: Expr a -> ExprAggr Int
count x = aggregate AggrCount x
_sum :: Num a => Expr a -> ExprAggr a
_sum x = aggregate AggrSum x
_max :: Ord a => Expr a -> ExprAggr a
_max x = aggregate AggrMax x
_min :: Ord a => Expr a -> ExprAggr a
_min x = aggregate AggrMin x
avg :: Num a => Expr a -> ExprAggr a
avg x = aggregate AggrAvg x
stddev :: Num a => Expr a -> ExprAggr a
stddev x = aggregate AggrStdDev x
stddevP :: Num a => Expr a -> ExprAggr a
stddevP x = aggregate AggrStdDevP x
variance :: Num a => Expr a -> ExprAggr a
variance x = aggregate AggrVar x
varianceP :: Num a => Expr a -> ExprAggr a
varianceP x = aggregate AggrVarP x
top :: Int -> Query ()
top n = updatePrimQuery_ (Special (Top n))
orderOp :: HasField f r => OrderOp -> Rel r -> Attr f a -> OrderExpr
orderOp op rel attr = OrderExpr op expr
where Expr expr = select attr rel
asc :: HasField f r => Rel r -> Attr f a -> OrderExpr
asc rel attr = orderOp OpAsc rel attr
desc :: (HasField f r) => Rel r -> Attr f a -> OrderExpr
desc rel attr = orderOp OpDesc rel attr
order :: [OrderExpr] -> Query ()
order xs = updatePrimQuery_ (Special (Order xs))
unQuery :: Query a -> a
unQuery (Query g) = fst $ g (1, Empty)
runQuery :: Query (Rel r) -> PrimQuery
runQuery = fst . runQueryRel
runQueryRel :: Query (Rel r) -> (PrimQuery,Rel r)
runQueryRel (Query f)
= let (Rel alias scheme,(i,primQuery)) = f (1,Empty)
assoc = zip scheme (map (AttrExpr . fresh alias) scheme)
in (Project assoc primQuery, Rel 0 scheme)
subQuery :: Query (Rel r) -> Query (Rel r)
subQuery (Query qs) = Query make
where
make (currentAlias, currentQry) =
let (Rel otherAlias otherScheme,(newestAlias, otherQuery)) = qs (currentAlias,Empty)
assoc = zip (map (fresh newestAlias) otherScheme)
(map (AttrExpr . fresh otherAlias) otherScheme)
in (Rel newestAlias otherScheme, (newestAlias + 1, times (Project assoc otherQuery) currentQry))
instance Functor Query where
fmap f (Query g) = Query (\q0 -> let (x,q1) = g q0 in (f x,q1))
instance Monad Query where
return x = Query (\q0 -> (x,q0))
(Query g) >>= f = Query (\q0 -> let (x,q1) = g q0
(Query h) = f x
in (h q1))
updatePrimQuery :: (PrimQuery -> PrimQuery) -> Query PrimQuery
updatePrimQuery f = Query (\(i,qt) -> (qt,(i,f qt)))
updatePrimQuery_ :: (PrimQuery -> PrimQuery) -> Query ()
updatePrimQuery_ f = updatePrimQuery f >> return ()
newAlias :: Query Alias
newAlias = Query (\(i,qt) -> (i,(i+1,qt)))
fresh :: Alias -> Attribute -> Attribute
fresh 0 attribute = attribute
fresh alias attribute = (attribute ++ show alias)
labels :: ShowLabels r => r -> [String]
labels = recordLabels
exprs :: ToPrimExprs r => Record r -> [PrimExpr]
exprs r = toPrimExprs (r RecNil)
class ToPrimExprs r where
toPrimExprs :: r -> [PrimExpr]
instance ToPrimExprs RecNil where
toPrimExprs ~RecNil = []
instance (ExprC e, ToPrimExprs r) => ToPrimExprs (RecCons l (e a) r) where
toPrimExprs ~(RecCons e r) = primExpr e : toPrimExprs r