circuithub/rel8
1
1
Fork 0
mirror of https://github.com/circuithub/rel8.git synced 2024-07-14 19:00:34 +03:00
Code Issues Projects Releases Wiki Activity

Some ContextTransformer thingy

Browse Source
This commit is contained in:
Oliver Charles 2020-01-31 11:58:48 +00:00
parent 397ef4da6f
commit 65b8fa7912
6 changed files with 142 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
src/Rel8/Aggregate.hs
View File

@ -233,9 +233,8 @@ instance ( Context k ~ Context v, Context ( MapTable f k ) ~ Context ( MapTable
KeyFields i -> KeyFields ( fieldMapping @_ @f i )
ValueFields i -> ValueFields ( fieldMapping @_ @f i )
reverseFieldMapping = \case
KeyFields i -> KeyFields ( reverseFieldMapping @_ @f i )
ValueFields i -> ValueFields ( reverseFieldMapping @_ @f i )
reverseMapping ( KeyFields i ) k = reverseMapping @k @f i ( k . KeyFields )
reverseMapping ( ValueFields i ) k = reverseMapping @v @f i ( k . ValueFields )
instance ( Context v ~ Expr m, Table k, Context k ~ Expr m, MonoidTable v ) => MonoidTable ( GroupBy k v ) where

67
src/Rel8/Expr.hs
View File

@ -10,6 +10,8 @@
{-# language TypeFamilies #-}
{-# language UndecidableInstances #-}
{-# options -fno-warn-orphans #-}
module Rel8.Expr
( DBType(..)
, (&&.)
@ -52,12 +54,39 @@ import Rel8.Stuff
import Rel8.Table
instance ContextTransformer Select where
type MapColumn Select _ a = a
instance ContextTransformer ( From m ) where
type MapColumn ( From m ) _ a = a
instance ContextTransformer NotNull where
type MapColumn NotNull _ a = DropMaybe a
instance ContextTransformer Demote where
type MapColumn Demote _ a = a
instance ContextTransformer Lit where
type MapColumn Lit _ a = a
instance ContextTransformer Null where
type MapColumn Null _ a = Maybe ( DropMaybe a )
instance Recontextualise ( Expr ( Nest m ) a ) Demote where
type MapTable Demote ( Expr ( Nest m ) a ) =
Expr m a
fieldMapping ExprField = ExprField
reverseFieldMapping ExprField = ExprField
reverseMapping ExprField k =
k ExprField
fieldMapping ExprField =
ExprField
-- | Typed SQL expressions
@ -283,15 +312,37 @@ instance Table ( Expr m a ) where
instance Recontextualise ( Expr m a ) Id where
type MapTable Id ( Expr m a ) = Expr m a
fieldMapping ExprField = ExprField
reverseFieldMapping ExprField = ExprField
type MapTable Id ( Expr m a ) =
Expr m a
reverseMapping ExprField k =
k ExprField
fieldMapping ExprField =
ExprField
instance Recontextualise ( Expr m a ) Null where
type MapTable Null ( Expr m a ) = Expr m a
fieldMapping ExprField = ExprField
reverseFieldMapping ExprField = ExprField
type MapTable Null ( Expr m a ) =
Expr m ( Maybe ( DropMaybe a ) )
reverseMapping ExprField k =
k ExprField
fieldMapping ExprField =
ExprField
instance Recontextualise ( Expr m a ) NotNull where
type MapTable NotNull ( Expr m a ) =
Expr m ( DropMaybe a )
reverseMapping ExprField k =
k ExprField
fieldMapping ExprField =
ExprField
binExpr :: Opaleye.BinOp -> Expr m a -> Expr m a -> Expr m b
binExpr op ( Expr a ) ( Expr b ) =

70
src/Rel8/HigherKindedTable.hs
View File

@ -77,9 +77,9 @@ data MyType f = MyType { fieldA :: Column f T }
-}
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
type HField t ( f :: Type -> Type ) = ( field :: Type -> Type ) | field -> t f
-- type HField t f =
-- GenericField t
-- | Like 'Constraintable', but for higher-kinded tables.
type HConstrainTable t ( f :: Type -> Type ) ( c :: Type -> Constraint ) :: Constraint
@ -87,36 +87,40 @@ class HigherKindedTable ( t :: ( Type -> Type ) -> Type ) where
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
hfield :: t f -> HField t f 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 )
=> proxy c
-> ( forall x. c x => HField t f 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 ) )
-- 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 ) )
adjustHField :: forall f g x. HField t f x -> HField t ( Reduce ( g f ) ) ( MapColumn g f x )
data TableHField t ( f :: Type -> Type ) x where
F :: HField t x -> TableHField t f x
F :: HField t f x -> TableHField t f x
-- | Any 'HigherKindedTable' is also a 'Table'.
@ -148,10 +152,12 @@ type family Reduce ( f :: * -> * ) :: ( * -> * ) where
Reduce ( Demote ( Expr ( Nest m ) ) ) = Expr m
instance ( HigherKindedTable t, HConstrainTable t ( Reduce ( g f ) ) Unconstrained, HConstrainTable t f Unconstrained ) => Recontextualise ( t f ) g where
type MapTable g ( t f ) = t ( Reduce ( g f ) )
fieldMapping ( F i ) = F i
reverseFieldMapping ( F i ) = F i
instance ( ContextTransformer g, HigherKindedTable t, HConstrainTable t ( Reduce ( g f ) ) Unconstrained, HConstrainTable t f Unconstrained ) => Recontextualise ( t f ) g where
type MapTable g ( t f ) =
t ( Reduce ( g f ) )
fieldMapping ( F i ) =
F ( adjustHField @t @f @g i )
data GenericField t a where
@ -257,10 +263,14 @@ instance ( Context a ~ f, Table a, Field a' ~ Field ( MapTable Structure a ), Re
ConstrainTable a c
k1field a ( K1False i ) =
field a ( fieldMapping @_ @Structure i )
reverseMapping @a @Structure i ( \j -> field a j )
k1tabulate proxy f =
tabulateMCP proxy ( f . K1False . reverseFieldMapping @_ @Structure )
tabulateMCP proxy ( f . K1False . fieldMapping @a @Structure )
data Spine a
instance ContextTransformer Structure where
type MapColumn Structure _ a = a

2
src/Rel8/Query.hs
View File

@ -180,7 +180,7 @@ writer into_ =
@( From Query )
( \i ->
traverseC \ColumnSchema{ columnName } -> do
f ( toPrimExpr . toColumn . flip field ( reverseFieldMapping @_ @( From Query ) i ) <$> xs
f ( toPrimExpr . toColumn . flip field ( fieldMapping @_ @( From Query ) i ) <$> xs
, columnName
)

63
src/Rel8/Table.hs
View File

@ -49,6 +49,8 @@ module Rel8.Table
, traverseCC
, zipCWithM
, zipCWithMC
, ContextTransformer(..)
) where
import Data.Functor.Compose
@ -163,12 +165,21 @@ class ConstrainTable t Unconstrained => Table ( t :: Type ) where
-> f t
class ( Table t, Table ( MapTable f t ) ) => Recontextualise ( t :: Type ) ( f :: ( Type -> Type ) -> Type -> Type ) where
type MapTable f t :: Type
class ContextTransformer ( t :: ( * -> * ) -> * -> * ) where
type MapColumn t ( f :: * -> * ) ( a :: * )
fieldMapping :: Field ( MapTable f t ) x -> Field t x
reverseFieldMapping :: Field t x -> Field ( MapTable f t ) x
class ( ContextTransformer f, Table t, Table ( MapTable f t ) ) => Recontextualise ( t :: Type ) ( f :: ( Type -> Type ) -> Type -> Type ) where
type MapTable f t :: *
reverseMapping
:: Field ( MapTable f t ) y
-> ( forall x. MapColumn f ( Context t ) x ~ y => Field t x -> r )
-> r
fieldMapping
:: Field t x
-> Field ( MapTable f t ) ( MapColumn f ( Context t ) x )
-- | Effectfully map a table from one context to another.
@ -179,12 +190,13 @@ traverseTableWithIndexC
, MapTable f t ~ t'
, Recontextualise t f
)
=> ( forall x. c x => Field t x -> C ( Context t ) x -> m ( C ( Context t' ) x ) )
=> ( forall x. c ( MapColumn f ( Context t ) x ) => Field t x -> C ( Context t ) x -> m ( C ( Context t' ) ( MapColumn f ( Context t ) x ) ) )
-> t
-> m t'
traverseTableWithIndexC f t =
tabulateMCP ( Proxy @c ) \index ->
f ( fieldMapping @_ @f index ) ( field t ( fieldMapping @_ @f index ) )
tabulateMCP
( Proxy @c )
( \index -> reverseMapping @t @f index ( \index' -> f index' ( field t index' ) ) )
data TupleField a b x where
@ -216,13 +228,11 @@ instance ( Context a ~ Context b, Context ( MapTable f a ) ~ Context ( MapTable
type MapTable f ( a, b ) =
( MapTable f a, MapTable f b )
fieldMapping = \case
Element1 i -> Element1 ( fieldMapping @a @f i )
Element2 i -> Element2 ( fieldMapping @b @f i )
reverseMapping ( Element1 i ) f = reverseMapping @a @f i ( \j -> f ( Element1 j ) )
reverseMapping ( Element2 i ) f = reverseMapping @b @f i ( \j -> f ( Element2 j ) )
reverseFieldMapping = \case
Element1 i -> Element1 ( reverseFieldMapping @a @f i )
Element2 i -> Element2 ( reverseFieldMapping @b @f i )
fieldMapping ( Element1 i ) = Element1 ( fieldMapping @_ @f i )
fieldMapping ( Element2 i ) = Element2 ( fieldMapping @_ @f i )
data SumField a x where
@ -249,12 +259,12 @@ instance Recontextualise a f => Recontextualise ( Sum a ) f where
type MapTable f ( Sum a ) =
Sum ( MapTable f a )
reverseMapping ( SumField i ) f =
reverseMapping @a @f i ( \j -> f ( SumField j ) )
fieldMapping ( SumField i ) =
SumField ( fieldMapping @_ @f i )
reverseFieldMapping ( SumField i ) =
SumField ( reverseFieldMapping @_ @f i )
-- | Map a 'Table' from one type to another. The table types must be compatible,
-- see 'Compatible' for what that means.
@ -263,7 +273,8 @@ mapTable
. ( MapTable f t ~ t'
, Recontextualise t f
)
=> ( forall x. C ( Context t ) x -> C ( Context t' ) x ) -> t -> t'
=> ( forall x. C ( Context t ) x -> C ( Context t' ) ( MapColumn f ( Context t ) x ) )
-> t -> t'
mapTable f =
runIdentity . traverseTable @f ( Identity . f )
@ -285,15 +296,18 @@ instance Table a => Table ( Identity a ) where
Identity <$> tabulateMCP proxy ( f . Compose . Identity )
instance ContextTransformer Id where
type MapColumn Id _ a = a
instance Table a => Recontextualise ( Identity a ) Id where
type MapTable Id ( Identity a ) =
Identity a
fieldMapping ( Compose ( Identity i ) ) =
Compose ( Identity i )
reverseMapping i k =
k i
reverseFieldMapping ( Compose ( Identity i ) ) =
Compose ( Identity i )
fieldMapping = id
-- | Map a 'Table' from one type to another, where all columns in the table are
@ -302,7 +316,8 @@ instance Table a => Recontextualise ( Identity a ) Id where
mapTableC
:: forall c f t' t
. ( ConstrainTable t' c, MapTable f t ~ t', Recontextualise t f )
=> ( forall x. c x => C ( Context t ) x -> C ( Context t' ) x ) -> t -> t'
=> ( forall x. c ( MapColumn f ( Context t ) x ) => C ( Context t ) x -> C ( Context t' ) ( MapColumn f ( Context t ) x ) )
-> t -> t'
mapTableC f =
runIdentity . traverseTableC @f @c ( Identity . f )
@ -312,7 +327,7 @@ mapTableC f =
traverseTable
:: forall f t' t m
. ( Applicative m, MapTable f t ~ t', Recontextualise t f )
=> ( forall x. C ( Context t ) x -> m ( C ( Context t' ) x ) )
=> ( forall x. C ( Context t ) x -> m ( C ( Context t' ) ( MapColumn f ( Context t ) x ) ) )
-> t
-> m t'
traverseTable f =
@ -329,7 +344,7 @@ traverseTable f =
traverseTableC
:: forall f c m t t'
. ( Applicative m, MapTable f t ~ t', ConstrainTable t' c, Recontextualise t f )
=> ( forall x. c x => C ( Context t ) x -> m ( C ( Context t' ) x ) )
=> ( forall x. c ( MapColumn f ( Context t ) x ) => C ( Context t ) x -> m ( C ( Context t' ) ( MapColumn f ( Context t ) x ) ) )
-> t
-> m t'
traverseTableC f =

3
src/Rel8/Tests.hs
View File

@ -13,7 +13,6 @@ import Data.Monoid
import Database.PostgreSQL.Simple ( Connection )
import GHC.Generics
import Rel8
import Rel8.Column
data Part f =
@ -264,7 +263,7 @@ select_maybeTable c =
select c maybeTableQ
catNullsTest :: MonadQuery m => m ( NotNull ( Expr m ) Int32 )
catNullsTest :: MonadQuery m => m ( Expr m Int32 )
catNullsTest =
catNulls ( nullId <$> each hasNull )