mirror of
https://github.com/circuithub/rel8.git
synced 2024-10-05 21:29:35 +03:00
WIP
This commit is contained in:
Oliver Charles
parent
064001d67b
commit
3890b86bda
@ -14,7 +14,7 @@
|
||||
{-# language UndecidableInstances #-}
|
||||
{-# language UndecidableSuperClasses #-}
|
||||
|
||||
module Rel8.MaybeTable ( HoldsUnderMaybe, MaybeTable(..), toMaybe ) where
|
||||
module Rel8.MaybeTable where
|
||||
|
||||
import Data.Functor.Identity
|
||||
import Data.Proxy
|
||||
@ -27,73 +27,72 @@ outer join fails to match any rows, this is essentialy @Nothing@, and if the
|
||||
outer join does match rows, this is like @Just@.
|
||||
|
||||
-}
|
||||
data MaybeTable f t where
|
||||
data MaybeTable t where
|
||||
MaybeTable
|
||||
:: Context t ~ Null f
|
||||
=> { -- | Check if this @MaybeTable@ is null. In other words, check if an outer
|
||||
:: { -- | Check if this @MaybeTable@ is null. In other words, check if an outer
|
||||
-- join matched any rows.
|
||||
isNullTable :: Column f Bool
|
||||
, maybeTable :: t
|
||||
isNullTable :: Column ( Context t ) Bool
|
||||
, maybeTable :: MapContext Null t
|
||||
}
|
||||
-> MaybeTable f t
|
||||
-> MaybeTable t
|
||||
|
||||
|
||||
data MaybeTableField ( f :: * -> * ) t a where
|
||||
MaybeTableIsNull :: MaybeTableField f t Bool
|
||||
MaybeTableField :: Field t a -> MaybeTableField f t ( Maybe a )
|
||||
-- data MaybeTableField ( f :: * -> * ) t a where
|
||||
-- MaybeTableIsNull :: MaybeTableField f t Bool
|
||||
-- MaybeTableField :: Field t a -> MaybeTableField f t ( Maybe a )
|
||||
|
||||
|
||||
instance ( f ~ u, g ~ v, Compatible t ( Null f ) s ( Null g ) ) => Compatible ( MaybeTable f t ) u ( MaybeTable g s ) v where
|
||||
transferField MaybeTableIsNull = MaybeTableIsNull
|
||||
transferField ( MaybeTableField f ) = MaybeTableField ( transferField f )
|
||||
-- instance ( f ~ u, g ~ v, Compatible t ( Null f ) s ( Null g ) ) => Compatible ( MaybeTable f t ) u ( MaybeTable g s ) v where
|
||||
-- transferField MaybeTableIsNull = MaybeTableIsNull
|
||||
-- transferField ( MaybeTableField f ) = MaybeTableField ( transferField f )
|
||||
|
||||
|
||||
class c ( Maybe x ) => HoldsUnderMaybe c x
|
||||
-- class c ( Maybe x ) => HoldsUnderMaybe c x
|
||||
|
||||
|
||||
instance c ( Maybe x ) => HoldsUnderMaybe c x
|
||||
-- instance c ( Maybe x ) => HoldsUnderMaybe c x
|
||||
|
||||
|
||||
instance ( ConstrainTable t ( HoldsUnderMaybe Unconstrained ), Context t ~ Null f, Table t ) => Table ( MaybeTable f t ) where
|
||||
type Field ( MaybeTable f t ) =
|
||||
MaybeTableField f t
|
||||
-- instance ( ConstrainTable t ( HoldsUnderMaybe Unconstrained ), Context t ~ Null f, Table t ) => Table ( MaybeTable f t ) where
|
||||
-- type Field ( MaybeTable f t ) =
|
||||
-- MaybeTableField f t
|
||||
|
||||
type ConstrainTable ( MaybeTable f t ) c =
|
||||
( c Bool, ConstrainTable t ( HoldsUnderMaybe c ) )
|
||||
-- type ConstrainTable ( MaybeTable f t ) c =
|
||||
-- ( c Bool, ConstrainTable t ( HoldsUnderMaybe c ) )
|
||||
|
||||
type Context ( MaybeTable f t ) =
|
||||
f
|
||||
-- type Context ( MaybeTable f t ) =
|
||||
-- f
|
||||
|
||||
field MaybeTable{ isNullTable, maybeTable } = \case
|
||||
MaybeTableIsNull ->
|
||||
MkC isNullTable
|
||||
-- field MaybeTable{ isNullTable, maybeTable } = \case
|
||||
-- MaybeTableIsNull ->
|
||||
-- MkC isNullTable
|
||||
|
||||
MaybeTableField i ->
|
||||
castC ( field maybeTable i )
|
||||
-- MaybeTableField i ->
|
||||
-- castC ( field maybeTable i )
|
||||
|
||||
tabulateMCP
|
||||
:: forall proxy c m
|
||||
. ( Applicative m, ConstrainTable ( MaybeTable f t ) c )
|
||||
=> proxy c
|
||||
-> ( forall x. c x => Field ( MaybeTable f t ) x -> m ( C f x ) )
|
||||
-> m ( MaybeTable f t )
|
||||
tabulateMCP _ f =
|
||||
MaybeTable
|
||||
<$> do toColumn <$> f MaybeTableIsNull
|
||||
<*> tabulateMCP
|
||||
( Proxy @( HoldsUnderMaybe c ) )
|
||||
( fmap castC . f . MaybeTableField )
|
||||
-- tabulateMCP
|
||||
-- :: forall proxy c m
|
||||
-- . ( Applicative m, ConstrainTable ( MaybeTable f t ) c )
|
||||
-- => proxy c
|
||||
-- -> ( forall x. c x => Field ( MaybeTable f t ) x -> m ( C f x ) )
|
||||
-- -> m ( MaybeTable f t )
|
||||
-- tabulateMCP _ f =
|
||||
-- MaybeTable
|
||||
-- <$> do toColumn <$> f MaybeTableIsNull
|
||||
-- <*> tabulateMCP
|
||||
-- ( Proxy @( HoldsUnderMaybe c ) )
|
||||
-- ( fmap castC . f . MaybeTableField )
|
||||
|
||||
|
||||
-- | If you 'Rel8.Query.select' a @MaybeTable@, you'll get back a @MaybeTable@
|
||||
-- as a result. However, this structure is awkward to use in ordinary Haskell,
|
||||
-- as it's a normal record where all of the fields are wrapped in 'Nothing'.
|
||||
-- 'toMaybe' lets you transform a @MaybeTable@ into a normal @Maybe@ value.
|
||||
toMaybe
|
||||
:: ( CompatibleTables null notNull
|
||||
, Compatible notNull Identity null ( Null Identity )
|
||||
)
|
||||
=> MaybeTable Identity null -> Maybe notNull
|
||||
toMaybe MaybeTable{ isNullTable, maybeTable }
|
||||
| isNullTable = Nothing
|
||||
| otherwise = traverseTable sequenceC maybeTable
|
||||
-- -- | If you 'Rel8.Query.select' a @MaybeTable@, you'll get back a @MaybeTable@
|
||||
-- -- as a result. However, this structure is awkward to use in ordinary Haskell,
|
||||
-- -- as it's a normal record where all of the fields are wrapped in 'Nothing'.
|
||||
-- -- 'toMaybe' lets you transform a @MaybeTable@ into a normal @Maybe@ value.
|
||||
-- toMaybe
|
||||
-- :: ( CompatibleTables null notNull
|
||||
-- , Compatible notNull Identity null ( Null Identity )
|
||||
-- )
|
||||
-- => MaybeTable Identity null -> Maybe notNull
|
||||
-- toMaybe MaybeTable{ isNullTable, maybeTable }
|
||||
-- | isNullTable = Nothing
|
||||
-- | otherwise = traverseTable sequenceC maybeTable
|
||||
|
||||
@ -62,12 +62,12 @@ instance MonadQuery m => MonadQuery ( Nest m ) where
|
||||
toOpaleye m
|
||||
|
||||
|
||||
-- | Exists checks if a query returns at least one row.
|
||||
--
|
||||
-- @exists q@ is the same as the SQL expression @EXISTS ( q )@
|
||||
exists :: MonadQuery m => m a -> m ( Expr m Bool )
|
||||
exists query =
|
||||
liftOpaleye ( lit True <$ Opaleye.restrictExists ( toOpaleye query ) )
|
||||
-- -- | Exists checks if a query returns at least one row.
|
||||
-- --
|
||||
-- -- @exists q@ is the same as the SQL expression @EXISTS ( q )@
|
||||
-- exists :: MonadQuery m => m a -> m ( Expr m Bool )
|
||||
-- exists query =
|
||||
-- liftOpaleye ( lit True <$ Opaleye.restrictExists ( toOpaleye query ) )
|
||||
|
||||
|
||||
-- | Select each row from a table definition.
|
||||
@ -95,7 +95,8 @@ each_forAll schema =
|
||||
unpackspec :: Opaleye.Unpackspec row row
|
||||
unpackspec =
|
||||
Opaleye.Unpackspec
|
||||
$ Opaleye.PackMap \f -> traverseTable ( traverseC ( traversePrimExpr f ) )
|
||||
$ Opaleye.PackMap \f ->
|
||||
traverseTable @Id ( traverseC ( traversePrimExpr f ) )
|
||||
|
||||
|
||||
writer :: Opaleye.Writer () row
|
||||
@ -107,6 +108,7 @@ each_forAll schema =
|
||||
view =
|
||||
Opaleye.View
|
||||
( mapTable
|
||||
@( From m )
|
||||
( mapC ( column . columnName ) )
|
||||
( tableColumns schema )
|
||||
)
|
||||
@ -120,26 +122,31 @@ each_forAll schema =
|
||||
leftJoin
|
||||
:: ( MonadQuery m
|
||||
, Promote m outer outer'
|
||||
, Compatible outer ( Expr m ) nullOuter ( Null ( Expr m ) )
|
||||
, Table nullOuter
|
||||
, Compatible nullOuter ( Null ( Expr m ) ) outer ( Expr m )
|
||||
, Recontextualise outer Null
|
||||
, ConstrainTable ( MapContext Null outer ) Unconstrained
|
||||
, Context ( MapContext Null outer ) ~ Null ( Expr m )
|
||||
, MapContext Demote outer' ~ outer
|
||||
, Recontextualise outer' Demote
|
||||
)
|
||||
=> Nest m outer'
|
||||
-> ( outer -> Expr m Bool )
|
||||
-> m ( MaybeTable ( Expr m ) nullOuter )
|
||||
-> m ( MaybeTable outer )
|
||||
leftJoin = leftJoin_forAll
|
||||
|
||||
leftJoin_forAll
|
||||
:: forall outer nullOuter outer' m
|
||||
:: forall outer outer' nullOuter m
|
||||
. ( MonadQuery m
|
||||
, Promote m outer outer'
|
||||
, Compatible outer ( Expr m ) nullOuter ( Null ( Expr m ) )
|
||||
, Table nullOuter
|
||||
, Compatible nullOuter ( Null ( Expr m ) ) outer ( Expr m )
|
||||
, ConstrainTable ( MapContext Null outer ) Unconstrained
|
||||
, Recontextualise outer Null
|
||||
, MapContext Null outer ~ nullOuter
|
||||
, Context nullOuter ~ Null ( Context outer )
|
||||
, MapContext Demote outer' ~ outer
|
||||
, Recontextualise outer' Demote
|
||||
)
|
||||
=> Nest m outer'
|
||||
-> ( outer -> Expr m Bool )
|
||||
-> m ( MaybeTable ( Expr m ) nullOuter )
|
||||
-> m ( MaybeTable outer )
|
||||
leftJoin_forAll joinTable condition =
|
||||
liftOpaleye $ Opaleye.QueryArr \( (), left, t ) ->
|
||||
let
|
||||
@ -161,8 +168,10 @@ leftJoin_forAll joinTable condition =
|
||||
)
|
||||
|
||||
in ( MaybeTable
|
||||
{ isNullTable = tag
|
||||
, maybeTable = mapTable ( mapC liftNull ) renamed
|
||||
{ isNullTable =
|
||||
tag
|
||||
, maybeTable =
|
||||
mapTable @Null recontextualiseColumn renamed
|
||||
}
|
||||
, Opaleye.Join
|
||||
Opaleye.LeftJoin
|
||||
@ -183,93 +192,93 @@ leftJoin_forAll joinTable condition =
|
||||
f ( toPrimExpr tag )
|
||||
|
||||
outer <-
|
||||
traverseTable
|
||||
traverseTable @Demote
|
||||
( traverseC ( fmap demote . traversePrimExpr f ) )
|
||||
outer'
|
||||
|
||||
return ( fromPrimExpr tag', outer )
|
||||
|
||||
|
||||
-- | Combine the results of two queries of the same type.
|
||||
--
|
||||
-- @union a b@ is the same as the SQL statement @x UNION b@.
|
||||
union
|
||||
:: ( MonadQuery m, Promote m a a' )
|
||||
=> Nest m a' -> Nest m a' -> m a
|
||||
union = union_forAll
|
||||
-- -- | Combine the results of two queries of the same type.
|
||||
-- --
|
||||
-- -- @union a b@ is the same as the SQL statement @x UNION b@.
|
||||
-- union
|
||||
-- :: ( MonadQuery m, Promote m a a' )
|
||||
-- => Nest m a' -> Nest m a' -> m a
|
||||
-- union = union_forAll
|
||||
|
||||
|
||||
union_forAll
|
||||
:: forall a' a m
|
||||
. ( MonadQuery m
|
||||
, Promote m a a'
|
||||
)
|
||||
=> Nest m a' -> Nest m a' -> m a
|
||||
union_forAll l r =
|
||||
liftOpaleye
|
||||
( Opaleye.unionExplicit
|
||||
binaryspec
|
||||
( toOpaleye ( mapTable ( mapC demote ) <$> l ) )
|
||||
( toOpaleye ( mapTable ( mapC demote ) <$> r ) )
|
||||
)
|
||||
-- union_forAll
|
||||
-- :: forall a' a m
|
||||
-- . ( MonadQuery m
|
||||
-- , Promote m a a'
|
||||
-- )
|
||||
-- => Nest m a' -> Nest m a' -> m a
|
||||
-- union_forAll l r =
|
||||
-- liftOpaleye
|
||||
-- ( Opaleye.unionExplicit
|
||||
-- binaryspec
|
||||
-- ( toOpaleye ( mapTable ( mapC demote ) <$> l ) )
|
||||
-- ( toOpaleye ( mapTable ( mapC demote ) <$> r ) )
|
||||
-- )
|
||||
|
||||
where
|
||||
-- where
|
||||
|
||||
binaryspec :: Opaleye.Binaryspec a a
|
||||
binaryspec =
|
||||
Opaleye.Binaryspec $ Opaleye.PackMap \f ( a, b ) ->
|
||||
zipTablesWithM
|
||||
( zipCWithM \x y -> fromPrimExpr <$> f ( toPrimExpr x, toPrimExpr y ) )
|
||||
a
|
||||
b
|
||||
-- binaryspec :: Opaleye.Binaryspec a a
|
||||
-- binaryspec =
|
||||
-- Opaleye.Binaryspec $ Opaleye.PackMap \f ( a, b ) ->
|
||||
-- zipTablesWithM
|
||||
-- ( zipCWithM \x y -> fromPrimExpr <$> f ( toPrimExpr x, toPrimExpr y ) )
|
||||
-- a
|
||||
-- b
|
||||
|
||||
|
||||
-- | Select all distinct rows from a query, removing duplicates.
|
||||
--
|
||||
-- @distinct q@ is equivalent to the SQL statement @SELECT DISTINCT q@
|
||||
distinct :: ( MonadQuery m, a `IsTableIn` m ) => m a -> m a
|
||||
distinct = distinct_forAll
|
||||
-- -- | Select all distinct rows from a query, removing duplicates.
|
||||
-- --
|
||||
-- -- @distinct q@ is equivalent to the SQL statement @SELECT DISTINCT q@
|
||||
-- distinct :: ( MonadQuery m, a `IsTableIn` m ) => m a -> m a
|
||||
-- distinct = distinct_forAll
|
||||
|
||||
|
||||
distinct_forAll
|
||||
:: forall a m
|
||||
. ( MonadQuery m, a `IsTableIn` m )
|
||||
=> m a -> m a
|
||||
distinct_forAll query =
|
||||
liftOpaleye ( Opaleye.distinctExplicit distinctspec ( toOpaleye query ) )
|
||||
-- distinct_forAll
|
||||
-- :: forall a m
|
||||
-- . ( MonadQuery m, a `IsTableIn` m )
|
||||
-- => m a -> m a
|
||||
-- distinct_forAll query =
|
||||
-- liftOpaleye ( Opaleye.distinctExplicit distinctspec ( toOpaleye query ) )
|
||||
|
||||
where
|
||||
-- where
|
||||
|
||||
distinctspec :: Opaleye.Distinctspec a a
|
||||
distinctspec =
|
||||
Opaleye.Distinctspec $ Opaleye.Aggregator $ Opaleye.PackMap \f a ->
|
||||
traverseTable
|
||||
( traverseC \x -> fromPrimExpr <$> f ( Nothing, toPrimExpr x ) )
|
||||
a
|
||||
-- distinctspec :: Opaleye.Distinctspec a a
|
||||
-- distinctspec =
|
||||
-- Opaleye.Distinctspec $ Opaleye.Aggregator $ Opaleye.PackMap \f a ->
|
||||
-- traverseTable
|
||||
-- ( traverseC \x -> fromPrimExpr <$> f ( Nothing, toPrimExpr x ) )
|
||||
-- a
|
||||
|
||||
|
||||
-- | @limit n@ select at most @n@ rows from a query.
|
||||
--
|
||||
-- @limit n@ is equivalent to the SQL @LIMIT n@.
|
||||
limit :: MonadQuery m => Natural -> m a -> m a
|
||||
limit n query =
|
||||
liftOpaleye
|
||||
( Opaleye.limit
|
||||
( fromIntegral n )
|
||||
( toOpaleye query )
|
||||
)
|
||||
-- -- | @limit n@ select at most @n@ rows from a query.
|
||||
-- --
|
||||
-- -- @limit n@ is equivalent to the SQL @LIMIT n@.
|
||||
-- limit :: MonadQuery m => Natural -> m a -> m a
|
||||
-- limit n query =
|
||||
-- liftOpaleye
|
||||
-- ( Opaleye.limit
|
||||
-- ( fromIntegral n )
|
||||
-- ( toOpaleye query )
|
||||
-- )
|
||||
|
||||
|
||||
-- | @offset n@ drops the first @n@ rows from a query.
|
||||
--
|
||||
-- @offset n@ is equivalent to the SQL @OFFSET n@.
|
||||
offset :: MonadQuery m => Natural -> m a -> m a
|
||||
offset n query =
|
||||
liftOpaleye
|
||||
( Opaleye.offset
|
||||
( fromIntegral n )
|
||||
( toOpaleye query )
|
||||
)
|
||||
-- -- | @offset n@ drops the first @n@ rows from a query.
|
||||
-- --
|
||||
-- -- @offset n@ is equivalent to the SQL @OFFSET n@.
|
||||
-- offset :: MonadQuery m => Natural -> m a -> m a
|
||||
-- offset n query =
|
||||
-- liftOpaleye
|
||||
-- ( Opaleye.offset
|
||||
-- ( fromIntegral n )
|
||||
-- ( toOpaleye query )
|
||||
-- )
|
||||
|
||||
|
||||
-- | Drop any rows that don't match a predicate.
|
||||
@ -281,27 +290,27 @@ where_ x =
|
||||
( (), Opaleye.restrict ( toPrimExpr x ) left, t )
|
||||
|
||||
|
||||
filterMap
|
||||
:: forall a nullA b nullB m
|
||||
. ( Compatible nullA ( Null ( Expr m ) ) a ( Expr m )
|
||||
, Compatible b ( Expr m ) nullB ( Null ( Expr m ) )
|
||||
, Table a, Table b, Context a ~ Context b
|
||||
, Table nullA, Table nullB, Context nullA ~ Context nullB
|
||||
, MonadQuery m
|
||||
)
|
||||
=> ( nullA -> nullB ) -> m a -> m b
|
||||
filterMap f q = do
|
||||
x <-
|
||||
q
|
||||
-- filterMap
|
||||
-- :: forall a nullA b nullB m
|
||||
-- . ( Compatible nullA ( Null ( Expr m ) ) a ( Expr m )
|
||||
-- , Compatible b ( Expr m ) nullB ( Null ( Expr m ) )
|
||||
-- , Table a, Table b, Context a ~ Context b
|
||||
-- , Table nullA, Table nullB, Context nullA ~ Context nullB
|
||||
-- , MonadQuery m
|
||||
-- )
|
||||
-- => ( nullA -> nullB ) -> m a -> m b
|
||||
-- filterMap f q = do
|
||||
-- x <-
|
||||
-- q
|
||||
|
||||
let
|
||||
y =
|
||||
f ( mapTable ( mapC liftNull ) x )
|
||||
-- let
|
||||
-- y =
|
||||
-- f ( mapTable ( mapC liftNull ) x )
|
||||
|
||||
allNotNull :: [ Expr m Bool ]
|
||||
allNotNull =
|
||||
getConst ( traverseTable @nullB ( traverseC ( \expr -> Const [ isNull expr ] ) ) y )
|
||||
-- allNotNull :: [ Expr m Bool ]
|
||||
-- allNotNull =
|
||||
-- getConst ( traverseTable @nullB ( traverseC ( \expr -> Const [ isNull expr ] ) ) y )
|
||||
|
||||
where_ ( and_ allNotNull )
|
||||
-- where_ ( and_ allNotNull )
|
||||
|
||||
return ( mapTable ( mapC retype ) y )
|
||||
-- return ( mapTable ( mapC retype ) y )
|
||||
|
||||
@ -14,6 +14,7 @@ module Rel8.Query where
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Functor.Identity
|
||||
import Data.Int
|
||||
import Data.String ( fromString )
|
||||
import qualified Database.PostgreSQL.Simple
|
||||
@ -68,14 +69,14 @@ instance MonadQuery Query where
|
||||
|
||||
-- | Run a @SELECT@ query, returning all rows.
|
||||
select
|
||||
:: ( Compatible row ( Expr Query ) row ( Expr Query ), FromRow row haskell, MonadIO m )
|
||||
:: ( FromRow row haskell, MonadIO m, Recontextualise row Id )
|
||||
=> Connection -> Query row -> m [ haskell ]
|
||||
select = select_forAll
|
||||
|
||||
|
||||
select_forAll
|
||||
:: forall row haskell m
|
||||
. ( Compatible row ( Expr Query ) row ( Expr Query ), FromRow row haskell, MonadIO m )
|
||||
. ( FromRow row haskell, MonadIO m, Recontextualise row Id )
|
||||
=> Connection -> Query row -> m [ haskell ]
|
||||
select_forAll conn query =
|
||||
maybe
|
||||
@ -83,10 +84,9 @@ select_forAll conn query =
|
||||
( liftIO . Database.PostgreSQL.Simple.queryWith_ ( queryParser query ) conn . fromString )
|
||||
( selectQuery query )
|
||||
|
||||
where
|
||||
|
||||
queryParser
|
||||
:: FromRow sql haskell
|
||||
:: ( FromRow sql haskell, Recontextualise sql Id )
|
||||
=> Query sql
|
||||
-> Database.PostgreSQL.Simple.RowParser haskell
|
||||
queryParser ( Query q ) =
|
||||
@ -100,153 +100,155 @@ queryParser ( Query q ) =
|
||||
|
||||
queryRunner
|
||||
:: forall row haskell
|
||||
. ( Compatible row ( Expr Query ) row ( Expr Query ), FromRow row haskell )
|
||||
. ( FromRow row haskell, Recontextualise row Id )
|
||||
=> Opaleye.FromFields row haskell
|
||||
queryRunner =
|
||||
Opaleye.QueryRunner ( void unpackspec ) rowParser ( const True )
|
||||
|
||||
|
||||
unpackspec :: ( Context row ~ Expr Query, Table row ) => Opaleye.Unpackspec row row
|
||||
unpackspec
|
||||
:: ( Table row, Context row ~ Expr Query, Recontextualise row Id )
|
||||
=> Opaleye.Unpackspec row row
|
||||
unpackspec =
|
||||
Opaleye.Unpackspec $ Opaleye.PackMap \f ->
|
||||
traverseTable ( traverseC ( traversePrimExpr f ) )
|
||||
traverseTable @Id ( traverseC ( traversePrimExpr f ) )
|
||||
|
||||
|
||||
-- | Run an @INSERT@ statement
|
||||
insert :: MonadIO m => Connection -> Insert result -> m result
|
||||
insert connection Insert{ into, values, onConflict, returning } =
|
||||
liftIO
|
||||
( Opaleye.runInsert_
|
||||
connection
|
||||
( toOpaleyeInsert into values returning )
|
||||
)
|
||||
-- -- | Run an @INSERT@ statement
|
||||
-- insert :: MonadIO m => Connection -> Insert result -> m result
|
||||
-- insert connection Insert{ into, values, onConflict, returning } =
|
||||
-- liftIO
|
||||
-- ( Opaleye.runInsert_
|
||||
-- connection
|
||||
-- ( toOpaleyeInsert into values returning )
|
||||
-- )
|
||||
|
||||
where
|
||||
-- where
|
||||
|
||||
toOpaleyeInsert
|
||||
:: forall schema result value
|
||||
. ( Context value ~ Expr Query
|
||||
, CompatibleTables schema value
|
||||
, Context schema ~ ColumnSchema
|
||||
)
|
||||
=> TableSchema schema
|
||||
-> [ value ]
|
||||
-> Returning schema result
|
||||
-> Opaleye.Insert result
|
||||
toOpaleyeInsert into_ iRows returning_ =
|
||||
Opaleye.Insert
|
||||
{ iTable = ddlTable into_ ( writer into_ )
|
||||
, iRows
|
||||
, iReturning = opaleyeReturning returning_
|
||||
, iOnConflict
|
||||
}
|
||||
-- toOpaleyeInsert
|
||||
-- :: forall schema result value
|
||||
-- . ( Context value ~ Expr Query
|
||||
-- , CompatibleTables schema value
|
||||
-- , Context schema ~ ColumnSchema
|
||||
-- )
|
||||
-- => TableSchema schema
|
||||
-- -> [ value ]
|
||||
-- -> Returning schema result
|
||||
-- -> Opaleye.Insert result
|
||||
-- toOpaleyeInsert into_ iRows returning_ =
|
||||
-- Opaleye.Insert
|
||||
-- { iTable = ddlTable into_ ( writer into_ )
|
||||
-- , iRows
|
||||
-- , iReturning = opaleyeReturning returning_
|
||||
-- , iOnConflict
|
||||
-- }
|
||||
|
||||
where
|
||||
-- where
|
||||
|
||||
iOnConflict :: Maybe Opaleye.OnConflict
|
||||
iOnConflict =
|
||||
case onConflict of
|
||||
DoNothing ->
|
||||
Just Opaleye.DoNothing
|
||||
-- iOnConflict :: Maybe Opaleye.OnConflict
|
||||
-- iOnConflict =
|
||||
-- case onConflict of
|
||||
-- DoNothing ->
|
||||
-- Just Opaleye.DoNothing
|
||||
|
||||
Abort ->
|
||||
Nothing
|
||||
-- Abort ->
|
||||
-- Nothing
|
||||
|
||||
|
||||
writer
|
||||
:: forall value schema
|
||||
. ( CompatibleTables schema value
|
||||
, Context value ~ Expr Query
|
||||
, Context schema ~ ColumnSchema
|
||||
)
|
||||
=> TableSchema schema -> Opaleye.Writer value schema
|
||||
writer into_ =
|
||||
let
|
||||
go
|
||||
:: forall f list
|
||||
. ( Functor list, Applicative f )
|
||||
=> ( ( list Opaleye.PrimExpr, String ) -> f () )
|
||||
-> list value
|
||||
-> f ()
|
||||
go f xs =
|
||||
void
|
||||
( traverseTableWithIndexC
|
||||
@Unconstrained
|
||||
@schema
|
||||
@schema
|
||||
( \i ->
|
||||
traverseC \c@ColumnSchema{ columnName } ->
|
||||
c <$ f ( toPrimExpr . toColumn . flip field ( transferField i ) <$> xs, columnName )
|
||||
)
|
||||
( tableColumns into_ )
|
||||
)
|
||||
-- writer
|
||||
-- :: forall value schema
|
||||
-- . ( CompatibleTables schema value
|
||||
-- , Context value ~ Expr Query
|
||||
-- , Context schema ~ ColumnSchema
|
||||
-- )
|
||||
-- => TableSchema schema -> Opaleye.Writer value schema
|
||||
-- writer into_ =
|
||||
-- let
|
||||
-- go
|
||||
-- :: forall f list
|
||||
-- . ( Functor list, Applicative f )
|
||||
-- => ( ( list Opaleye.PrimExpr, String ) -> f () )
|
||||
-- -> list value
|
||||
-- -> f ()
|
||||
-- go f xs =
|
||||
-- void
|
||||
-- ( traverseTableWithIndexC
|
||||
-- @Unconstrained
|
||||
-- @schema
|
||||
-- @schema
|
||||
-- ( \i ->
|
||||
-- traverseC \c@ColumnSchema{ columnName } ->
|
||||
-- c <$ f ( toPrimExpr . toColumn . flip field ( transferField i ) <$> xs, columnName )
|
||||
-- )
|
||||
-- ( tableColumns into_ )
|
||||
-- )
|
||||
|
||||
in
|
||||
Opaleye.Writer ( Opaleye.PackMap go )
|
||||
-- in
|
||||
-- Opaleye.Writer ( Opaleye.PackMap go )
|
||||
|
||||
|
||||
opaleyeReturning :: Returning schema result -> Opaleye.Returning schema result
|
||||
opaleyeReturning returning =
|
||||
case returning of
|
||||
NumberOfRowsInserted ->
|
||||
Opaleye.Count
|
||||
-- opaleyeReturning :: Returning schema result -> Opaleye.Returning schema result
|
||||
-- opaleyeReturning returning =
|
||||
-- case returning of
|
||||
-- NumberOfRowsInserted ->
|
||||
-- Opaleye.Count
|
||||
|
||||
Projection f ->
|
||||
Opaleye.ReturningExplicit
|
||||
queryRunner
|
||||
( f . mapTable ( mapC ( column . columnName ) ) )
|
||||
-- Projection f ->
|
||||
-- Opaleye.ReturningExplicit
|
||||
-- queryRunner
|
||||
-- ( f . mapTable ( mapC ( column . columnName ) ) )
|
||||
|
||||
|
||||
ddlTable :: TableSchema schema -> Opaleye.Writer value schema -> Opaleye.Table value schema
|
||||
ddlTable schema writer_ =
|
||||
toOpaleyeTable schema writer_ ( Opaleye.View ( tableColumns schema ) )
|
||||
-- ddlTable :: TableSchema schema -> Opaleye.Writer value schema -> Opaleye.Table value schema
|
||||
-- ddlTable schema writer_ =
|
||||
-- toOpaleyeTable schema writer_ ( Opaleye.View ( tableColumns schema ) )
|
||||
|
||||
|
||||
-- | The constituent parts of a SQL @INSERT@ statement.
|
||||
data Insert :: * -> * where
|
||||
Insert
|
||||
:: Selects Query schema value
|
||||
=> { into :: TableSchema schema
|
||||
-- ^ Which table to insert into.
|
||||
, values :: [ value ]
|
||||
-- ^ The rows to insert.
|
||||
, onConflict :: OnConflict
|
||||
-- ^ What to do if the inserted rows conflict with data already in the
|
||||
-- table.
|
||||
, returning :: Returning schema result
|
||||
-- ^ What information to return on completion.
|
||||
}
|
||||
-> Insert result
|
||||
-- -- | The constituent parts of a SQL @INSERT@ statement.
|
||||
-- data Insert :: * -> * where
|
||||
-- Insert
|
||||
-- :: Selects Query schema value
|
||||
-- => { into :: TableSchema schema
|
||||
-- -- ^ Which table to insert into.
|
||||
-- , values :: [ value ]
|
||||
-- -- ^ The rows to insert.
|
||||
-- , onConflict :: OnConflict
|
||||
-- -- ^ What to do if the inserted rows conflict with data already in the
|
||||
-- -- table.
|
||||
-- , returning :: Returning schema result
|
||||
-- -- ^ What information to return on completion.
|
||||
-- }
|
||||
-- -> Insert result
|
||||
|
||||
|
||||
-- | @Returning@ describes what information to return when an @INSERT@
|
||||
-- statement completes.
|
||||
data Returning schema a where
|
||||
-- | Just return the number of rows inserted.
|
||||
NumberOfRowsInserted :: Returning schema Int64
|
||||
-- -- | @Returning@ describes what information to return when an @INSERT@
|
||||
-- -- statement completes.
|
||||
-- data Returning schema a where
|
||||
-- -- | Just return the number of rows inserted.
|
||||
-- NumberOfRowsInserted :: Returning schema Int64
|
||||
|
||||
-- | Return a projection of the rows inserted. This can be useful if your
|
||||
-- insert statement increments sequences by using default values.
|
||||
--
|
||||
-- >>> :t insert Insert{ returning = Projection fooId }
|
||||
-- IO [ FooId ]
|
||||
Projection
|
||||
:: ( Selects Query schema row
|
||||
, Context row ~ Context projection
|
||||
, FromRow projection a
|
||||
)
|
||||
=> ( row -> projection )
|
||||
-> Returning schema [ a ]
|
||||
-- -- | Return a projection of the rows inserted. This can be useful if your
|
||||
-- -- insert statement increments sequences by using default values.
|
||||
-- --
|
||||
-- -- >>> :t insert Insert{ returning = Projection fooId }
|
||||
-- -- IO [ FooId ]
|
||||
-- Projection
|
||||
-- :: ( Selects Query schema row
|
||||
-- , Context row ~ Context projection
|
||||
-- , FromRow projection a
|
||||
-- )
|
||||
-- => ( row -> projection )
|
||||
-- -> Returning schema [ a ]
|
||||
|
||||
|
||||
data OnConflict
|
||||
= Abort
|
||||
| DoNothing
|
||||
-- data OnConflict
|
||||
-- = Abort
|
||||
-- | DoNothing
|
||||
|
||||
|
||||
selectQuery
|
||||
:: forall a
|
||||
. ( Context a ~ Expr Query, Table a )
|
||||
. ( Table a, Context a ~ Expr Query, Recontextualise a Id )
|
||||
=> Query a -> Maybe String
|
||||
selectQuery ( Query opaleye ) =
|
||||
showSqlForPostgresExplicit
|
||||
@ -263,70 +265,70 @@ selectQuery ( Query opaleye ) =
|
||||
)
|
||||
|
||||
|
||||
delete :: MonadIO m => Connection -> Delete from returning -> m returning
|
||||
delete c Delete{ from, deleteWhere, returning } =
|
||||
liftIO ( Opaleye.runDelete_ c ( go from deleteWhere returning ) )
|
||||
-- delete :: MonadIO m => Connection -> Delete from returning -> m returning
|
||||
-- delete c Delete{ from, deleteWhere, returning } =
|
||||
-- liftIO ( Opaleye.runDelete_ c ( go from deleteWhere returning ) )
|
||||
|
||||
where
|
||||
-- where
|
||||
|
||||
go
|
||||
:: forall schema r row
|
||||
. ( CompatibleTables row schema, Context schema ~ ColumnSchema, Context row ~ Expr Query )
|
||||
=> TableSchema schema
|
||||
-> ( row -> Expr Query Bool )
|
||||
-> Returning schema r
|
||||
-> Opaleye.Delete r
|
||||
go schema deleteWhere_ returning_ =
|
||||
Opaleye.Delete
|
||||
{ dTable = ddlTable schema ( Opaleye.Writer ( pure () ) )
|
||||
, dWhere = Opaleye.Column . toPrimExpr . deleteWhere_ . mapTable ( mapC ( column . columnName ) )
|
||||
, dReturning = opaleyeReturning returning_
|
||||
}
|
||||
-- go
|
||||
-- :: forall schema r row
|
||||
-- . ( CompatibleTables row schema, Context schema ~ ColumnSchema, Context row ~ Expr Query )
|
||||
-- => TableSchema schema
|
||||
-- -> ( row -> Expr Query Bool )
|
||||
-- -> Returning schema r
|
||||
-- -> Opaleye.Delete r
|
||||
-- go schema deleteWhere_ returning_ =
|
||||
-- Opaleye.Delete
|
||||
-- { dTable = ddlTable schema ( Opaleye.Writer ( pure () ) )
|
||||
-- , dWhere = Opaleye.Column . toPrimExpr . deleteWhere_ . mapTable ( mapC ( column . columnName ) )
|
||||
-- , dReturning = opaleyeReturning returning_
|
||||
-- }
|
||||
|
||||
|
||||
data Delete from return where
|
||||
Delete
|
||||
:: Selects Query from row
|
||||
=> { from :: TableSchema from
|
||||
, deleteWhere :: row -> Expr Query Bool
|
||||
, returning :: Returning from return
|
||||
}
|
||||
-> Delete from return
|
||||
-- data Delete from return where
|
||||
-- Delete
|
||||
-- :: Selects Query from row
|
||||
-- => { from :: TableSchema from
|
||||
-- , deleteWhere :: row -> Expr Query Bool
|
||||
-- , returning :: Returning from return
|
||||
-- }
|
||||
-- -> Delete from return
|
||||
|
||||
|
||||
update :: MonadIO m => Connection -> Update target returning -> m returning
|
||||
update connection Update{ target, set, updateWhere, returning } =
|
||||
liftIO ( Opaleye.runUpdate_ connection ( go target set updateWhere returning ) )
|
||||
-- update :: MonadIO m => Connection -> Update target returning -> m returning
|
||||
-- update connection Update{ target, set, updateWhere, returning } =
|
||||
-- liftIO ( Opaleye.runUpdate_ connection ( go target set updateWhere returning ) )
|
||||
|
||||
where
|
||||
-- where
|
||||
|
||||
go
|
||||
:: forall returning target row
|
||||
. ( CompatibleTables row target
|
||||
, CompatibleTables target row
|
||||
, Context target ~ ColumnSchema
|
||||
, Context row ~ Expr Query
|
||||
)
|
||||
=> TableSchema target
|
||||
-> ( row -> row )
|
||||
-> ( row -> Expr Query Bool )
|
||||
-> Returning target returning
|
||||
-> Opaleye.Update returning
|
||||
go target_ set_ updateWhere_ returning_ =
|
||||
Opaleye.Update
|
||||
{ uTable = ddlTable target_ ( writer target_ )
|
||||
, uReturning = opaleyeReturning returning_
|
||||
, uWhere = Opaleye.Column . toPrimExpr . updateWhere_ . mapTable ( mapC ( column . columnName ) )
|
||||
, uUpdateWith = set_ . mapTable ( mapC ( column . columnName ) )
|
||||
}
|
||||
-- go
|
||||
-- :: forall returning target row
|
||||
-- . ( CompatibleTables row target
|
||||
-- , CompatibleTables target row
|
||||
-- , Context target ~ ColumnSchema
|
||||
-- , Context row ~ Expr Query
|
||||
-- )
|
||||
-- => TableSchema target
|
||||
-- -> ( row -> row )
|
||||
-- -> ( row -> Expr Query Bool )
|
||||
-- -> Returning target returning
|
||||
-- -> Opaleye.Update returning
|
||||
-- go target_ set_ updateWhere_ returning_ =
|
||||
-- Opaleye.Update
|
||||
-- { uTable = ddlTable target_ ( writer target_ )
|
||||
-- , uReturning = opaleyeReturning returning_
|
||||
-- , uWhere = Opaleye.Column . toPrimExpr . updateWhere_ . mapTable ( mapC ( column . columnName ) )
|
||||
-- , uUpdateWith = set_ . mapTable ( mapC ( column . columnName ) )
|
||||
-- }
|
||||
|
||||
|
||||
data Update target returning where
|
||||
Update
|
||||
:: Selects Query target row
|
||||
=> { target :: TableSchema target
|
||||
, set :: row -> row
|
||||
, updateWhere :: row -> Expr Query Bool
|
||||
, returning :: Returning target returning
|
||||
}
|
||||
-> Update target returning
|
||||
-- data Update target returning where
|
||||
-- Update
|
||||
-- :: Selects Query target row
|
||||
-- => { target :: TableSchema target
|
||||
-- , set :: row -> row
|
||||
-- , updateWhere :: row -> Expr Query Bool
|
||||
-- , returning :: Returning target returning
|
||||
-- }
|
||||
-- -> Update target returning
|
||||
|
||||
@ -11,6 +11,7 @@
|
||||
|
||||
module Rel8.SimpleConstraints where
|
||||
|
||||
import Rel8.Column
|
||||
import Rel8.ColumnSchema
|
||||
import Rel8.Expr
|
||||
import Rel8.Nest
|
||||
@ -22,8 +23,11 @@ import Rel8.Table
|
||||
class
|
||||
( Context row ~ Expr m
|
||||
, Context schema ~ ColumnSchema
|
||||
, CompatibleTables row schema
|
||||
, CompatibleTables schema row
|
||||
, MapContext ( From m ) schema ~ row
|
||||
, Recontextualise schema ( From m )
|
||||
, Recontextualise row Id
|
||||
-- , CompatibleTables row schema
|
||||
-- , CompatibleTables schema row
|
||||
) => Selects m schema row
|
||||
|
||||
|
||||
@ -31,8 +35,12 @@ instance
|
||||
{-# overlapping #-}
|
||||
( Context row ~ Expr m
|
||||
, Context schema ~ ColumnSchema
|
||||
, CompatibleTables row schema
|
||||
, CompatibleTables schema row
|
||||
, MapContext ( From m ) schema ~ row
|
||||
, Recontextualise schema ( From m )
|
||||
, Table row
|
||||
, Recontextualise row Id
|
||||
-- , CompatibleTables row schema
|
||||
-- , CompatibleTables schema row
|
||||
) => Selects m schema row
|
||||
|
||||
|
||||
@ -42,8 +50,12 @@ data Hidden ( a :: k )
|
||||
instance
|
||||
( Context row ~ Expr m
|
||||
, Context ( Hidden () ) ~ ColumnSchema
|
||||
, CompatibleTables row ( Hidden () )
|
||||
, CompatibleTables ( Hidden () ) row
|
||||
, MapContext ( From m ) ( Hidden () ) ~ row
|
||||
, Recontextualise ( Hidden () ) ( From m )
|
||||
, Table row
|
||||
, Recontextualise row Id
|
||||
-- , CompatibleTables row ( Hidden () )
|
||||
-- , CompatibleTables ( Hidden () ) row
|
||||
) => Selects m ( Hidden () ) row
|
||||
|
||||
|
||||
@ -60,9 +72,9 @@ class
|
||||
-- but exist at different levels of scope. In particular, @Promote m a b@ says
|
||||
-- @b@ is the same expression as @a@, where the scope has been increased by one.
|
||||
class
|
||||
( CompatibleTables a b
|
||||
, Context a ~ Expr m
|
||||
( Context a ~ Expr m
|
||||
, Context b ~ Expr ( Nest m )
|
||||
-- , CompatibleTables a b
|
||||
, Table a
|
||||
, Table b
|
||||
) => Promote m a b where
|
||||
@ -70,16 +82,18 @@ class
|
||||
|
||||
instance
|
||||
{-# overlapping #-}
|
||||
( CompatibleTables a b
|
||||
, Context a ~ Expr m
|
||||
( Context a ~ Expr m
|
||||
, Context b ~ Expr ( Nest m )
|
||||
-- , CompatibleTables a b
|
||||
, Table a
|
||||
, Table b
|
||||
) => Promote m a b where
|
||||
|
||||
|
||||
instance
|
||||
( CompatibleTables ( Hidden () ) b
|
||||
, Context ( Hidden () ) ~ Expr m
|
||||
( Context ( Hidden () ) ~ Expr m
|
||||
, Context b ~ Expr ( Nest m )
|
||||
, Table ( Hidden () )
|
||||
, Table b
|
||||
-- , CompatibleTables ( Hidden () ) b
|
||||
) => Promote m ( Hidden () ) b where
|
||||
|
||||
@ -24,37 +24,37 @@ behind the scenes, and is safely exported if you want to use it in your own
|
||||
work, or if you want to understand further how Rel8 works.
|
||||
|
||||
-}
|
||||
module Rel8.Table
|
||||
( -- * Tables of kind @*@
|
||||
Table(..)
|
||||
, mapTable
|
||||
, mapTableC
|
||||
, traverseTable
|
||||
, traverseTableC
|
||||
, traverseTableWithIndexC
|
||||
, zipTablesWithM
|
||||
, zipTablesWithMC
|
||||
module Rel8.Table where
|
||||
-- ( -- * Tables of kind @*@
|
||||
-- Table(..)
|
||||
-- , mapTable
|
||||
-- , mapTableC
|
||||
-- , traverseTable
|
||||
-- , traverseTableC
|
||||
-- , traverseTableWithIndexC
|
||||
-- , zipTablesWithM
|
||||
-- , zipTablesWithMC
|
||||
|
||||
-- ** Sub-tables
|
||||
, ConstrainedTable
|
||||
, Unconstrained
|
||||
-- -- ** Sub-tables
|
||||
-- , ConstrainedTable
|
||||
-- , Unconstrained
|
||||
|
||||
-- ** Relationships Between Tables
|
||||
, CompatibleTables
|
||||
, Compatible(..)
|
||||
-- -- ** Relationships Between Tables
|
||||
-- , CompatibleTables
|
||||
-- , Compatible(..)
|
||||
|
||||
-- * Higher-kinded tables
|
||||
, HigherKindedTable
|
||||
-- -- * Higher-kinded tables
|
||||
-- , HigherKindedTable
|
||||
|
||||
-- * Columns
|
||||
, Column
|
||||
, C( MkC )
|
||||
, mapC
|
||||
, traverseC
|
||||
, traverseCC
|
||||
, zipCWithM
|
||||
, zipCWithMC
|
||||
) where
|
||||
-- -- * Columns
|
||||
-- , Column
|
||||
-- , C( MkC )
|
||||
-- , mapC
|
||||
-- , traverseC
|
||||
-- , traverseCC
|
||||
-- , zipCWithM
|
||||
-- , zipCWithMC
|
||||
-- ) where
|
||||
|
||||
import Data.Functor.Identity
|
||||
import Data.Kind
|
||||
@ -136,7 +136,7 @@ instance Table HaskellPackage where
|
||||
@
|
||||
|
||||
-}
|
||||
class ( Compatible t ( Context t ) t ( Context t ), ConstrainTable t Unconstrained ) => Table ( t :: Type ) where
|
||||
class ( ConstrainTable t Unconstrained, MapContext Id t ~ t ) => Table ( t :: Type ) where
|
||||
-- | The @Field@ type is a type where each value corresponds to a distinct
|
||||
-- field in the table. It describes not just the field itself, but also the
|
||||
-- type of values stored there.
|
||||
@ -146,6 +146,9 @@ class ( Compatible t ( Context t ) t ( Context t ), ConstrainTable t Unconstrain
|
||||
-- This associated type family lets us extract that functor.
|
||||
type Context t :: Type -> Type
|
||||
|
||||
-- | Ensure a constraint holds over all field types in the table.
|
||||
type ConstrainTable t ( c :: Type -> Constraint ) :: Constraint
|
||||
|
||||
-- | Give the tag of field in the table, look at the contents of that field.
|
||||
field :: t -> Field t x -> C ( Context t ) x
|
||||
|
||||
@ -164,131 +167,155 @@ class ( Compatible t ( Context t ) t ( Context t ), ConstrainTable t Unconstrain
|
||||
-> ( forall x. c x => Field t x -> f ( C ( Context t ) x ) )
|
||||
-> f t
|
||||
|
||||
-- | Ensure a constraint holds over all field types in the table.
|
||||
type ConstrainTable t ( c :: Type -> Constraint ) :: Constraint
|
||||
|
||||
class ( Table t, Table ( MapContext f t ) ) => Recontextualise ( t :: Type ) ( f :: ( Type -> Type ) -> Type -> Type ) where
|
||||
type MapContext f t :: Type
|
||||
|
||||
fieldMapping :: Field ( MapContext f t ) x -> Field t x
|
||||
|
||||
reverseFieldMapping :: Field t x -> Field ( MapContext f t ) x
|
||||
|
||||
|
||||
-- | A type class synonym for all tables that can be constrained by a given
|
||||
-- class.
|
||||
class ( ConstrainTable t c, Table t ) => ConstrainedTable t c where
|
||||
instance ( ConstrainTable t c, Table t ) => ConstrainedTable t c where
|
||||
class ContextMap ( f :: ( Type -> Type ) -> Type -> Type ) ( context :: Type -> Type ) where
|
||||
recontextualiseColumn :: C context x -> C ( f context ) x
|
||||
|
||||
|
||||
-- | Witness that two tables are compatible with each other. The notion of
|
||||
-- compatible is explained in 'Compatible'.
|
||||
class ( Table a, Table b, Compatible a ( Context a ) b ( Context b ) ) => CompatibleTables a b
|
||||
instance ( Table a, Table b, Compatible a ( Context a ) b ( Context b ) ) => CompatibleTables a b
|
||||
-- instance Table t => Recontextualise t Id where
|
||||
-- type MapContext Id t = t
|
||||
|
||||
|
||||
-- | This type class witnesses that two tables are "compatible" with each over.
|
||||
-- Compatible in the sense of Rel8 means:
|
||||
--
|
||||
-- * Both tables use the same context functor.
|
||||
-- * Both tables have isomorphic fields selectors.
|
||||
class ( Context a ~ f, Context b ~ g ) => Compatible a ( f :: Type -> Type ) b ( g :: Type -> Type ) | a -> f, b -> g, f b g -> a where
|
||||
-- | Witness the isomorphism between field selectors.
|
||||
transferField :: Field a x -> Field b x
|
||||
-- instance Table t => Recontextualise t Structure where
|
||||
-- type MapContext Structure t = Spine t
|
||||
|
||||
|
||||
-- data SpineField t a = SpineField { fromSpineField :: Field t a }
|
||||
|
||||
-- instance Table t => Table ( Spine t ) where
|
||||
-- type ConstrainTable ( Spine t ) c =
|
||||
-- ConstrainTable t c
|
||||
|
||||
-- type Field ( Spine t ) =
|
||||
-- SpineField t
|
||||
|
||||
|
||||
-- instance Table t => Table ( Identity t ) where
|
||||
-- type Context ( Identity t ) =
|
||||
-- Id ( Context t )
|
||||
|
||||
-- type ConstrainTable ( Identity t ) Unconstrained =
|
||||
-- ConstrainTable t Unconstrained
|
||||
|
||||
|
||||
-- | Effectfully map a table from one context to another.
|
||||
traverseTableWithIndexC
|
||||
:: forall c t t' f g m
|
||||
. ( Applicative m, Table t, Compatible t' f t g, ConstrainedTable t' c )
|
||||
:: forall c f t t' m
|
||||
. ( Applicative m
|
||||
, ConstrainTable t' c
|
||||
, MapContext f t ~ t'
|
||||
, Recontextualise t f
|
||||
, Table t
|
||||
, Table t'
|
||||
)
|
||||
=> ( forall x. c x => Field t x -> C ( Context t ) x -> m ( C ( Context t' ) x ) )
|
||||
-> t
|
||||
-> m t'
|
||||
traverseTableWithIndexC f t =
|
||||
tabulateMCP ( Proxy @c ) \index ->
|
||||
f ( transferField index ) ( field t ( transferField index ) )
|
||||
f ( fieldMapping @_ @f index ) ( field t ( fieldMapping @_ @f index ) )
|
||||
|
||||
|
||||
data TupleField a b x where
|
||||
Element1 :: Field a x -> TupleField a b x
|
||||
Element2 :: Field b x -> TupleField a b x
|
||||
-- data TupleField a b x where
|
||||
-- Element1 :: Field a x -> TupleField a b x
|
||||
-- Element2 :: Field b x -> TupleField a b x
|
||||
|
||||
|
||||
-- | The product of two tables is also a table, provided that they share the
|
||||
-- same 'Context'.
|
||||
instance ( Context a ~ Context b, Table a, Table b ) => Table ( a, b ) where
|
||||
type Context ( a, b ) =
|
||||
Context a
|
||||
-- -- | The product of two tables is also a table, provided that they share the
|
||||
-- -- same 'Context'.
|
||||
-- instance ( Context a ~ Context b, Table a, Table b ) => Table ( a, b ) where
|
||||
-- type Context ( a, b ) =
|
||||
-- Context a
|
||||
|
||||
type ConstrainTable ( a, b ) c =
|
||||
( ConstrainTable a c, ConstrainTable b c )
|
||||
-- type ConstrainTable ( a, b ) c =
|
||||
-- ( ConstrainTable a c, ConstrainTable b c )
|
||||
|
||||
type Field ( a, b ) = TupleField a b
|
||||
-- type Field ( a, b ) = TupleField a b
|
||||
|
||||
field ( a, b ) = \case
|
||||
Element1 f -> field a f
|
||||
Element2 f -> field b f
|
||||
-- field ( a, b ) = \case
|
||||
-- Element1 f -> field a f
|
||||
-- Element2 f -> field b f
|
||||
|
||||
tabulateMCP proxy f =
|
||||
(,) <$> tabulateMCP proxy ( f . Element1 )
|
||||
<*> tabulateMCP proxy ( f . Element2 )
|
||||
-- tabulateMCP proxy f =
|
||||
-- (,) <$> tabulateMCP proxy ( f . Element1 )
|
||||
-- <*> tabulateMCP proxy ( f . Element2 )
|
||||
|
||||
|
||||
instance ( Context x ~ Context y, Context a ~ Context b, Compatible a f x g, Compatible b f y g ) => Compatible ( a, b ) f ( x, y ) g where
|
||||
transferField = \case
|
||||
Element1 i -> Element1 ( transferField i )
|
||||
Element2 i -> Element2 ( transferField i )
|
||||
-- instance ( Context x ~ Context y, Context a ~ Context b, Compatible a f x g, Compatible b f y g ) => Compatible ( a, b ) f ( x, y ) g where
|
||||
-- transferField = \case
|
||||
-- Element1 i -> Element1 ( transferField i )
|
||||
-- Element2 i -> Element2 ( transferField i )
|
||||
|
||||
|
||||
data SumField a x where
|
||||
SumField :: Field a x -> SumField a x
|
||||
-- data SumField a x where
|
||||
-- SumField :: Field a x -> SumField a x
|
||||
|
||||
|
||||
instance Table a => Table ( Sum a ) where
|
||||
type ConstrainTable ( Sum a ) c =
|
||||
ConstrainTable a c
|
||||
-- instance Table a => Table ( Sum a ) where
|
||||
-- type ConstrainTable ( Sum a ) c =
|
||||
-- ConstrainTable a c
|
||||
|
||||
type Context ( Sum a ) =
|
||||
Context a
|
||||
-- type Context ( Sum a ) =
|
||||
-- Context a
|
||||
|
||||
type Field ( Sum a ) = SumField a
|
||||
-- type Field ( Sum a ) = SumField a
|
||||
|
||||
field ( Sum a ) ( SumField i ) =
|
||||
field a i
|
||||
-- field ( Sum a ) ( SumField i ) =
|
||||
-- field a i
|
||||
|
||||
tabulateMCP proxy f =
|
||||
Sum <$> tabulateMCP proxy ( f . SumField )
|
||||
-- tabulateMCP proxy f =
|
||||
-- Sum <$> tabulateMCP proxy ( f . SumField )
|
||||
|
||||
|
||||
instance Compatible a f b g => Compatible ( Sum a ) f ( Sum b ) g where
|
||||
transferField ( SumField x ) =
|
||||
SumField ( transferField x )
|
||||
-- instance Compatible a f b g => Compatible ( Sum a ) f ( Sum b ) g where
|
||||
-- transferField ( SumField x ) =
|
||||
-- SumField ( transferField x )
|
||||
|
||||
|
||||
-- | Map a 'Table' from one type to another. The table types must be compatible,
|
||||
-- see 'Compatible' for what that means.
|
||||
mapTable
|
||||
:: forall t' t
|
||||
. CompatibleTables t' t
|
||||
:: forall f t' t
|
||||
. ( MapContext f t ~ t'
|
||||
, ConstrainTable t' Unconstrained
|
||||
, Recontextualise t f
|
||||
, Table t
|
||||
, Table t'
|
||||
)
|
||||
=> ( forall x. C ( Context t ) x -> C ( Context t' ) x ) -> t -> t'
|
||||
mapTable f =
|
||||
runIdentity . traverseTable ( Identity . f )
|
||||
runIdentity . traverseTable @f ( Identity . f )
|
||||
|
||||
|
||||
-- | Map a 'Table' from one type to another, where all columns in the table are
|
||||
-- subject to a constraint. The table types must be compatible, see 'Compatible'
|
||||
-- for what that means.
|
||||
mapTableC
|
||||
:: forall c t' t
|
||||
. ( ConstrainedTable t' c, CompatibleTables t' t )
|
||||
:: forall c f t' t
|
||||
. ( ConstrainTable t' c, MapContext f t ~ t', Recontextualise t f )
|
||||
=> ( forall x. c x => C ( Context t ) x -> C ( Context t' ) x ) -> t -> t'
|
||||
mapTableC f =
|
||||
runIdentity . traverseTableC @c ( Identity . f )
|
||||
runIdentity . traverseTableC @f @c ( Identity . f )
|
||||
|
||||
|
||||
-- | Effectfully traverse all fields in a 'Table', potentially producing another
|
||||
-- @Table@.
|
||||
traverseTable
|
||||
:: forall t' t f
|
||||
. ( Applicative f, Table t', CompatibleTables t' t )
|
||||
=> ( forall x. C ( Context t ) x -> f ( C ( Context t' ) x ) )
|
||||
:: forall f t' t m
|
||||
. ( Applicative m, MapContext f t ~ t', Recontextualise t f, ConstrainTable t' Unconstrained, Table t', Table t )
|
||||
=> ( forall x. C ( Context t ) x -> m ( C ( Context t' ) x ) )
|
||||
-> t
|
||||
-> f t'
|
||||
-> m t'
|
||||
traverseTable f =
|
||||
traverseTableWithIndexC @Unconstrained ( const f )
|
||||
traverseTableWithIndexC @Unconstrained @f ( const f )
|
||||
|
||||
|
||||
-- | Effectfully traverse all fields in a 'Table', provided that all fields
|
||||
@ -299,263 +326,36 @@ traverseTable f =
|
||||
-- >>> traverseTableC @Read ( traverseC readMaybe ) MyTable{ fieldA = "True" }
|
||||
-- Just MyTable{ fieldA = True }
|
||||
traverseTableC
|
||||
:: forall c m t t'
|
||||
. ( Applicative m, ConstrainedTable t' c, CompatibleTables t' t )
|
||||
:: forall f c m t t'
|
||||
. ( Applicative m, MapContext f t ~ t', ConstrainTable t' c, Recontextualise t f )
|
||||
=> ( forall x. c x => C ( Context t ) x -> m ( C ( Context t' ) x ) )
|
||||
-> t
|
||||
-> m t'
|
||||
traverseTableC f =
|
||||
traverseTableWithIndexC @c ( const f )
|
||||
traverseTableWithIndexC @c @f ( const f )
|
||||
|
||||
|
||||
zipTablesWithM
|
||||
:: forall t t' t'' m
|
||||
. ( Applicative m
|
||||
, Table t''
|
||||
, CompatibleTables t'' t
|
||||
, CompatibleTables t'' t'
|
||||
)
|
||||
=> ( forall x. C ( Context t ) x -> C ( Context t' ) x -> m ( C ( Context t'' ) x ) )
|
||||
-> t -> t' -> m t''
|
||||
zipTablesWithM f t t' =
|
||||
tabulateMCP @t'' ( Proxy @Unconstrained ) \index ->
|
||||
f ( field t ( transferField index ) )
|
||||
( field t' ( transferField index ) )
|
||||
-- zipTablesWithM
|
||||
-- :: forall t t' t'' m
|
||||
-- . ( Applicative m
|
||||
-- , Table t''
|
||||
-- , CompatibleTables t'' t
|
||||
-- , CompatibleTables t'' t'
|
||||
-- )
|
||||
-- => ( forall x. C ( Context t ) x -> C ( Context t' ) x -> m ( C ( Context t'' ) x ) )
|
||||
-- -> t -> t' -> m t''
|
||||
-- zipTablesWithM f t t' =
|
||||
-- tabulateMCP @t'' ( Proxy @Unconstrained ) \index ->
|
||||
-- f ( field t ( transferField index ) )
|
||||
-- ( field t' ( transferField index ) )
|
||||
|
||||
|
||||
zipTablesWithMC
|
||||
:: forall c t'' t t' m
|
||||
. ( ConstrainTable t'' c
|
||||
, CompatibleTables t'' t
|
||||
, CompatibleTables t'' t'
|
||||
, Applicative m
|
||||
:: forall c t m
|
||||
. ( Applicative m, ConstrainTable t c, Table t
|
||||
)
|
||||
=> ( forall x. c x => C ( Context t ) x -> C ( Context t' ) x -> m ( C ( Context t'' ) x ) )
|
||||
-> t -> t' -> m t''
|
||||
=> ( forall x. c x => C ( Context t ) x -> C ( Context t ) x -> m ( C ( Context t ) x ) )
|
||||
-> t -> t -> m t
|
||||
zipTablesWithMC f t t' =
|
||||
tabulateMCP @t'' ( Proxy @c) \index ->
|
||||
f ( field t ( transferField index ) ) ( field t' ( transferField index ) )
|
||||
|
||||
|
||||
data GenericField t a where
|
||||
GenericField :: GHField t ( Rep ( t Spine ) ) a -> GenericField t a
|
||||
|
||||
{-| Higher-kinded data types.
|
||||
|
||||
Higher-kinded data types are data types of the pattern:
|
||||
|
||||
@
|
||||
data MyType f =
|
||||
MyType { field1 :: Column f T1 OR HK1 f
|
||||
, field2 :: Column f T2 OR HK2 f
|
||||
, ...
|
||||
, fieldN :: Column f Tn OR HKn f
|
||||
}
|
||||
@
|
||||
|
||||
where @Tn@ is any Haskell type, and @HKn@ is any higher-kinded type.
|
||||
|
||||
That is, higher-kinded data are records where all fields in the record
|
||||
are all either of the type @Column f T@ (for any @T@), or are themselves
|
||||
higher-kinded data:
|
||||
|
||||
[Nested]
|
||||
|
||||
@
|
||||
data Nested f =
|
||||
Nested { nested1 :: MyType f
|
||||
, nested2 :: MyType f
|
||||
}
|
||||
@
|
||||
|
||||
The @HigherKindedTable@ type class is used to give us a special mapping
|
||||
operation that lets us change the type parameter @f@.
|
||||
|
||||
[Supplying @HigherKindedTable@ instances]
|
||||
|
||||
This type class should be derived generically for all table types in your
|
||||
project. To do this, enable the @DeriveAnyType@ and @DeriveGeneric@ language
|
||||
extensions:
|
||||
|
||||
@
|
||||
\{\-\# LANGUAGE DeriveAnyClass, DeriveGeneric #-\}
|
||||
import qualified GHC.Generics
|
||||
|
||||
data MyType f = MyType { fieldA :: Column f T }
|
||||
deriving ( GHC.Generics.Generic, HigherKindedTable )
|
||||
@
|
||||
|
||||
-}
|
||||
class HigherKindedTable ( t :: ( Type -> Type ) -> Type ) where
|
||||
-- | Like 'Field', but for higher-kinded tables.
|
||||
type HField t = ( field :: Type -> Type ) | field -> t
|
||||
type HField t =
|
||||
GenericField t
|
||||
|
||||
-- | Like 'Constraintable', but for higher-kinded tables.
|
||||
type HConstrainTable t ( f :: Type -> Type ) ( c :: Type -> Constraint ) :: Constraint
|
||||
type HConstrainTable t f c =
|
||||
GHConstrainTable ( Rep ( t f ) ) ( Rep ( t Spine ) ) c
|
||||
|
||||
-- | Like 'field', but for higher-kinded tables.
|
||||
hfield :: t f -> HField t x -> C f x
|
||||
default hfield
|
||||
:: forall f x
|
||||
. ( Generic ( t f )
|
||||
, HField t ~ GenericField t
|
||||
, GHigherKindedTable ( Rep ( t f ) ) t f ( Rep ( t Spine ) )
|
||||
)
|
||||
=> t f -> HField t x -> C f x
|
||||
hfield x ( GenericField i ) =
|
||||
ghfield @( Rep ( t f ) ) @t @f @( Rep ( t Spine ) ) ( from x ) i
|
||||
|
||||
-- | Like 'tabulateMCP', but for higher-kinded tables.
|
||||
htabulate
|
||||
:: ( Applicative m, HConstrainTable t f c )
|
||||
=> proxy c -> ( forall x. c x => HField t x -> m ( C f x ) ) -> m ( t f )
|
||||
|
||||
default htabulate
|
||||
:: forall f m c proxy
|
||||
. ( Applicative m, GHConstrainTable ( Rep ( t f ) ) ( Rep ( t Spine ) ) c, Generic ( t f )
|
||||
, GHigherKindedTable ( Rep ( t f ) ) t f ( Rep ( t Spine ) )
|
||||
, HField t ~ GenericField t
|
||||
)
|
||||
=> proxy c -> ( forall x. c x => HField t x -> m ( C f x ) ) -> m ( t f )
|
||||
htabulate proxy f =
|
||||
fmap to ( ghtabulate @( Rep ( t f ) ) @t @f @( Rep ( t Spine ) ) proxy ( f . GenericField ) )
|
||||
|
||||
|
||||
|
||||
data TableHField t ( f :: Type -> Type ) x where
|
||||
F :: HField t x -> TableHField t f x
|
||||
|
||||
|
||||
-- | Any 'HigherKindedTable' is also a 'Table'.
|
||||
instance ( ConstrainTable ( t f ) Unconstrained, HigherKindedTable t ) => Table ( t f ) where
|
||||
type Field ( t f ) =
|
||||
TableHField t f
|
||||
|
||||
type Context ( t f ) =
|
||||
f
|
||||
|
||||
type ConstrainTable ( t f ) c =
|
||||
HConstrainTable t f c
|
||||
|
||||
tabulateMCP proxy f =
|
||||
htabulate proxy \x -> f ( F x )
|
||||
|
||||
field x ( F i ) =
|
||||
hfield x i
|
||||
|
||||
|
||||
instance ( HConstrainTable t' g Unconstrained, HConstrainTable t' f Unconstrained, HConstrainTable t f Unconstrained, t ~ t', f ~ f', g ~ g' ) => Compatible ( t f ) f' ( t' g ) g' where
|
||||
transferField ( F x ) =
|
||||
F x
|
||||
|
||||
|
||||
class GHigherKindedTable ( rep :: Type -> Type ) ( t :: ( Type -> Type ) -> Type ) ( f :: Type -> Type ) ( repIdentity :: Type -> Type ) where
|
||||
data GHField t repIdentity :: Type -> Type
|
||||
|
||||
type GHConstrainTable rep repIdentity ( c :: Type -> Constraint ) :: Constraint
|
||||
|
||||
ghfield :: rep a -> GHField t repIdentity x -> C f x
|
||||
|
||||
ghtabulate
|
||||
:: ( Applicative m, GHConstrainTable rep repIdentity c )
|
||||
=> proxy c
|
||||
-> ( forall x. c x => GHField t repIdentity x -> m ( C f x ) )
|
||||
-> m ( rep a )
|
||||
|
||||
|
||||
instance GHigherKindedTable x t f x' => GHigherKindedTable ( M1 i c x ) t f ( M1 i' c' x' ) where
|
||||
data GHField t ( M1 i' c' x' ) a where
|
||||
M1Field :: GHField t x' a -> GHField t ( M1 i' c' x' ) a
|
||||
|
||||
type GHConstrainTable ( M1 i c x ) ( M1 i' c' x' ) constraint =
|
||||
GHConstrainTable x x' constraint
|
||||
|
||||
ghfield ( M1 a ) ( M1Field i ) =
|
||||
ghfield a i
|
||||
|
||||
ghtabulate proxy f =
|
||||
M1 <$> ghtabulate @x @t @f @x' proxy ( f . M1Field )
|
||||
|
||||
|
||||
instance ( GHigherKindedTable x t f x', GHigherKindedTable y t f y' ) => GHigherKindedTable ( x :*: y ) t f ( x' :*: y' ) where
|
||||
data GHField t ( x' :*: y' ) a where
|
||||
FieldL :: GHField t x' a -> GHField t ( x' :*: y' ) a
|
||||
FieldR :: GHField t y' a -> GHField t ( x' :*: y' ) a
|
||||
|
||||
type GHConstrainTable ( x :*: y ) ( x' :*: y' ) constraint =
|
||||
( GHConstrainTable x x' constraint, GHConstrainTable y y' constraint )
|
||||
|
||||
ghfield ( x :*: y ) = \case
|
||||
FieldL i -> ghfield x i
|
||||
FieldR i -> ghfield y i
|
||||
|
||||
ghtabulate proxy f =
|
||||
(:*:) <$> ghtabulate @x @t @f @x' proxy ( f . FieldL )
|
||||
<*> ghtabulate @y @t @f @y' proxy ( f . FieldR )
|
||||
|
||||
|
||||
type family IsColumnApplication ( a :: Type ) :: Bool where
|
||||
IsColumnApplication ( Spine a ) = 'True
|
||||
IsColumnApplication _ = 'False
|
||||
|
||||
|
||||
|
||||
instance DispatchK1 ( IsColumnApplication c' ) f c c' => GHigherKindedTable ( K1 i c ) t f ( K1 i' c' ) where
|
||||
data GHField t ( K1 i' c' ) a where
|
||||
K1Field :: K1Field ( IsColumnApplication c' ) c' x -> GHField t ( K1 i' c' ) x
|
||||
|
||||
type GHConstrainTable ( K1 i c ) ( K1 i' c' ) constraint =
|
||||
ConstrainK1 ( IsColumnApplication c' ) c c' constraint
|
||||
|
||||
ghfield ( K1 a ) ( K1Field i ) =
|
||||
k1field @( IsColumnApplication c' ) @f @c @c' a i
|
||||
|
||||
ghtabulate proxy f =
|
||||
K1 <$> k1tabulate @( IsColumnApplication c' ) @f @c @c' proxy ( f . K1Field )
|
||||
|
||||
|
||||
class DispatchK1 ( isSpine :: Bool ) f a a' where
|
||||
data K1Field isSpine a' :: Type -> Type
|
||||
|
||||
type ConstrainK1 isSpine a a' ( c :: Type -> Constraint ) :: Constraint
|
||||
|
||||
k1field :: a -> K1Field isSpine a' x -> C f x
|
||||
|
||||
k1tabulate
|
||||
:: ( ConstrainK1 isSpine a a' c, Applicative m )
|
||||
=> proxy c -> ( forall x. c x => K1Field isSpine a' x -> m ( C f x ) ) -> m a
|
||||
|
||||
|
||||
instance a ~ Column f b => DispatchK1 'True f a ( Spine b ) where
|
||||
data K1Field 'True ( Spine b ) x where
|
||||
K1True :: K1Field 'True ( Spine b ) b
|
||||
|
||||
type ConstrainK1 'True a ( Spine b ) c =
|
||||
c b
|
||||
|
||||
k1field a K1True =
|
||||
MkC a
|
||||
|
||||
k1tabulate _ f =
|
||||
toColumn <$> f @b K1True
|
||||
|
||||
|
||||
instance ( Context a ~ f, Table a, Compatible a' Spine a f, Compatible a f a' Spine ) => DispatchK1 'False f a a' where
|
||||
data K1Field 'False a' x where
|
||||
K1False :: Field a' x -> K1Field 'False a' x
|
||||
|
||||
type ConstrainK1 'False a a' c =
|
||||
ConstrainTable a c
|
||||
|
||||
k1field a ( K1False i ) =
|
||||
field a ( transferField i )
|
||||
|
||||
k1tabulate proxy f =
|
||||
tabulateMCP proxy ( f . K1False . transferField )
|
||||
|
||||
|
||||
data Spine a
|
||||
tabulateMCP @t ( Proxy @c) \index ->
|
||||
f ( field t index ) ( field t' index )
|
||||
|
||||
@ -3,9 +3,11 @@
|
||||
{-# language ConstraintKinds #-}
|
||||
{-# language DeriveAnyClass #-}
|
||||
{-# language DeriveGeneric #-}
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language GADTs #-}
|
||||
{-# language InstanceSigs #-}
|
||||
{-# language LambdaCase #-}
|
||||
{-# language MultiParamTypeClasses #-}
|
||||
{-# language NamedFieldPuns #-}
|
||||
{-# language OverloadedStrings #-}
|
||||
{-# language RankNTypes #-}
|
||||
@ -20,6 +22,7 @@
|
||||
|
||||
module Rel8.Tests where
|
||||
|
||||
import Data.Functor.Identity ( Identity )
|
||||
import Data.Int
|
||||
import Data.Monoid
|
||||
import Database.PostgreSQL.Simple ( Connection )
|
||||
@ -54,6 +57,10 @@ allParts =
|
||||
each parts
|
||||
|
||||
|
||||
proj1 :: MonadQuery m => m ( Expr m Int32 )
|
||||
proj1 = partId <$> allParts
|
||||
|
||||
|
||||
partsEq :: MonadQuery m => m ( Expr m Bool )
|
||||
partsEq = do
|
||||
parts1 <- allParts
|
||||
@ -67,7 +74,11 @@ select_allParts c =
|
||||
select c allParts
|
||||
|
||||
|
||||
-- TODO Can we make this infer?
|
||||
proj2 :: Connection -> IO [ Int32 ]
|
||||
proj2 c = map partId <$> select_allParts c
|
||||
|
||||
|
||||
-- -- TODO Can we make this infer?
|
||||
-- allParts_inferred =
|
||||
-- each parts
|
||||
|
||||
@ -121,7 +132,7 @@ projectParts =
|
||||
|
||||
leftJoinTest
|
||||
:: MonadQuery m
|
||||
=> m ( Expr m Int32, MaybeTable ( Expr m ) ( ProjectPart ( Null ( Expr m ) ) ) )
|
||||
=> m ( Expr m ( Maybe Int32) )
|
||||
leftJoinTest = do
|
||||
Part{ partId } <-
|
||||
each parts
|
||||
@ -130,7 +141,7 @@ leftJoinTest = do
|
||||
leftJoin ( each projectParts ) \ProjectPart{ projectPartPartId } ->
|
||||
projectPartPartId ==. partId
|
||||
|
||||
return ( partId, projectPart )
|
||||
return ( projectPartPartId ( maybeTable projectPart ) )
|
||||
|
||||
|
||||
data PartWithProject f =
|
||||
@ -171,31 +182,31 @@ nestedTableEq = do
|
||||
-- select partsWithProjects
|
||||
|
||||
|
||||
partsAggregation
|
||||
:: MonadQuery m
|
||||
=> m ( Expr m String, Sum ( Expr m Int32 ) )
|
||||
partsAggregation = do
|
||||
groupAndAggregate
|
||||
( \part -> GroupBy ( partName part ) ( Sum ( partId part ) ) )
|
||||
allParts
|
||||
-- partsAggregation
|
||||
-- :: MonadQuery m
|
||||
-- => m ( Expr m String, Sum ( Expr m Int32 ) )
|
||||
-- partsAggregation = do
|
||||
-- groupAndAggregate
|
||||
-- ( \part -> GroupBy ( partName part ) ( Sum ( partId part ) ) )
|
||||
-- allParts
|
||||
|
||||
|
||||
-- -- illegalPartsAggregation1 :: MonadQuery m => m ( GroupBy ( Expr m String ) ( Sum ( Expr m Int32 ) ) )
|
||||
-- -- illegalPartsAggregation1 = do
|
||||
-- -- unreachable <- allParts
|
||||
-- -- -- illegalPartsAggregation1 :: MonadQuery m => m ( GroupBy ( Expr m String ) ( Sum ( Expr m Int32 ) ) )
|
||||
-- -- -- illegalPartsAggregation1 = do
|
||||
-- -- -- unreachable <- allParts
|
||||
|
||||
-- -- groupAndAggregate
|
||||
-- -- ( \part -> GroupBy ( partName unreachable ) ( Sum ( partId part ) ) )
|
||||
-- -- allParts
|
||||
-- -- -- groupAndAggregate
|
||||
-- -- -- ( \part -> GroupBy ( partName unreachable ) ( Sum ( partId part ) ) )
|
||||
-- -- -- allParts
|
||||
|
||||
|
||||
-- -- illegalPartsAggregation2 :: MonadQuery m => m ( GroupBy ( Expr m String ) ( Sum ( Expr m Int32 ) ) )
|
||||
-- -- illegalPartsAggregation2 = do
|
||||
-- -- unreachable <- allParts
|
||||
-- -- -- illegalPartsAggregation2 :: MonadQuery m => m ( GroupBy ( Expr m String ) ( Sum ( Expr m Int32 ) ) )
|
||||
-- -- -- illegalPartsAggregation2 = do
|
||||
-- -- -- unreachable <- allParts
|
||||
|
||||
-- -- groupAndAggregate
|
||||
-- -- ( \part -> unreachable )
|
||||
-- -- allParts
|
||||
-- -- -- groupAndAggregate
|
||||
-- -- -- ( \part -> unreachable )
|
||||
-- -- -- allParts
|
||||
|
||||
|
||||
data HasNull f =
|
||||
@ -227,7 +238,7 @@ nullTest = do
|
||||
|
||||
nullTestLeftJoin
|
||||
:: MonadQuery m
|
||||
=> m ( Expr m ( Maybe ( Maybe Int32 ) ), Expr m ( Maybe Int32 ) )
|
||||
=> m ( Expr m ( Maybe Int32 ), Expr m ( Maybe Int32 ) )
|
||||
nullTestLeftJoin = do
|
||||
t1 <-
|
||||
each hasNull
|
||||
@ -241,7 +252,7 @@ nullTestLeftJoin = do
|
||||
|
||||
nullTestLeftJoinEasyEq
|
||||
:: MonadQuery m
|
||||
=> m ( Expr m ( Maybe ( Maybe Int32 ) ), Expr m ( Maybe Int32 ) )
|
||||
=> m ( Expr m ( Maybe Int32 ), Expr m ( Maybe Int32 ) )
|
||||
nullTestLeftJoinEasyEq = do
|
||||
t1 <-
|
||||
each hasNull
|
||||
@ -253,6 +264,6 @@ nullTestLeftJoinEasyEq = do
|
||||
return ( nullId ( maybeTable t2 ), notNullId ( maybeTable t2 ) )
|
||||
|
||||
|
||||
filterMapTest :: MonadQuery m => m _
|
||||
filterMapTest =
|
||||
filterMap nullId ( each hasNull )
|
||||
-- filterMapTest :: MonadQuery m => m _
|
||||
-- filterMapTest =
|
||||
-- filterMap nullId ( each hasNull )
|
||||
|
||||
Loading…
Reference in New Issue
Block a user