diff --git a/src/Rel8/Aggregate.hs b/src/Rel8/Aggregate.hs index a47581c..ab59673 100644 --- a/src/Rel8/Aggregate.hs +++ b/src/Rel8/Aggregate.hs @@ -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 diff --git a/src/Rel8/Expr.hs b/src/Rel8/Expr.hs index bdbc91c..da41a10 100644 --- a/src/Rel8/Expr.hs +++ b/src/Rel8/Expr.hs @@ -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 ) = diff --git a/src/Rel8/HigherKindedTable.hs b/src/Rel8/HigherKindedTable.hs index 1c0ab32..064b40e 100644 --- a/src/Rel8/HigherKindedTable.hs +++ b/src/Rel8/HigherKindedTable.hs @@ -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 diff --git a/src/Rel8/Query.hs b/src/Rel8/Query.hs index 4e17661..93bb78c 100644 --- a/src/Rel8/Query.hs +++ b/src/Rel8/Query.hs @@ -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 ) diff --git a/src/Rel8/Table.hs b/src/Rel8/Table.hs index f9bc7a1..3146dc4 100644 --- a/src/Rel8/Table.hs +++ b/src/Rel8/Table.hs @@ -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 = diff --git a/src/Rel8/Tests.hs b/src/Rel8/Tests.hs index dba6a94..4e4e908 100644 --- a/src/Rel8/Tests.hs +++ b/src/Rel8/Tests.hs @@ -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 )