mirror of
https://github.com/khibino/haskell-relational-record.git
synced 2025-01-08 14:26:33 +03:00
Add an arrow combinator module to import the idea of Opaleye.
This commit is contained in:
Kei Hibino
parent
b1cf7653d5
commit
1612424498
@ -22,6 +22,8 @@ extra-source-files: ChangeLog.md
|
||||
|
||||
library
|
||||
exposed-modules:
|
||||
Database.Relational.Query.Arrow
|
||||
|
||||
Database.Relational.Query
|
||||
Database.Relational.Query.Table
|
||||
Database.Relational.Query.SQL
|
||||
|
||||
424
relational-query/src/Database/Relational/Query/Arrow.hs
Normal file
424
relational-query/src/Database/Relational/Query/Arrow.hs
Normal file
@ -0,0 +1,424 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
|
||||
-- |
|
||||
-- Module : Database.Relational.Query.Arrow
|
||||
-- Copyright : 2015 Kei Hibino
|
||||
-- License : BSD3
|
||||
--
|
||||
-- Maintainer : ex8k.hibino@gmail.com
|
||||
-- Stability : experimental
|
||||
-- Portability : unknown
|
||||
--
|
||||
-- This module defines arrow version combinators which
|
||||
-- improves type-safty on building queries.
|
||||
-- Referencing the local projections may cause to break
|
||||
-- the result query.
|
||||
-- It is possible to controls injection of previous local projections
|
||||
-- by restricting domain type of arrow. This idea is imported from Opaleye.
|
||||
-- (https://github.com/tomjaguarpaw/haskell-opaleye,
|
||||
-- https://github.com/khibino/haskell-relational-record/issues/19).
|
||||
module Database.Relational.Query.Arrow (
|
||||
module Database.Relational.Query,
|
||||
|
||||
all', distinct,
|
||||
|
||||
query, queryMaybe, query', queryMaybe',
|
||||
queryList, queryList', queryExists, queryExists', queryListU, queryListU',
|
||||
queryScalar, queryScalar', queryScalarU, queryScalarU',
|
||||
|
||||
uniqueQuery', uniqueQueryMaybe',
|
||||
|
||||
on, wheres, having, groupBy, placeholder,
|
||||
|
||||
relation, relation', aggregateRelation, aggregateRelation',
|
||||
|
||||
uniqueRelation',
|
||||
|
||||
groupBy', key, key', set, bkey, rollup, cube, groupingSets,
|
||||
|
||||
orderBy, asc, desc,
|
||||
|
||||
partitionBy, over,
|
||||
|
||||
assign,
|
||||
|
||||
derivedUpdate', derivedUpdate,
|
||||
derivedDelete', derivedDelete,
|
||||
|
||||
QueryA,
|
||||
|
||||
QuerySimple, QueryAggregate, QueryUnique,
|
||||
|
||||
AggregatingSet, AggregatingSetList, AggregatingPowerSet,
|
||||
|
||||
Orderings, Window, Assignings,
|
||||
|
||||
UpdateTargetContext, RestrictionContext,
|
||||
) where
|
||||
|
||||
import Control.Category (Category)
|
||||
import Control.Arrow (Arrow, Kleisli (..))
|
||||
|
||||
import Database.Record
|
||||
import Database.Relational.Query hiding
|
||||
(all', distinct,
|
||||
query, queryMaybe, query', queryMaybe',
|
||||
queryList, queryList', queryScalar, queryScalar',
|
||||
uniqueQuery', uniqueQueryMaybe',
|
||||
on, wheres, having, groupBy, placeholder,
|
||||
relation, relation', aggregateRelation, aggregateRelation', uniqueRelation',
|
||||
groupBy', key, key', set, bkey, rollup, cube, groupingSets,
|
||||
orderBy, asc, desc, partitionBy, over,
|
||||
derivedUpdate', derivedUpdate, derivedDelete', derivedDelete,
|
||||
QuerySimple, QueryAggregate, QueryUnique, Window,
|
||||
UpdateTargetContext, RestrictionContext)
|
||||
import qualified Database.Relational.Query as Monadic
|
||||
import Database.Relational.Query.Monad.Class (MonadQualifyUnique)
|
||||
import Database.Relational.Query.Projection (ListProjection)
|
||||
import Database.Relational.Query.Monad.Trans.Aggregating (AggregateKey)
|
||||
import qualified Database.Relational.Query.Monad.Trans.Aggregating as Monadic
|
||||
import qualified Database.Relational.Query.Monad.Trans.Ordering as Monadic
|
||||
import qualified Database.Relational.Query.Monad.Trans.Assigning as Monadic
|
||||
|
||||
|
||||
-- | Arrow to build queries.
|
||||
newtype QueryA m a b = QueryA (Kleisli m a b) deriving (Category, Arrow)
|
||||
|
||||
queryA :: (a -> m b) -> QueryA m a b
|
||||
queryA = QueryA . Kleisli
|
||||
|
||||
runQueryA :: QueryA m a b -> a -> m b
|
||||
runQueryA (QueryA k) = runKleisli k
|
||||
|
||||
runAofM :: (m b -> c) -> QueryA m () b -> c
|
||||
runAofM = (. (`runQueryA` ()))
|
||||
|
||||
-- | Arrow type corresponding to 'Monadic.QuerySimple'
|
||||
type QuerySimple = QueryA Monadic.QuerySimple
|
||||
|
||||
-- | Arrow type corresponding to 'Monadic.QueryAggregate'
|
||||
type QueryAggregate = QueryA Monadic.QueryAggregate
|
||||
|
||||
-- | Arrow type corresponding to 'Monadic.QueryUnique'
|
||||
type QueryUnique = QueryA Monadic.QueryUnique
|
||||
|
||||
-- | Arrow type corresponding to 'Monadic.AggregatingSet'
|
||||
type AggregatingSet = QueryA Monadic.AggregatingSet
|
||||
|
||||
-- | Arrow type corresponding to 'Monadic.AggregatingSetList'
|
||||
type AggregatingSetList = QueryA Monadic.AggregatingSetList
|
||||
|
||||
-- | Arrow type corresponding to 'Monadic.AggregatingPowerSet'
|
||||
type AggregatingPowerSet = QueryA Monadic.AggregatingPowerSet
|
||||
|
||||
-- | Arrow type corresponding to 'Monadic.Orderings'
|
||||
type Orderings c m = QueryA (Monadic.Orderings c m)
|
||||
|
||||
-- | Arrow type corresponding to 'Monadic.Window'
|
||||
type Window c = QueryA (Monadic.Window c)
|
||||
|
||||
-- | Arrow type corresponding to 'Monadic.Assignings'
|
||||
type Assignings r m = QueryA (Monadic.Assignings r m)
|
||||
|
||||
-- | Arrow type corresponding to 'Monadic.UpdateTargetContext'
|
||||
type UpdateTargetContext p r = Assignings r Restrict (Projection Flat r) (PlaceHolders p)
|
||||
|
||||
-- | Arrow type corresponding to 'Monadic.RestrictionContext'
|
||||
type RestrictionContext p r = QueryA Monadic.Restrict (Projection Flat r) (PlaceHolders p)
|
||||
|
||||
|
||||
-- | Same as 'Monadic.all''. Arrow version.
|
||||
all' :: MonadQuery m => QueryA m () ()
|
||||
all' = queryA $ \() -> Monadic.all'
|
||||
|
||||
-- | Same as 'Monadic.distinct'. Arrow version.
|
||||
distinct :: MonadQuery m => QueryA m () ()
|
||||
distinct = queryA $ \() -> Monadic.distinct
|
||||
|
||||
-- | Same as 'Monadic.query'. Arrow version.
|
||||
-- The result arrow is not injected by local projections.
|
||||
query :: (MonadQualify ConfigureQuery m, MonadQuery m)
|
||||
=> Relation () r -> QueryA m () (Projection Flat r)
|
||||
query r = queryA $ \() -> Monadic.query r
|
||||
|
||||
-- | Same as 'Monadic.queryMaybe'. Arrow version.
|
||||
-- The result arrow is not injected by any local projections.
|
||||
queryMaybe :: (MonadQualify ConfigureQuery m, MonadQuery m)
|
||||
=> Relation () r -> QueryA m () (Projection Flat (Maybe r))
|
||||
queryMaybe r = queryA $ \() -> Monadic.queryMaybe r
|
||||
|
||||
-- | Same as 'Monadic.query''. Arrow version.
|
||||
-- The result arrow is not injected by any local projections.
|
||||
query' :: (MonadQualify ConfigureQuery m, MonadQuery m)
|
||||
=> Relation p r -> QueryA m () (PlaceHolders p, Projection Flat r)
|
||||
query' r = queryA $ \() -> Monadic.query' r
|
||||
|
||||
-- | Same as 'Monadic.queryMaybe''. Arrow version.
|
||||
-- The result arrow is not injected by any local projections.
|
||||
queryMaybe' :: (MonadQualify ConfigureQuery m, MonadQuery m)
|
||||
=> Relation p r -> QueryA m () (PlaceHolders p, Projection Flat (Maybe r))
|
||||
queryMaybe' r = queryA $ \() -> Monadic.queryMaybe' r
|
||||
|
||||
unsafeQueryList :: MonadQualify ConfigureQuery m
|
||||
=> (a -> Relation () r)
|
||||
-> QueryA m a (ListProjection (Projection c) r)
|
||||
unsafeQueryList rf = queryA $ Monadic.queryList . rf
|
||||
|
||||
unsafeQueryList' :: MonadQualify ConfigureQuery m
|
||||
=> (a -> Relation p r)
|
||||
-> QueryA m a (PlaceHolders p, ListProjection (Projection c) r)
|
||||
unsafeQueryList' rf = queryA $ Monadic.queryList' . rf
|
||||
|
||||
-- | Same as 'Monadic.queryList'. Arrow version.
|
||||
-- The result arrow is designed to be injected by local projections.
|
||||
queryList :: MonadQualify ConfigureQuery m
|
||||
=> (Projection c a -> Relation () r)
|
||||
-> QueryA m (Projection c a) (ListProjection (Projection c) r)
|
||||
queryList = unsafeQueryList
|
||||
|
||||
-- | Same as 'Monadic.queryList''. Arrow version.
|
||||
-- The result arrow is designed to be injected by local projections.
|
||||
queryList' :: MonadQualify ConfigureQuery m
|
||||
=> (Projection c a -> Relation p r)
|
||||
-> QueryA m (Projection c a) (PlaceHolders p, ListProjection (Projection c) r)
|
||||
queryList' = unsafeQueryList'
|
||||
|
||||
-- | Same as 'Monadic.queryList' to pass this result to 'exists' operator. Arrow version.
|
||||
-- The result arrow is designed to be injected by local projections.
|
||||
queryExists :: MonadQualify ConfigureQuery m
|
||||
=> (Projection c a -> Relation () r)
|
||||
-> QueryA m (Projection c a) (ListProjection (Projection Exists) r)
|
||||
queryExists = unsafeQueryList
|
||||
|
||||
-- | Same as 'Monadic.queryList'' to pass this result to 'exists' operator. Arrow version.
|
||||
-- The result arrow is designed to be injected by local projections.
|
||||
queryExists' :: MonadQualify ConfigureQuery m
|
||||
=> (Projection c a -> Relation p r)
|
||||
-> QueryA m (Projection c a) (PlaceHolders p, ListProjection (Projection Exists) r)
|
||||
queryExists' = unsafeQueryList'
|
||||
|
||||
-- | Same as 'Monadic.queryList'. Arrow version.
|
||||
-- Useful for no reference cases to local projections.
|
||||
queryListU :: MonadQualify ConfigureQuery m
|
||||
=> Relation () r
|
||||
-> QueryA m () (ListProjection (Projection c) r)
|
||||
queryListU r = unsafeQueryList $ \() -> r
|
||||
|
||||
-- | Same as 'Monadic.queryList''. Arrow version.
|
||||
-- Useful for no reference cases to local projections.
|
||||
queryListU' :: MonadQualify ConfigureQuery m
|
||||
=> Relation p r
|
||||
-> QueryA m () (PlaceHolders p, ListProjection (Projection c) r)
|
||||
queryListU' r = unsafeQueryList' $ \() -> r
|
||||
|
||||
unsafeQueryScalar :: (MonadQualify ConfigureQuery m, ScalarDegree r)
|
||||
=> (a -> UniqueRelation () c r)
|
||||
-> QueryA m a (Projection c (Maybe r))
|
||||
unsafeQueryScalar rf = queryA $ Monadic.queryScalar . rf
|
||||
|
||||
unsafeQueryScalar' :: (MonadQualify ConfigureQuery m, ScalarDegree r)
|
||||
=> (a -> UniqueRelation p c r)
|
||||
-> QueryA m a (PlaceHolders p, Projection c (Maybe r))
|
||||
unsafeQueryScalar' rf = queryA $ Monadic.queryScalar' . rf
|
||||
|
||||
-- | Same as 'Monadic.queryScalar'. Arrow version.
|
||||
-- The result arrow is designed to be injected by any local projection.
|
||||
queryScalar :: (MonadQualify ConfigureQuery m, ScalarDegree r)
|
||||
=> (Projection c a -> UniqueRelation () c r)
|
||||
-> QueryA m (Projection c a) (Projection c (Maybe r))
|
||||
queryScalar = unsafeQueryScalar
|
||||
|
||||
-- | Same as 'Monadic.queryScalar''. Arrow version.
|
||||
-- The result arrow is designed to be injected by any local projection.
|
||||
queryScalar' :: (MonadQualify ConfigureQuery m, ScalarDegree r)
|
||||
=> (Projection c a -> UniqueRelation p c r)
|
||||
-> QueryA m (Projection c a) (PlaceHolders p, Projection c (Maybe r))
|
||||
queryScalar' = unsafeQueryScalar'
|
||||
|
||||
-- | Same as 'Monadic.queryScalar'. Arrow version.
|
||||
-- Useful for no reference cases to local projections.
|
||||
queryScalarU :: (MonadQualify ConfigureQuery m, ScalarDegree r)
|
||||
=> UniqueRelation () c r
|
||||
-> QueryA m () (Projection c (Maybe r))
|
||||
queryScalarU r = unsafeQueryScalar $ \() -> r
|
||||
|
||||
-- | Same as 'Monadic.queryScalar''. Arrow version.
|
||||
-- Useful for no reference cases to local projections.
|
||||
queryScalarU' :: (MonadQualify ConfigureQuery m, ScalarDegree r)
|
||||
=> UniqueRelation p c r
|
||||
-> QueryA m () (PlaceHolders p, Projection c (Maybe r))
|
||||
queryScalarU' r = unsafeQueryScalar' $ \() -> r
|
||||
|
||||
-- | Same as 'Monadic.uniqueQuery''. Arrow version.
|
||||
-- The result arrow is not injected by local projections.
|
||||
uniqueQuery' :: MonadQualifyUnique ConfigureQuery m
|
||||
=> UniqueRelation p c r
|
||||
-> QueryA m () (PlaceHolders p, Projection c r)
|
||||
uniqueQuery' r = queryA $ \() -> Monadic.uniqueQuery' r
|
||||
|
||||
-- | Same as 'Monadic.uniqueQueryMaybe''. Arrow version.
|
||||
-- The result arrow is not injected by local projections.
|
||||
uniqueQueryMaybe' :: MonadQualifyUnique ConfigureQuery m
|
||||
=> UniqueRelation p c r
|
||||
-> QueryA m () (PlaceHolders p, Projection c (Maybe r))
|
||||
uniqueQueryMaybe' r = queryA $ \() -> Monadic.uniqueQueryMaybe' r
|
||||
|
||||
-- | Same as 'Monadic.on'. Arrow version.
|
||||
-- The result arrow is designed to be injected by local conditional flat-projections.
|
||||
on :: MonadQuery m
|
||||
=> QueryA m (Projection Flat (Maybe Bool)) ()
|
||||
on = queryA Monadic.on
|
||||
|
||||
-- | Same as 'Monadic.wheres'. Arrow version.
|
||||
-- The result arrow is designed to be injected by local conditional flat-projections.
|
||||
wheres :: MonadRestrict Flat m
|
||||
=> QueryA m (Projection Flat (Maybe Bool)) ()
|
||||
wheres = queryA Monadic.wheres
|
||||
|
||||
-- | Same as 'Monadic.having'. Arrow version.
|
||||
-- The result arrow is designed to be injected by local conditional aggregated-projections.
|
||||
having :: MonadRestrict Aggregated m
|
||||
=> QueryA m (Projection Aggregated (Maybe Bool)) ()
|
||||
having = queryA Monadic.having
|
||||
|
||||
-- | Same as 'Monadic.groupBy'. Arrow version.
|
||||
-- The result arrow is designed to be injected by local flat-projections.
|
||||
groupBy :: MonadAggregate m
|
||||
=> QueryA m (Projection Flat r) (Projection Aggregated r)
|
||||
groupBy = queryA Monadic.groupBy
|
||||
|
||||
-- | Same as 'Monadic.placeholder'. Arrow version.
|
||||
-- The result arrow is designed to be injected by locally built arrow using placeholders.
|
||||
placeholder :: (PersistableWidth t, SqlProjectable p, Monad m)
|
||||
=> QueryA m (QueryA m (p t) a) (PlaceHolders t, a)
|
||||
placeholder = queryA $ Monadic.placeholder . runQueryA
|
||||
|
||||
-- | Same as 'Monadic.relation'.
|
||||
-- Finalize query-building arrow instead of query-building monad.
|
||||
relation :: QuerySimple () (Projection Flat r)
|
||||
-> Relation () r
|
||||
relation = runAofM Monadic.relation
|
||||
|
||||
-- | Same as 'Monadic.relation''.
|
||||
-- Finalize query-building arrow instead of query-building monad.
|
||||
relation' :: QuerySimple () (PlaceHolders p, Projection Flat r)
|
||||
-> Relation p r
|
||||
relation' = runAofM Monadic.relation'
|
||||
|
||||
-- | Same as 'Monadic.aggregateRelation'.
|
||||
-- Finalize query-building arrow instead of query-building monad.
|
||||
aggregateRelation :: QueryAggregate () (Projection Aggregated r)
|
||||
-> Relation () r
|
||||
aggregateRelation = runAofM Monadic.aggregateRelation
|
||||
|
||||
-- | Same as 'Monadic.aggregateRelation''.
|
||||
-- Finalize query-building arrow instead of query-building monad.
|
||||
aggregateRelation' :: QueryAggregate () (PlaceHolders p, Projection Aggregated r)
|
||||
-> Relation p r
|
||||
aggregateRelation' = runAofM Monadic.aggregateRelation'
|
||||
|
||||
-- | Same as 'Monadic.uniqueRelation''.
|
||||
-- Finalize query-building arrow instead of query-building monad.
|
||||
uniqueRelation' :: QueryUnique () (PlaceHolders p, Projection c r)
|
||||
-> UniqueRelation p c r
|
||||
uniqueRelation' = runAofM Monadic.uniqueRelation'
|
||||
|
||||
-- | Same as 'Monadic.groupBy''.
|
||||
-- This arrow is designed to be injected by local 'AggregateKey'.
|
||||
groupBy' :: MonadAggregate m => QueryA m (AggregateKey a) a
|
||||
groupBy' = queryA Monadic.groupBy'
|
||||
|
||||
-- | Same as 'Monadic.key'.
|
||||
-- This arrow is designed to be injected by local flat-projections.
|
||||
key :: AggregatingSet (Projection Flat r) (Projection Aggregated (Maybe r))
|
||||
key = queryA Monadic.key
|
||||
|
||||
-- | Same as 'Monadic.key''.
|
||||
-- This arrow is designed to be injected by local 'AggregteKey'.
|
||||
key' :: AggregatingSet (AggregateKey a) a
|
||||
key' = queryA Monadic.key'
|
||||
|
||||
-- | Same as 'Monadic.set'.
|
||||
-- This arrow is designed to be injected by locally built 'AggregtingSet' arrow.
|
||||
set :: AggregatingSetList (AggregatingSet () a) a
|
||||
set = queryA $ runAofM Monadic.set
|
||||
|
||||
-- | Same as 'Monadic.bkey'.
|
||||
-- This arrow is designed to be injected by local flat-projections.
|
||||
bkey :: AggregatingPowerSet (Projection Flat r) (Projection Aggregated (Maybe r))
|
||||
bkey = queryA Monadic.bkey
|
||||
|
||||
-- | Same as 'Monadic.rollup'.
|
||||
-- Finalize locally built 'AggregatingPowerSet'.
|
||||
rollup :: AggregatingPowerSet () a -> AggregateKey a
|
||||
rollup = runAofM Monadic.rollup
|
||||
|
||||
-- | Same as 'Monadic.cube'.
|
||||
-- Finalize locally built 'AggregatingPowerSet'.
|
||||
cube :: AggregatingPowerSet () a -> AggregateKey a
|
||||
cube = runAofM Monadic.cube
|
||||
|
||||
-- | Same as 'Monadic.groupingSets'.
|
||||
-- Finalize locally built 'AggregatingSetList'.
|
||||
groupingSets :: AggregatingSetList () a -> AggregateKey a
|
||||
groupingSets = runAofM Monadic.groupingSets
|
||||
|
||||
-- | Same as 'Monadic.orderBy'.
|
||||
-- The result arrow is designed to be injected by local projections.
|
||||
orderBy :: Monad m
|
||||
=> Order
|
||||
-> Orderings c m (Projection c t) ()
|
||||
orderBy o = queryA (`Monadic.orderBy` o)
|
||||
|
||||
-- | Same as 'Monadic.asc'.
|
||||
-- The result arrow is designed to be injected by local projections.
|
||||
asc :: Monad m
|
||||
=> Orderings c m (Projection c t) ()
|
||||
asc = queryA Monadic.asc
|
||||
|
||||
-- | Same as 'Monadic.desc'.
|
||||
-- The result arrow is designed to be injected by local projections.
|
||||
desc :: Monad m
|
||||
=> Orderings c m (Projection c t) ()
|
||||
desc = queryA Monadic.desc
|
||||
|
||||
-- | Same as 'Monadic.partitionBy'.
|
||||
-- The result arrow is designed to be injected by local projections.
|
||||
partitionBy :: Window c (Projection c r) ()
|
||||
partitionBy = queryA Monadic.partitionBy
|
||||
|
||||
-- | Same as 'Monadic.over'.
|
||||
-- Make window function result projection using built 'Window' arrow.
|
||||
over :: SqlProjectable (Projection c)
|
||||
=> Projection OverWindow a -> Window c () () -> Projection c a
|
||||
over po = runAofM $ Monadic.over po
|
||||
|
||||
infix 8 `over`
|
||||
|
||||
-- | Make 'Monadic.AssignTarget' into arrow which is designed to be
|
||||
-- injected by local projection assignees.
|
||||
assign :: Monad m
|
||||
=> Monadic.AssignTarget r v
|
||||
-> Assignings r m (Projection Flat v) ()
|
||||
assign t = queryA (`Monadic.assignTo` t)
|
||||
|
||||
-- | Same as 'Monadic.derivedUpdate''.
|
||||
-- Make 'Update' from assigning statement arrow using configuration.
|
||||
derivedUpdate' :: TableDerivable r => Config -> UpdateTargetContext p r -> Update p
|
||||
derivedUpdate' config = Monadic.derivedUpdate' config . runQueryA
|
||||
|
||||
-- | Same as 'Monadic.derivedUpdate'.
|
||||
-- Make 'Update' from assigning statement arrow.
|
||||
derivedUpdate :: TableDerivable r => UpdateTargetContext p r -> Update p
|
||||
derivedUpdate = Monadic.derivedUpdate . runQueryA
|
||||
|
||||
-- | Same as 'Monadic.derivedDelete''.
|
||||
-- Make 'Update' from restrict statement arrow using configuration.
|
||||
derivedDelete' :: TableDerivable r => Config -> RestrictionContext p r -> Delete p
|
||||
derivedDelete' config = Monadic.derivedDelete' config . runQueryA
|
||||
|
||||
-- | Same as 'Monadic.derivedDelete'.
|
||||
-- Make 'Update' from restrict statement arrow.
|
||||
derivedDelete :: TableDerivable r => RestrictionContext p r -> Delete p
|
||||
derivedDelete = Monadic.derivedDelete . runQueryA
|
||||
Loading…
Reference in New Issue
Block a user