mirror of
https://github.com/khibino/haskell-relational-record.git
synced 2024-12-12 12:09:08 +03:00
ORDER BY support.
This commit is contained in:
Kei Hibino
parent
7824af3a78
commit
c11310fc59
@ -21,4 +21,4 @@ import Database.Relational.Query.Projection
|
||||
value, valueTrue, valueFalse, valueNull, placeholder)
|
||||
import Database.Relational.Query.Relation (Relation)
|
||||
import Database.Relational.Query.Join
|
||||
import Database.Relational.Query.Type (Query, untypeQuery, toQuery)
|
||||
import Database.Relational.Query.Type (Query, untypeQuery, fromRelation)
|
||||
|
||||
@ -2,7 +2,7 @@
|
||||
module Database.Relational.Query.Join (
|
||||
QueryJoin,
|
||||
|
||||
on, wheres,
|
||||
on, wheres, asc, desc,
|
||||
table,
|
||||
|
||||
record, expr, compose, (>*<), (!), (!?), relation,
|
||||
@ -25,7 +25,7 @@ import qualified Database.Relational.Query.AliasId as AliasId
|
||||
import Database.Relational.Query.Table (Table)
|
||||
import Database.Relational.Query.Sub (SubQuery)
|
||||
|
||||
import Database.Relational.Query.Expr (Expr)
|
||||
import Database.Relational.Query.Expr (Expr, showExpr)
|
||||
import qualified Database.Relational.Query.Expr as Expr
|
||||
|
||||
import Database.Relational.Query.Product
|
||||
@ -37,17 +37,18 @@ import qualified Database.Relational.Query.Projection as Projection
|
||||
|
||||
import Database.Relational.Query.Pi (Pi)
|
||||
|
||||
import Database.Relational.Query.Relation (Relation, finalizeRelation)
|
||||
import Database.Relational.Query.Relation (Relation, finalizeRelation, Order(Asc, Desc))
|
||||
import qualified Database.Relational.Query.Relation as Relation
|
||||
|
||||
data Context = Context
|
||||
{ currentAliasId :: AliasId
|
||||
, product :: Maybe QueryProduct
|
||||
, restriction :: Maybe (Expr Bool)
|
||||
, orderByRev :: [(Order, String)]
|
||||
}
|
||||
|
||||
primContext :: Context
|
||||
primContext = Context primAlias Nothing Nothing
|
||||
primContext = Context primAlias Nothing Nothing []
|
||||
|
||||
nextAliasContext :: Context -> Context
|
||||
nextAliasContext s = s { currentAliasId = newAliasId (currentAliasId s) }
|
||||
@ -62,6 +63,10 @@ updateRestriction' e1 ctx =
|
||||
where uf Nothing = e1
|
||||
uf (Just e0) = e0 `Expr.and` e1
|
||||
|
||||
updateOrderBy' :: Order -> Expr t -> Context -> Context
|
||||
updateOrderBy' order e ctx =
|
||||
ctx { orderByRev = ((order, showExpr e) :) . orderByRev $ ctx }
|
||||
|
||||
|
||||
newtype QueryJoin a =
|
||||
QueryJoin { runQueryJoin :: Context -> (a, Context) }
|
||||
@ -89,6 +94,9 @@ updateJoinRestriction e = updateContext (updateProduct' d) where
|
||||
updateRestriction :: Expr Bool -> QueryJoin ()
|
||||
updateRestriction e = updateContext (updateRestriction' e)
|
||||
|
||||
updateOrderBy :: Order -> Expr t -> QueryJoin ()
|
||||
updateOrderBy order e = updateContext (updateOrderBy' order e)
|
||||
|
||||
|
||||
on :: Expr Bool -> QueryJoin ()
|
||||
on = updateJoinRestriction
|
||||
@ -96,6 +104,12 @@ on = updateJoinRestriction
|
||||
wheres :: Expr Bool -> QueryJoin ()
|
||||
wheres = updateRestriction
|
||||
|
||||
asc :: Expr t -> QueryJoin ()
|
||||
asc = updateOrderBy Asc
|
||||
|
||||
desc :: Expr t -> QueryJoin ()
|
||||
desc = updateOrderBy Desc
|
||||
|
||||
|
||||
table :: Table r -> Relation r
|
||||
table = Relation.fromTable
|
||||
@ -157,7 +171,7 @@ from :: Table r -> QueryJoin (Projection r)
|
||||
from = inner . table
|
||||
|
||||
relation :: QueryJoin (Projection r) -> Relation r
|
||||
relation q = finalizeRelation projection product' (restriction st) where
|
||||
relation q = finalizeRelation projection product' (restriction st) (orderByRev st) where
|
||||
(projection, st) = runQueryPrime q
|
||||
product' = maybe (error "relation: empty product!") Product.tree $ product st
|
||||
|
||||
|
||||
@ -1,6 +1,8 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Database.Relational.Query.Relation (
|
||||
|
||||
Order (..),
|
||||
Relation,
|
||||
|
||||
outer,
|
||||
@ -13,6 +15,7 @@ module Database.Relational.Query.Relation (
|
||||
) where
|
||||
|
||||
import Prelude hiding (product, and)
|
||||
import Data.List (foldl')
|
||||
|
||||
import Database.Relational.Query.AliasId (asColumnN)
|
||||
|
||||
@ -33,11 +36,14 @@ import Language.SQL.Keyword (Keyword(..), unwordsSQL)
|
||||
import qualified Language.SQL.Keyword as SQL
|
||||
|
||||
|
||||
data Order = Asc | Desc
|
||||
|
||||
data Relation r = Table (Table r)
|
||||
| Relation
|
||||
{ projection :: Projection r
|
||||
, product :: Product
|
||||
, restriction :: Maybe (Expr Bool)
|
||||
, orderByRev :: [(Order, String)]
|
||||
}
|
||||
|
||||
outer :: Relation r -> Relation (Maybe r)
|
||||
@ -53,17 +59,23 @@ width = d where
|
||||
fromTable :: Table r -> Relation r
|
||||
fromTable = Table
|
||||
|
||||
composedSQL :: Projection r -> Product -> Maybe (Expr Bool) -> String
|
||||
composedSQL pj pd re =
|
||||
composedSQL :: Projection r -> Product -> Maybe (Expr Bool) -> [(Order, String)] -> String
|
||||
composedSQL pj pd re odRev =
|
||||
unwordsSQL
|
||||
$ [SELECT, columns' `SQL.sepBy` SQL.word ", ",
|
||||
FROM, SQL.word . productSQL $ pd ]
|
||||
$ [SELECT, columns' `SQL.sepBy` ", ",
|
||||
FROM, SQL.word . productSQL $ pd]
|
||||
++ wheres re
|
||||
++ orders
|
||||
where columns' = zipWith
|
||||
(\f n -> SQL.word f `asColumnN` n)
|
||||
(Projection.columns pj)
|
||||
[(0 :: Int)..]
|
||||
wheres = maybe [] (\e -> [WHERE, SQL.word . showExpr $ e])
|
||||
order Asc = ASC
|
||||
order Desc = DESC
|
||||
orderList = foldl' (\ r (o, e) -> [SQL.word e, order o] `SQL.sepBy` " " : r) [] odRev
|
||||
orders | null odRev = []
|
||||
| otherwise = [ORDER, BY, orderList `SQL.sepBy` ", "]
|
||||
|
||||
toSubQuery :: Relation r -> SubQuery
|
||||
toSubQuery = d where
|
||||
@ -72,10 +84,12 @@ toSubQuery = d where
|
||||
(composedSQL
|
||||
(projection rel)
|
||||
(product rel)
|
||||
(restriction rel))
|
||||
(restriction rel)
|
||||
(orderByRev rel)
|
||||
)
|
||||
(width rel)
|
||||
|
||||
finalizeRelation :: Projection r -> Product -> Maybe (Expr Bool) -> Relation r
|
||||
finalizeRelation :: Projection r -> Product -> Maybe (Expr Bool) -> [(Order, String)] -> Relation r
|
||||
finalizeRelation = Relation
|
||||
|
||||
toSQL :: Relation r -> String
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
|
||||
module Database.Relational.Query.Type (
|
||||
Query (untypeQuery), unsafeTypedQuery, toQuery
|
||||
Query (untypeQuery), unsafeTypedQuery, fromRelation
|
||||
) where
|
||||
|
||||
import Database.Relational.Query.Relation (Relation)
|
||||
@ -15,5 +15,5 @@ instance Show (Query p a) where
|
||||
show = untypeQuery
|
||||
|
||||
|
||||
toQuery :: Relation r -> Query p r
|
||||
toQuery = unsafeTypedQuery . Relation.toSQL
|
||||
fromRelation :: Relation r -> Query p r
|
||||
fromRelation = unsafeTypedQuery . Relation.toSQL
|
||||
|
||||
Loading…
Reference in New Issue
Block a user