Some ContextTransformer thingy

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
+  reverseMapping ( KeyFields i ) k = reverseMapping @k @f i ( k . KeyFields )
-    KeyFields i -> KeyFields ( reverseFieldMapping @_ @f i )
+  reverseMapping ( ValueFields i ) k = reverseMapping @v @f i ( k . ValueFields )
-    ValueFields i -> ValueFields ( reverseFieldMapping @_ @f i )
 
 
 instance ( Context v ~ Expr m, Table k, Context k ~ Expr m, MonoidTable v ) => MonoidTable ( GroupBy k v ) where

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
+  reverseMapping ExprField k =
-  reverseFieldMapping ExprField = ExprField
+    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
+  type MapTable Id ( Expr m a ) =
-  fieldMapping ExprField = ExprField
+    Expr m a
-  reverseFieldMapping ExprField = ExprField
+
+  reverseMapping ExprField k =
+    k ExprField
+
+  fieldMapping ExprField =
+    ExprField
 
 
 instance Recontextualise ( Expr m a ) Null where
-  type MapTable Null ( Expr m a ) = Expr m a
+  type MapTable Null ( Expr m a ) =
-  fieldMapping ExprField = ExprField
+    Expr m ( Maybe ( DropMaybe a ) )
-  reverseFieldMapping ExprField = ExprField
+
+  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 ) =

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 ( f :: Type -> Type ) = ( field :: Type -> Type ) | field -> t f
-  type HField t =
+  -- type HField t f =
-    GenericField t
+  --   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
+  hfield :: t f -> HField t f x -> C f x
-  default hfield
+  -- default hfield
-    :: forall f x
+  --   :: forall f x
-     . ( Generic ( t f )
+  --    . ( Generic ( t f )
-       , HField t ~ GenericField t
+  --      , HField t ~ GenericField t
-       , GHigherKindedTable ( Rep ( t f ) ) t f ( Rep ( t Spine ) )
+  --      , GHigherKindedTable ( Rep ( t f ) ) t f ( Rep ( t Spine ) )
-       )
+  --      )
-    => t f -> HField t x -> C f x
+  --   => t f -> HField t x -> C f x
-  hfield x ( GenericField i ) =
+  -- hfield x ( GenericField i ) =
-    ghfield @( Rep ( t f ) ) @t @f @( Rep ( t Spine ) ) ( from x ) 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
+  -- default htabulate
-    :: forall f m c proxy
+  --   :: forall f m c proxy
-     . ( Applicative m, GHConstrainTable ( Rep ( t f ) ) ( Rep ( t Spine ) ) c, Generic ( t f )
+  --    . ( Applicative m, GHConstrainTable ( Rep ( t f ) ) ( Rep ( t Spine ) ) c, Generic ( t f )
-       , GHigherKindedTable ( Rep ( t f ) ) t f ( Rep ( t Spine ) )
+  --      , GHigherKindedTable ( Rep ( t f ) ) t f ( Rep ( t Spine ) )
-       , HField t ~ GenericField t
+  --      , HField t ~ GenericField t
-       )
+  --      )
-    => proxy c -> ( forall x. c x => HField t x -> m ( C f x ) ) -> m ( t f )
+  --   => proxy c -> ( forall x. c x => HField t x -> m ( C f x ) ) -> m ( t f )
-  htabulate proxy f =
+  -- htabulate proxy f =
-    fmap to ( ghtabulate @( Rep ( t f ) ) @t @f @( Rep ( t Spine ) ) proxy ( f . GenericField ) )
+  --   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
+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 ) )
+  type MapTable g ( t f ) =
-  fieldMapping ( F i ) = F i
+    t ( Reduce ( g f ) )
-  reverseFieldMapping ( F i ) = F i
+
+  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

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
                     )
 

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
+class ContextTransformer ( t :: ( * -> * ) -> * -> * ) where
-  type MapTable f t :: Type
+  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 ->
+  tabulateMCP
-    f ( fieldMapping @_ @f index ) ( field t ( fieldMapping @_ @f index ) )
+    ( 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
+  reverseMapping ( Element1 i ) f = reverseMapping @a @f i ( \j -> f ( Element1 j ) )
-    Element1 i -> Element1 ( fieldMapping @a @f i )
+  reverseMapping ( Element2 i ) f = reverseMapping @b @f i ( \j -> f ( Element2 j ) )
-    Element2 i -> Element2 ( fieldMapping @b @f i )
 
-  reverseFieldMapping = \case
+  fieldMapping ( Element1 i ) = Element1 ( fieldMapping @_ @f i )
-    Element1 i -> Element1 ( reverseFieldMapping @a @f i )
+  fieldMapping ( Element2 i ) = Element2 ( fieldMapping @_ @f i )
-    Element2 i -> Element2 ( reverseFieldMapping @b @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 ) ) =
+  reverseMapping i k =
-    Compose ( Identity i )
+    k i
 
-  reverseFieldMapping ( Compose ( Identity i ) ) =
+  fieldMapping = id
-    Compose ( Identity i )
 
 
 -- | 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 =

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 )