Yet another version

Another.hs

@@ -0,0 +1,211 @@
+{-# language BlockArguments #-}
+{-# language ConstraintKinds #-}
+{-# language DataKinds #-}
+{-# language DerivingVia #-}
+{-# language FlexibleContexts #-}
+{-# language FlexibleInstances #-}
+{-# language FunctionalDependencies #-}
+{-# language GADTs #-}
+{-# language InstanceSigs #-}
+{-# language KindSignatures #-}
+{-# language LambdaCase #-}
+{-# language NamedFieldPuns #-}
+{-# language RankNTypes #-}
+{-# language ScopedTypeVariables #-}
+{-# language StandaloneDeriving #-}
+{-# language TypeApplications #-}
+{-# language TypeFamilies #-}
+{-# language TypeFamilyDependencies #-}
+{-# language UndecidableInstances #-}
+{-# language UndecidableSuperClasses #-}
+
+{-# options -Wno-implicit-prelude -Wno-missing-export-lists -Wno-missing-import-lists #-}
+
+module Another where
+
+import Prelude hiding (null)
+import Control.Applicative (liftA2)
+import Data.Functor.Identity (Identity)
+import Data.Kind (Constraint, Type)
+import Database.PostgreSQL.Simple.FromField (FieldParser)
+import Database.PostgreSQL.Simple.FromRow (RowParser, fieldWith, field)
+import qualified Opaleye.Internal.Column as O
+import qualified Opaleye.Internal.HaskellDB.PrimQuery as O
+import qualified Opaleye.Internal.RunQuery as O
+import qualified Opaleye as O
+import Data.Profunctor.Product.Default (Default)
+import Data.Proxy ( Proxy( Proxy ) )
+
+type family Column (f :: Type -> Type) (a :: Type) :: Type where
+  Column Identity a = a
+  Column f a = f a
+
+newtype C f a = C { toColumn :: Column f a }
+
+data Witness (c :: Type -> Constraint) (a :: Type) where
+  Witness :: c a => Witness c a
+
+class DBType (a :: Type) where
+  typeInformation :: TypeInformation a
+
+data TypeInformation a = TypeInformation
+  { encode :: a -> O.PrimExpr
+  , decode :: FieldParser a
+  }
+
+mapTypeInformation :: (a -> b) -> (b -> a) -> TypeInformation a -> TypeInformation b
+mapTypeInformation f g TypeInformation{ encode, decode } = TypeInformation
+  { encode = encode . g
+  , decode = \x y -> f <$> decode x y
+  }
+
+newtype OpaleyeDBType sql a = OpaleyeDBType a
+
+instance (O.DefaultFromField sql a, Default O.ToFields a (O.Column sql)) => DBType (OpaleyeDBType sql a) where
+  typeInformation = TypeInformation
+    { encode = \(OpaleyeDBType x) -> 
+        case O.toFields @a @(O.Column sql) x of
+          O.Column primExpr -> primExpr
+    , decode = \x y -> 
+        case O.defaultFromField @sql @a of
+          O.QueryRunnerColumn _ fieldParser -> OpaleyeDBType <$> fieldParser x y
+    }
+
+deriving via OpaleyeDBType O.SqlBool Bool instance DBType Bool
+deriving via OpaleyeDBType O.SqlInt4 Int instance DBType Int
+
+instance DBType ()  where
+  typeInformation = TypeInformation
+    { encode = \_ -> O.ConstExpr O.NullLit
+    , decode = \_ _ -> return ()
+    }
+
+instance DBType a => DBType (Maybe a) where
+  typeInformation = TypeInformation
+    { encode = maybe null (encode typeInformation)
+    , decode = \x y ->
+        case y of
+          Nothing -> return Nothing
+          Just _  -> decode typeInformation x y
+    }
+
+class AllFields t DBType => HigherKindedTable (t :: (Type -> Type) -> Type) where
+  type HField t = (i :: Type -> Type) | i -> t
+  type AllFields t (c :: Type -> Constraint) :: Constraint
+
+  hindex :: t f -> HField t a -> C f a
+  htabulate :: (forall x. HField t x -> C f x) -> t f
+  htraverse :: Applicative m => (forall x. C f x -> m (C g x)) -> t f -> m (t g)
+  hdicts :: forall (c :: Type -> Constraint). AllFields t c => t (Witness c)
+
+class HigherKindedTable (Schema t) => Table (t :: Type) where
+  type Schema t :: ((Type -> Type) -> Type)
+  type Context t :: Type -> Type
+
+  fromColumns :: Schema t (Context t) -> t
+  toColumns :: t -> Schema t (Context t)
+
+instance HigherKindedTable f => Table (f g) where
+  type Schema (f g) = f
+  type Context (f g) = g
+  toColumns = id
+  fromColumns = id
+
+newtype Expr a = Expr { toPrimExpr :: O.PrimExpr }
+
+unsafeCoerceExpr :: Expr a -> Expr b
+unsafeCoerceExpr (Expr a) = Expr a
+
+data MaybeTable t = MaybeTable (Expr (Maybe ())) t
+
+class SerializationMethod expr haskell => Serializable expr haskell | expr -> haskell, haskell -> expr where
+
+instance SerializationMethod expr haskell => Serializable expr haskell 
+
+type family ResultType (expr :: Type) :: Type where
+  ResultType (MaybeTable t) = Maybe (ResultType t)
+  ResultType (t Expr)       = t Identity
+  ResultType (a, b)         = (ResultType a, ResultType b)
+  ResultType (Expr a)       = a
+
+type family ExprType (haskell :: Type) :: Type where
+  ExprType (Maybe (t Identity))    = MaybeTable (t Expr)
+  ExprType (Maybe a)               = Expr (Maybe a)
+  ExprType (t Identity)            = t Expr
+  ExprType (a, b)                  = (ExprType a, ExprType b)
+  ExprType a                       = Expr a
+
+class (haskell ~ ResultType expr, expr ~ ExprType haskell) => SerializationMethod (expr :: Type) (haskell :: Type) where
+  rowParser :: RowParser haskell
+  lit :: haskell -> expr
+
+instance (DBType a, a ~ b, ExprType b ~ Expr a) => SerializationMethod (Expr (a :: Type)) (b :: Type) where
+  rowParser = fieldWith (decode (typeInformation @a))
+  lit = Expr . encode (typeInformation @a)
+
+instance (HigherKindedTable s, s ~ t) => SerializationMethod (s Expr) (t Identity) where
+  rowParser = htraverse f $ htabulate @s \i -> g (hindex hdicts i) 
+    where
+      f :: C RowParser x -> RowParser (C Identity x)
+      f (C x) = C <$> x
+
+      g :: forall a. C (Witness DBType) a -> C RowParser a
+      g (C Witness) = C $ fieldWith $ decode $ typeInformation @a
+
+  lit t = htabulate \i -> f (hindex hdicts i) (hindex t i) 
+    where
+      f :: forall x. C (Witness DBType) x -> C Identity x -> C Expr x
+      f (C Witness) (C a) = C $ Expr $ encode (typeInformation @x) a
+
+instance (SerializationMethod a1 b1, SerializationMethod a2 b2, a1 ~ ExprType b1, a2 ~ ExprType b2, b1 ~ ResultType a1, b2 ~ ResultType a2) => SerializationMethod (a1, a2) (b1, b2) where
+  rowParser = liftA2 (,) rowParser rowParser
+  lit (a, b) = (lit a, lit b)
+
+instance (Serializable s t, Table s, Context s ~ Expr, MaybeTable s ~ ExprType (Maybe t), ResultType s ~ t) => SerializationMethod (MaybeTable s) (Maybe t) where
+  rowParser = do
+    nullTag <- field
+    case nullTag of
+      Just ()   -> Just <$> rowParser
+      Nothing   -> Nothing <$ htraverse @(Schema s) (\x -> x <$ fieldWith (\_ _ -> pure ())) (htabulate @_ @Proxy \_ -> C Proxy)
+
+  lit Nothing = MaybeTable nullUnit $ fromColumns $ htabulate \_ -> C $ unsafeCoerceExpr nullUnit
+    where
+      nullUnit :: Expr (Maybe ())
+      nullUnit = lit Nothing
+
+  lit (Just a) = MaybeTable (lit (Just ())) (lit a)
+
+null :: O.PrimExpr
+null = O.ConstExpr O.NullLit
+
+--
+
+data One f = One { oneA :: Column f Int }
+
+data OneField :: Type -> Type where
+  OneA :: OneField Int
+
+instance HigherKindedTable One where
+  type HField One = OneField
+  type AllFields One c = (c Int)
+
+  hindex One{ oneA } = \case
+    OneA -> C oneA
+
+  htabulate f = One { oneA = toColumn $ f OneA }
+
+  hdicts = One Witness
+
+  htraverse :: forall m f g. Applicative m => (forall x. C f x -> m (C g x)) -> One f -> m (One g)
+  htraverse f One{ oneA } = fmap (\(C oneA') -> One oneA') $ f (C oneA :: C f Int)
+
+
+-- TODO Get this to infer!
+-- thing :: _
+-- thing = lit (Just $ (One 42))
+
+thing :: MaybeTable (One Expr)
+thing = lit (Just $ (One 42 :: One Identity))
+
+-- thing2 :: MaybeTable (One Expr)
+-- thing2 = lit (Just _)

shell.nix

@@ -1,5 +1,5 @@
 let
-  hsPkgs = import ./default.nix {};
+  hsPkgs = import ./default.nix;
 in
   hsPkgs.shellFor {
     withHoogle = true;

src/Rel8.hs

@@ -39,7 +39,6 @@ module Rel8
 
     -- ** Expressions
   , Expr
-  , Context
   , coerceExpr
   , unsafeCoerceExpr
 
@@ -86,11 +85,7 @@ module Rel8
   , update
   , Update(..)
 
-    -- * Common Table Subtypes
+    -- * TOOD
-  , IsTableIn
-  , Selects
-
-    -- TODO
   , ExprType
 
     -- * Next Steps
@@ -107,7 +102,6 @@ import Rel8.DBEq
 import Rel8.EqTable
 import Rel8.Expr
 import Rel8.Query
-import Rel8.SimpleConstraints
 import Rel8.TableSchema
 
 {- $nextSteps

src/Rel8/Core.hs

@@ -48,6 +48,7 @@ import Data.Typeable ( Typeable )
 import Data.UUID ( UUID )
 import Database.PostgreSQL.Simple.FromField ( FromField, FieldParser, fromField, optionalField, returnError, ResultError( Incompatible ) )
 import Database.PostgreSQL.Simple.FromRow ( RowParser, fieldWith )
+import Data.Functor.Compose ( Compose(..) )
 import GHC.Generics hiding ( C )
 import qualified Opaleye.Internal.Column as Opaleye
 import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
@@ -102,19 +103,21 @@ data MyType f = MyType { fieldA :: Column f T }
 @
 
 -}
-class HigherKindedTable ( t :: ( Type -> Type ) -> Type ) where
+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 = (field :: Type -> Type) | field -> t
-  type HField t =
+  type HField t = GenericField t
-    GenericField t
 
   -- | Like 'Constraintable', but for higher-kinded tables.
-  type HConstrainTable t ( f :: Type -> Type ) ( c :: Type -> Constraint ) :: Constraint
+  type HConstrainTable t (f :: Type -> Type) (c :: Type -> Constraint) :: Constraint
-  type HConstrainTable t f c =
+  type HConstrainTable t f c = GHConstrainTable (Rep (t f)) (Rep (t SPINE)) c
-    GHConstrainTable ( Rep ( t f ) ) ( Rep ( t SPINE ) ) c
+
+  hfield :: t f -> HField t x -> C f x
+  htabulate :: ( forall x. c x => HField t x -> C f x ) -> t f
+  htraverse :: Applicative m => (forall x. C f x -> m (C g x)) -> t f -> m (t g)
+  hdicts :: forall f c. HConstrainTable t f c => t (Dict 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 )
@@ -126,50 +129,49 @@ class HigherKindedTable ( t :: ( Type -> Type ) -> Type ) where
     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
+  -- default htabulate
-    :: forall f m c proxy
+  --   :: forall f
-     . ( 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 )
+  --   => ( forall x. c x => HField t x -> C f x ) -> 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 ) )
 
 
+data Dict c a where
+  Dict :: c a => Dict c a
+
 
 data TableHField t ( f :: Type -> Type ) x where
   F :: HField t x -> TableHField t f x
 
 
 -- | Any 'HigherKindedTable' is also a 'Table'.
-instance HigherKindedTable t => Table (t f) where
+instance (HigherKindedTable t, f ~ g) => Table f (t g) where
-  type Structure (t f) = t
+  type Columns (t g) = t
-  type Context (t f) = f
+  toColumns = id
-  toStructure = id
+  fromColumns = id
-  fromStructure = id
 
 
 data GenericField t a where
-  GenericField :: GHField t ( Rep ( t SPINE ) ) a -> GenericField t a
+  GenericField :: GHField t (Rep (t SPINE)) a -> GenericField t a
 
 
-class GHigherKindedTable ( rep :: Type -> Type ) ( t :: ( Type -> Type ) -> Type ) ( f :: Type -> Type ) ( repIdentity :: Type -> Type ) where
+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
+  -- ghtabulate
-    :: ( Applicative m, GHConstrainTable rep repIdentity c )
+  --   :: ( Applicative m, GHConstrainTable rep repIdentity c )
-    => proxy c
+  --   => proxy c
-    -> ( forall x. c x => GHField t repIdentity x -> m ( C f x ) )
+  --   -> ( forall x. c x => GHField t repIdentity x -> m ( C f x ) )
-    -> m ( rep a )
+  --   -> m ( rep a )
 
 
 instance GHigherKindedTable x t f x' => GHigherKindedTable ( M1 i c x ) t f ( M1 i' c' x' ) where
@@ -182,8 +184,8 @@ instance GHigherKindedTable x t f x' => GHigherKindedTable ( M1 i c x ) t f ( M1
   ghfield ( M1 a ) ( M1Field i ) =
     ghfield a i
 
-  ghtabulate proxy f =
+--   ghtabulate proxy f =
-    M1 <$> ghtabulate @x @t @f @x' proxy ( f . M1Field )
+--     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
@@ -198,9 +200,9 @@ instance ( GHigherKindedTable x t f x', GHigherKindedTable y t f y' ) => GHigher
     FieldL i -> ghfield x i
     FieldR i -> ghfield y i
 
-  ghtabulate proxy f =
+--   ghtabulate proxy f =
-    (:*:) <$> ghtabulate @x @t @f @x' proxy ( f . FieldL )
+--     (:*:) <$> ghtabulate @x @t @f @x' proxy ( f . FieldL )
-          <*> ghtabulate @y @t @f @y' proxy ( f . FieldR )
+--           <*> ghtabulate @y @t @f @y' proxy ( f . FieldR )
 
 
 type family IsColumnApplication ( a :: Type ) :: Bool where
@@ -219,8 +221,8 @@ instance DispatchK1 ( IsColumnApplication c' ) f c c' => GHigherKindedTable ( K1
   ghfield ( K1 a ) ( K1Field i ) =
     k1field @( IsColumnApplication c' ) @f @c @c' a i
 
-  ghtabulate proxy f =
+--   ghtabulate proxy f =
-    K1 <$> k1tabulate @( IsColumnApplication c' ) @f @c @c' proxy ( f . K1Field )
+--     K1 <$> k1tabulate @( IsColumnApplication c' ) @f @c @c' proxy ( f . K1Field )
 
 
 class DispatchK1 ( isSPINE :: Bool ) f a a' where
@@ -230,9 +232,9 @@ class DispatchK1 ( isSPINE :: Bool ) f a a' where
 
   k1field :: a -> K1Field isSPINE a' x -> C f x
 
-  k1tabulate
+--   k1tabulate
-    :: ( ConstrainK1 isSPINE a a' c, Applicative m )
+--     :: ( ConstrainK1 isSPINE a a' c, Applicative m )
-    => proxy c -> ( forall x. c x => K1Field isSPINE a' x -> m ( C f x ) ) -> m a
+--     => 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
@@ -245,8 +247,8 @@ instance (a ~ Column f b) => DispatchK1 'True f a ( SPINE b ) where
   k1field a K1True =
     MkC a
 
-  k1tabulate _ f =
+--   k1tabulate _ f =
-    toColumn <$> f @b K1True
+--     toColumn <$> f @b K1True
 
 
 data SPINE a
@@ -259,25 +261,11 @@ writing higher-kinded data types is usually more convenient. See also:
 'HigherKindedTable'.
 
 -}
-class HigherKindedTable (Structure t) => Table (t :: Type) where
+class HigherKindedTable (Columns t) => Table (context :: Type -> Type) (t :: Type) | t -> context where
-  type Structure t :: (Type -> Type) -> Type
+  type Columns t :: (Type -> Type) -> Type
-  type Context t :: Type -> Type
 
-  toStructure :: t -> Structure t (Context t)
+  toColumns :: t -> Columns t context
-  fromStructure :: Structure t (Context t) -> t
+  fromColumns :: Columns t context -> t
-
-
-
--- | Effectfully map a table from one context to another.
-traverseTableWithIndexC
-  :: forall c t t' m
-   . (Applicative m, Table t, Table t', HConstrainTable (Structure t') (Context t') c, Structure t ~ Structure t')
-  => (forall x. c x => HField (Structure t) x -> C (Context t) x -> m (C (Context t') x))
-  -> t
-  -> m t'
-traverseTableWithIndexC f t =
-  fmap fromStructure $
-  htabulate (Proxy @c) \index -> f index (hfield (toStructure t) index)
 
 
 data HPair x y (f :: Type -> Type) = HPair { hfst :: x f, hsnd :: y f }
@@ -287,107 +275,38 @@ data HPair x y (f :: Type -> Type) = HPair { hfst :: x f, hsnd :: y f }
 deriving instance (HigherKindedTable x, HigherKindedTable y) => HigherKindedTable (HPair x y)
 
 
-instance (Table a, Table b, Context a ~ Context b) => Table (a, b) where
+instance (Table f a, Table f b) => Table f (a, b) where
-  type Structure (a, b) = HPair (Structure a) (Structure b)
+  type Columns (a, b) = HPair (Columns a) (Columns b)
-  type Context (a, b) = Context a
+  toColumns (a, b) = HPair (toColumns a) (toColumns b)
-  toStructure (a, b) = HPair (toStructure a) (toStructure b)
+  fromColumns (HPair x y) = (fromColumns x, fromColumns y)
-  fromStructure (HPair x y) = (fromStructure x, fromStructure y)
 
 
--- | Map a 'Table' from one type to another. The table types must be compatible,
+instance (Table f a, Columns a ~ Columns a') => DispatchK1 'False f a a' where
--- see 'Compatible' for what that means.
-mapTable
-  :: forall t' t
-   . (Table t, Table t', Structure t ~ Structure t', HConstrainTable (Structure t) (Context t') Unconstrained)
-  => (forall x. C (Context t) x -> C (Context t') x) -> t -> t'
-mapTable f = runIdentity . traverseTable (Identity . f)
-
-
--- | Map a 'Table' from one type to another, where all columns in the table are
--- subject to a constraint.
-mapTableC
-  :: forall c t' t
-   . (Table t, Table t', Structure t ~ Structure t', HConstrainTable (Structure t) (Context t') c)
-  => (forall x. c x => C (Context t) x -> C (Context t') x)
-  -> t -> t'
-mapTableC f =
-  runIdentity . traverseTableC @c ( Identity . f )
-
-
--- | Effectfully traverse all fields in a 'Table', potentially producing another
--- @Table@.
-traverseTable
-  :: forall t' t m
-   . (Applicative m, Table t, Table t', Structure t ~ Structure t', HConstrainTable (Structure t) (Context t') Unconstrained)
-  => (forall x. C (Context t) x -> m (C (Context t') x))
-  -> t
-  -> m t'
-traverseTable f =
-  traverseTableWithIndexC @Unconstrained (const f)
-
-
--- | Effectfully traverse all fields in a 'Table', provided that all fields
--- satisfy a given constraint. For example, if all fields in a table have an
--- instance for 'Read', we can apply 'readMaybe' to all fields in the table,
--- failing if any read fails:
---
--- >>> traverseTableC @Read ( traverseC readMaybe ) MyTable{ fieldA = "True" }
--- Just MyTable{ fieldA = True }
-traverseTableC
-  :: forall c m t t'
-   . (Table t, Table t', Applicative m, Structure t ~ Structure t', HConstrainTable (Structure t) (Context t') c)
-  => (forall x. c x => C (Context t) x -> m (C (Context t') x))
-  -> t
-  -> m t'
-traverseTableC f =
-  traverseTableWithIndexC @c (const f)
-
-
-zipTablesWithM
-  :: forall t m
-   . ( Applicative m
-     , Table t
-     , HConstrainTable (Structure t) (Context t) Unconstrained
-     )
-  => ( forall x. C ( Context t ) x -> C ( Context t ) x -> m ( C ( Context t ) x ) )
-  -> t -> t -> m t
-zipTablesWithM f t t' =
-  fmap fromStructure $
-  htabulate (Proxy @Unconstrained) \index ->
-    f (hfield (toStructure t) index) (hfield (toStructure t') index)
-
-
-instance (Context a ~ f, Table a, Structure a ~ Structure a') => DispatchK1 'False f a a' where
   data K1Field 'False a' x where
-    K1False :: HField (Structure a') x -> K1Field 'False a' x
+    K1False :: HField (Columns a') x -> K1Field 'False a' x
 
-  type ConstrainK1 'False a a' c =
+  -- type ConstrainK1 'False a a' c =
-    HConstrainTable (Structure a) (Context a) c
+  --   HConstrainTable (Columns a) (Context a) c
 
   k1field a (K1False i) =
-    hfield (toStructure a) i
+    hfield (toColumns a) i
 
-  k1tabulate proxy f =
+-- --   k1tabulate proxy f =
-    fromStructure <$> htabulate proxy (f . K1False)
+-- --     fromColumns <$> htabulate proxy (f . K1False)
 
 
 newtype HIdentity a f = HIdentity { unHIdentity :: Column f a }
   deriving ( Generic, HigherKindedTable )
 
 
--- | Any 'Identity' can be seen as a 'Table' with only one column.
-instance Table (Identity a) where
-  type Context (Identity a) = Identity
-  type Structure (Identity a) = HIdentity a
-  toStructure = HIdentity . runIdentity
-  fromStructure = Identity . unHIdentity
-
-
 -- | @Serializable@ witnesses the one-to-one correspondence between the type @sql@,
 -- which contains SQL expressions, and the type @haskell@, which contains the
 -- Haskell decoding of rows containing @sql@ SQL expressions.
-class (ExprTable sql, SerializableChoice sql haskell) => Serializable sql haskell | sql -> haskell, haskell -> sql where
+class SerializationMethod sql haskell => Serializable sql haskell | sql -> haskell, haskell -> sql where
-instance (ExprTable a, SerializableChoice a b) => Serializable a b where
+  lit2 :: haskell -> sql
+
+instance SerializationMethod a b => Serializable a b where
+  lit2 = lit
 
 
 type family ExprType (a :: Type) :: Type where
@@ -405,58 +324,63 @@ type family ResultType (a :: Type) :: Type where
   ResultType (MaybeTable a) = Maybe (ResultType a)
 
 
-class (ExprTable a, a ~ ExprType b, b ~ ResultType a) => SerializableChoice (a :: Type) (b :: Type) where
+class (Table Expr expr, expr ~ ExprType haskell, haskell ~ ResultType expr) => SerializationMethod (expr :: Type) (haskell :: Type) where
-  rowParser :: a -> RowParser b
+  rowParser :: RowParser haskell
-  lit :: b -> a
+  lit :: haskell -> expr
 
 
 -- | Any higher-kinded records can be @SELECT@ed, as long as we know how to
 -- decode all of the records constituent part's.
-instance (expr ~ Expr, identity ~ Identity, ExprTable (t expr), Table (t identity), HConstrainTable t Identity DBType) => SerializableChoice ( t expr ) ( t identity ) where
+instance (s ~ t, expr ~ Expr, identity ~ Identity, HigherKindedTable t, HConstrainTable t Identity DBType) => SerializationMethod (s expr) (t identity) where
-  rowParser =
+--   rowParser _ = htraverse f $ htabulate @t \i -> g (hfield hdicts i) 
-    traverseTableC @DBType ( traverseCC @DBType \_ -> fieldWith ( decode typeInformation ) )
+--     where
+--       f :: C RowParser x -> RowParser (C Identity x)
+--       f (MkC x) = MkC <$> x
 
-  lit =
+--       g :: forall a. C (Dict DBType) a -> C RowParser a
-    runIdentity . mapContext (Proxy @Lit) (Proxy @DBType) (Identity . mapCC @DBType lit)
+--       g (MkC Dict) = MkC $ fieldWith $ decode $ typeInformation @a
 
+  lit t = 
+    fromColumns $ htabulate \i ->
+      case (hfield (hdicts @t @Identity @DBType) i, hfield t i) of
+        (MkC Dict, MkC x) -> MkC $ lit2 x -- mapCC @DBType lit x
 
-instance DBType a => SerializableChoice (Expr a) a where
+instance (DBType a, a ~ b) => SerializationMethod (Expr a) b where
-  rowParser _ = fieldWith (decode typeInformation)
+  rowParser = fieldWith (decode typeInformation)
 
   lit = Expr . Opaleye.CastExpr typeName . encode
     where
       DatabaseType{ encode, typeName } = typeInformation
 
 
-instance (Serializable a1 b1, Serializable a2 b2) => SerializableChoice (a1, a2) (b1, b2) where
+instance (Serializable a1 b1, Serializable a2 b2) => SerializationMethod (a1, a2) (b1, b2) where
-  rowParser (a, b) =
+  rowParser = liftA2 (,) rowParser rowParser
-    liftA2 (,) (rowParser a) (rowParser b)
 
   lit (a, b) = (lit a, lit b)
 
 
-instance
+-- instance
-  ( Context a ~ Expr
+--   ( Context a ~ Expr
-  , Table a
+--   , Table a
-  , HConstrainTable (Structure a) Expr Unconstrained
+--   , HConstrainTable (Structure a) Expr Unconstrained
-  , HConstrainTable (Structure a) Expr DBType
+--   , HConstrainTable (Structure a) Expr DBType
-  , Serializable a b
+--   , Serializable a b
-  , ExprType (Maybe b) ~ MaybeTable a
+--   , ExprType (Maybe b) ~ MaybeTable a
-  ) => SerializableChoice (MaybeTable a) (Maybe b) where
+--   ) => SerializationMethod (MaybeTable a) (Maybe b) where
 
-  rowParser ( MaybeTable _ t ) = do
+--   rowParser ( MaybeTable _ t ) = do
-    rowExists <- fieldWith ( decode typeInformation )
+--     rowExists <- fieldWith ( decode typeInformation )
 
-    case rowExists of
+--     case rowExists of
-      Just True ->
+--       Just True ->
-        Just <$> rowParser t
+--         Just <$> rowParser t
 
-      _ ->
+--       _ ->
-        Nothing <$ traverseTableC @DBType @RowParser @_ @a nullField t
+--         Nothing <$ traverseTableC @DBType @RowParser @_ @a nullField t
 
-  lit = \case
+--   lit = \case
-    Nothing -> noTable
+--     Nothing -> noTable
-    Just x -> pure (lit x)
+--     Just x -> pure (lit x)
 
 
 nullField :: forall x f. C f x -> RowParser ( C f x )
@@ -464,8 +388,7 @@ nullField x = x <$ fieldWith (\_ _ -> pure ())
 
 
 -- | Typed SQL expressions
-newtype Expr ( a :: Type ) =
+newtype Expr (a :: Type) = Expr { toPrimExpr :: Opaleye.PrimExpr }
-  Expr { toPrimExpr :: Opaleye.PrimExpr }
 
 
 type role Expr representational
@@ -476,8 +399,8 @@ instance ( IsString a, DBType a ) => IsString ( Expr a ) where
     lit . fromString
 
 
-class (HConstrainTable (Structure a) Expr Unconstrained, Table a, Context a ~ Expr, HConstrainTable (Structure a) Expr DBType) => ExprTable a
+-- class (HConstrainTable (Structure a) Expr Unconstrained, Table a, Context a ~ Expr, HConstrainTable (Structure a) Expr DBType) => Table Expr a
-instance (HConstrainTable (Structure a) Expr Unconstrained, Table a, Context a ~ Expr, HConstrainTable (Structure a) Expr DBType) => ExprTable a
+-- instance (HConstrainTable (Structure a) Expr Unconstrained, Table a, Context a ~ Expr, HConstrainTable (Structure a) Expr DBType) => Table Expr a
 
 
 {-| @MaybeTable t@ is the table @t@, but as the result of an outer join. If the
@@ -518,51 +441,51 @@ instance Monad MaybeTable where
         null_ (lit False) (\x' -> null_ (lit False) (\y' -> x' ||. y') y) x
 
 
-data HMaybeTable g f =
+-- data HMaybeTable g f =
-  HMaybeTable
+--   HMaybeTable
-    { hnullTag :: Column f (Maybe Bool)
+--     { hnullTag :: Column f (Maybe Bool)
-    , hcontents :: g f
+--     , hcontents :: g f
-    }
+--     }
-  deriving
+--   deriving
-    (Generic)
+--     (Generic)
 
 
-deriving instance (forall f. Table (g f)) => HigherKindedTable (HMaybeTable g)
+-- deriving instance (forall f. Table (g f)) => HigherKindedTable (HMaybeTable g)
 
 
-instance (ExprTable a, HigherKindedTable (Structure a)) => Table (MaybeTable a) where
+-- instance (Table Expr a, HigherKindedTable (Structure a)) => Table (MaybeTable a) where
-  type Structure (MaybeTable a) = HMaybeTable (Structure a)
+--   type Structure (MaybeTable a) = HMaybeTable (Structure a)
-  type Context (MaybeTable a) = Expr
+--   type Context (MaybeTable a) = Expr
 
-  toStructure (MaybeTable x y) = HMaybeTable x (toStructure y)
+--   toStructure (MaybeTable x y) = HMaybeTable x (toStructure y)
-  fromStructure (HMaybeTable x y) = MaybeTable x (fromStructure y)
+--   fromColumns (HMaybeTable x y) = MaybeTable x (fromColumns y)
 
 
 maybeTable
-  :: ExprTable b
+  :: Table Expr b
   => b -> (a -> b) -> MaybeTable a -> b
 maybeTable def f MaybeTable{ nullTag, table } =
   ifThenElse_ (null_ (lit False) id nullTag) (f table) def
 
 
-noTable :: forall a. ExprTable a => MaybeTable a
+noTable :: forall a. Table Expr a => MaybeTable a
-noTable = MaybeTable tag t
+noTable = undefined
-  where
+-- noTable = MaybeTable tag t
-    tag :: Expr (Maybe Bool)
+--   where
-    tag = lit (Nothing :: Maybe Bool)
+--     tag :: Expr (Maybe Bool)
+--     tag = lit (Nothing :: Maybe Bool)
 
-    t :: a
+--     t :: a
-    t = fromStructure $ runIdentity $ htabulate (Proxy @DBType) f
+--     t = fromColumns $ runIdentity $ htabulate (Proxy @DBType) f
-      where
+--       where
-        f :: forall x i. DBType x => i x -> Identity (C Expr x)
+--         f :: forall x i. DBType x => i x -> Identity (C Expr x)
-        f _ = pure $ MkC $ unsafeCoerceExpr (lit (Nothing :: Maybe x) :: Expr (Maybe x))
+--         f _ = pure $ MkC $ unsafeCoerceExpr (lit (Nothing :: Maybe x) :: Expr (Maybe x))
 
 
-instance Table (Expr a) where
+instance expr ~ Expr => Table expr (Expr a) where
-  type Context (Expr a) = Expr
+  type Columns (Expr a) = HIdentity a
-  type Structure (Expr a) = HIdentity a
+  toColumns = HIdentity
-  toStructure = HIdentity
+  fromColumns = unHIdentity
-  fromStructure = unHIdentity
 
 
 {-| Haskell types that can be represented as expressiosn in a database. There
@@ -588,7 +511,7 @@ just used integers (the type distinction does not impact query generation).
 
 -}
 
-class (ExprType a ~ Expr a, ResultType (Expr a) ~ a, ExprType (Maybe a) ~ Expr (Maybe a)) => DBType ( a :: Type ) where
+class (ExprType a ~ Expr a, ResultType (Expr a) ~ a, ExprType (Maybe a) ~ Expr (Maybe a), Serializable (Expr a) a) => DBType (a :: Type) where
   typeInformation :: DatabaseType a a
 
 
@@ -746,71 +669,67 @@ infixr 2 ||.
     Expr ( Opaleye.BinExpr Opaleye.OpOr a b )
 
 
-ifThenElse_ :: ExprTable a => Expr Bool -> a -> a -> a
+ifThenElse_ :: Table Expr a => Expr Bool -> a -> a -> a
 ifThenElse_ bool whenTrue whenFalse =
   case_ [ ( bool, whenTrue ) ] whenFalse
 
 
-case_ :: forall a. ExprTable a => [ ( Expr Bool, a ) ] -> a -> a
+case_ :: forall a. Table Expr a => [ ( Expr Bool, a ) ] -> a -> a
 case_ alts def =
-  fromStructure $ runIdentity $ htabulate @(Structure a) (Proxy @Unconstrained) \x ->
+  fromColumns $ htabulate @(Columns a) \x -> MkC $ fromPrimExpr $
-    pure $ MkC $ fromPrimExpr $
     Opaleye.CaseExpr
-        [ ( toPrimExpr bool, toPrimExpr $ toColumn $ hfield (toStructure alt) x ) | ( bool, alt ) <- alts ]
+        [ ( toPrimExpr bool, toPrimExpr $ toColumn $ hfield (toColumns alt) x ) | ( bool, alt ) <- alts ]
-        ( toPrimExpr $ toColumn $ hfield (toStructure def) x )
+        ( toPrimExpr $ toColumn $ hfield (toColumns def) x )
 
 
 unsafeCoerceExpr :: Expr a -> Expr b
-unsafeCoerceExpr ( Expr x ) = Expr x
+unsafeCoerceExpr (Expr x) = Expr x
 
 
 retype :: Expr a -> Expr b
-retype =
+retype = fromPrimExpr . toPrimExpr
-  fromPrimExpr . toPrimExpr
 
 
-isNull :: Expr ( Maybe a ) -> Expr Bool
+isNull :: Expr (Maybe a) -> Expr Bool
-isNull =
+isNull = fromPrimExpr . Opaleye.UnExpr Opaleye.OpIsNull . toPrimExpr
-  fromPrimExpr . Opaleye.UnExpr Opaleye.OpIsNull . toPrimExpr
 
 
 fromPrimExpr :: Opaleye.PrimExpr -> Expr a
-fromPrimExpr =
+fromPrimExpr = Expr
-  Expr
 
 
-type family Apply (g :: (Type -> Type) -> Type -> Type) (f :: Type -> Type) :: Type -> Type where
+-- type family Apply (g :: (Type -> Type) -> Type -> Type) (f :: Type -> Type) :: Type -> Type where
-  Apply Lit Identity = Expr
+--   Apply Lit Identity = Expr
-  Apply g f = g f
+--   Apply g f = g f
 
 
-data Lit (f :: Type -> Type) a
+-- data Lit (f :: Type -> Type) a
 
 
-class
+-- class
-  ( Table a
+--   ( Table a
-  , Table b
+--   , Table b
-  , MapContext g a ~ b
+--   , MapContext g a ~ b
-  , Structure a ~ Structure b
+--   , Structure a ~ Structure b
-  , Apply g (Context a) ~ Context b
+--   , Apply g (Context a) ~ Context b
-  ) =>
+--   ) =>
-    Recontextualise g a b
+--     Recontextualise g a b
-  where
+--   where
 
-  type MapContext (g :: (Type -> Type) -> Type -> Type) a :: Type
+--   type MapContext (g :: (Type -> Type) -> Type -> Type) a :: Type
 
-  mapContext :: (Applicative m, HConstrainTable (Structure a) (Context b) c)
+--   mapContext :: (Applicative m, HConstrainTable (Structure a) (Context b) c)
-    => proxy g
+--     => proxy g
-    -> proxy' c
+--     -> proxy' c
-    -> (forall x. c x => C (Context a) x -> m (C (Context b) x))
+--     -> (forall x. c x => C (Context a) x -> m (C (Context b) x))
-    -> a
+--     -> a
-    -> m b
+--     -> m b
 
 
-instance (HigherKindedTable t, f' ~ Apply g f) => Recontextualise g (t f) (t f') where
+-- instance (HigherKindedTable t, f' ~ Apply g f) => Recontextualise g (t f) (t f') where
-  type MapContext g (t f) = t (Apply g f)
+--   type MapContext g (t f) = t (Apply g f)
 
-  mapContext _ c f as = htabulate c (\field -> f (hfield as field))
+--   mapContext _ c f as = htabulate c (\field -> f (hfield as field))
 
 
 -- | A deriving-via helper type for column types that store a Haskell value
@@ -834,3 +753,21 @@ instance (Read a, Show a, Typeable a) => DBType (ReadShow a) where
   typeInformation =
     parseDatabaseType (fmap ReadShow . readEither) $
     lmap (show . fromReadShow) typeInformation
+
+
+mapTable 
+  :: (Columns s ~ Columns t, Table f s, Table g t) 
+  => (forall x. C f x -> C g x) -> s -> t
+mapTable f = fromColumns . runIdentity . htraverse (pure . f) . toColumns
+
+
+zipTablesWithM 
+  :: (Columns x ~ Columns y, Columns y ~ Columns z, Table f x, Table g y, Table h z) 
+  => (forall x. C f x -> C g y -> m (C h z)) -> x -> y -> m z
+zipTablesWithM f x y = undefined
+
+
+traverseTable 
+  :: (Columns x ~ Columns y, Table f x, Table g y) 
+  => (forall x. C f x -> m (C g y)) -> x -> m y
+traverseTable f = undefined

src/Rel8/EqTable.hs

@@ -1,4 +1,5 @@
 {-# language BlockArguments #-}
+{-# language FlexibleContexts #-}
 {-# language FlexibleInstances #-}
 {-# language ScopedTypeVariables #-}
 {-# language TypeApplications #-}
@@ -15,7 +16,7 @@ import Rel8.Core
 
 -- | The class of database tables (containing one or more columns) that can be
 -- compared for equality as a whole.
-class ExprTable a => EqTable a where
+class Table Expr a => EqTable a where
   -- | Compare two tables or expressions for equality.
   --
   -- This operator is overloaded (much like Haskell's 'Eq' type class) to allow
@@ -31,7 +32,7 @@ class ExprTable a => EqTable a where
   --
   -- >>> :t ( exprA, exprA ) ==. ( exprA, exprA )
   -- Expr m Bool
-  (==.) :: a -> a -> Context a Bool
+  (==.) :: a -> a -> Expr Bool
 
 
 -- | Any @Expr@s can be compared for equality as long as the underlying

src/Rel8/Expr.hs

@@ -22,7 +22,6 @@ module Rel8.Expr
   , (&&.)
   , (||.)
   , Expr
-  , ExprTable
   , Function
   , and_
   , or_

src/Rel8/Query.hs

@@ -130,15 +130,13 @@ queryRunner
    . Serializable row haskell
   => Opaleye.FromFields row haskell
 queryRunner =
-  Opaleye.QueryRunner ( void unpackspec ) rowParser ( const 1 )
+  Opaleye.QueryRunner ( void unpackspec ) (const rowParser) ( const 1 )
 
 
-unpackspec
+unpackspec :: Table Expr row => Opaleye.Unpackspec row row
-  :: (ExprTable row)
-  => Opaleye.Unpackspec row row
 unpackspec =
-  Opaleye.Unpackspec $ Opaleye.PackMap \f ->
+  Opaleye.Unpackspec $ Opaleye.PackMap \f -> 
-    traverseTable (traverseC (traversePrimExpr f))
+    fmap fromColumns . htraverse (traverseC (traversePrimExpr f)) . toColumns
 
 
 -- | Run an @INSERT@ statement
@@ -154,10 +152,9 @@ insert connection Insert{ into, rows, onConflict, returning } =
 
     toOpaleyeInsert
       :: forall schema result value
-       . ( ExprTable value
+       . ( Table Expr value
-         , Context schema ~ ColumnSchema
+         , Table ColumnSchema schema
-         , Structure value ~ Structure schema
+         , Columns value ~ Columns schema
-         , Table schema
          )
       => TableSchema schema
       -> [ value ]
@@ -185,9 +182,8 @@ insert connection Insert{ into, rows, onConflict, returning } =
 
 writer
   :: forall value schema
-   . ( Context value ~ Expr
+   . ( Table Expr value 
-     , Context schema ~ ColumnSchema
+     , Table ColumnSchema schema
-     , Selects schema value
      )
   => TableSchema schema -> Opaleye.Writer value schema
 writer into_ =
@@ -197,23 +193,23 @@ writer into_ =
        . ( Functor list, Applicative f )
       => ( ( list Opaleye.PrimExpr, String ) -> f () )
       -> list value
-      -> f ()
+      -> f () 
-    go f xs =
+    go f xs = undefined
-      void
+      -- void
-        ( traverseTableWithIndexC
+      --   ( traverseTableWithIndexC
-            @Unconstrained
+      --       @Unconstrained
-            @schema
+      --       @schema
-            @value
+      --       @value
-            ( \i ->
+      --       ( \i ->
-                traverseC \ColumnSchema{ columnName } -> do
+      --           traverseC \ColumnSchema{ columnName } -> do
-                  f ( toPrimExpr . toColumn . flip hfield i . toStructure <$> xs
+      --             f ( toPrimExpr . toColumn . flip hfield i . toStructure <$> xs
-                    , columnName
+      --               , columnName
-                    )
+      --               )
 
-                  return ( column columnName )
+      --             return ( column columnName )
-            )
+      --       )
-            ( tableColumns into_ )
+      --       ( tableColumns into_ )
-        )
+      --   )
 
   in
   Opaleye.Writer ( Opaleye.PackMap go )
@@ -239,7 +235,7 @@ ddlTable schema writer_ =
 -- | The constituent parts of a SQL @INSERT@ statement.
 data Insert :: * -> * where
   Insert
-    :: Selects schema value
+    :: (Columns value ~ Columns schema, Table Expr value, Table ColumnSchema schema)
     => { into :: TableSchema schema
          -- ^ Which table to insert into.
        , rows :: [ value ]
@@ -265,9 +261,10 @@ data Returning schema a where
   -- >>> :t insert Insert{ returning = Projection fooId }
   -- IO [ FooId ]
   Projection
-    :: ( Selects schema row
+    :: ( Table Expr projection
-       , Table projection
+       , Table ColumnSchema schema
-       , Context row ~ Context projection
+       , Table Expr row
+       , Columns schema ~ Columns row
        , Serializable projection a
        )
     => ( row -> projection )
@@ -279,7 +276,7 @@ data OnConflict
   | DoNothing
 
 
-selectQuery :: forall a . ExprTable a => Query a -> Maybe String
+selectQuery :: forall a . Table Expr a => Query a -> Maybe String
 selectQuery ( Query opaleye ) =
   showSqlForPostgresExplicit
 
@@ -303,10 +300,9 @@ delete c Delete{ from, deleteWhere, returning } =
 
     go
       :: forall schema r row
-       . ( Context schema ~ ColumnSchema
+       . ( Table Expr row 
-         , ExprTable row
+         , Table ColumnSchema schema
-         , Structure schema ~ Structure row
+         , Columns schema ~ Columns row
-         , Table schema
          )
       => TableSchema schema
       -> ( row -> Expr Bool )
@@ -326,7 +322,7 @@ delete c Delete{ from, deleteWhere, returning } =
 
 data Delete from return where
   Delete
-    :: Selects from row
+    :: ( Columns from ~ Columns row, Table Expr row, Table ColumnSchema from )
     => { from :: TableSchema from
        , deleteWhere :: row -> Expr Bool
        , returning :: Returning from return
@@ -342,10 +338,9 @@ update connection Update{ target, set, updateWhere, returning } =
 
     go
       :: forall returning target row
-       . ( Context target ~ ColumnSchema
+       . ( Table Expr row
-         , ExprTable row
+         , Columns target ~ Columns row
-         , Structure target ~ Structure row
+         , Table ColumnSchema target
-         , Table target
          )
       => TableSchema target
       -> ( row -> row )
@@ -373,7 +368,7 @@ update connection Update{ target, set, updateWhere, returning } =
 
 data Update target returning where
   Update
-    :: Selects target row
+    :: ( Columns target ~ Columns row, Table Expr row, Table ColumnSchema target )
     => { target :: TableSchema target
        , set :: row -> row
        , updateWhere :: row -> Expr Bool
@@ -393,13 +388,13 @@ exists query =
 -- | Select each row from a table definition.
 --
 -- This is equivalent to @FROM table@.
-each :: Selects schema row => TableSchema schema -> Query row
+each :: (Columns schema ~ Columns row, Table Expr row, Table ColumnSchema schema) => TableSchema schema -> Query row
 each = each_forAll
 
 
 each_forAll
   :: forall schema row
-   . Selects schema row
+   . ( Columns schema ~ Columns row, Table Expr row, Table ColumnSchema schema )
   => TableSchema schema -> Query row
 each_forAll schema =
   liftOpaleye
@@ -453,13 +448,13 @@ optional =
 -- | Combine the results of two queries of the same type.
 --
 -- @union a b@ is the same as the SQL statement @x UNION b@.
-union :: ExprTable a => Query a -> Query a -> Query a
+union :: Table Expr a => Query a -> Query a -> Query a
 union = union_forAll
 
 
 union_forAll
   :: forall a
-   . ExprTable a
+   . Table Expr a
   => Query a -> Query a -> Query a
 union_forAll l r =
   liftOpaleye
@@ -483,11 +478,11 @@ union_forAll l r =
 -- | Select all distinct rows from a query, removing duplicates.
 --
 -- @distinct q@ is equivalent to the SQL statement @SELECT DISTINCT q@
-distinct :: ExprTable a => Query a -> Query a
+distinct :: Table Expr a => Query a -> Query a
 distinct = distinct_forAll
 
 
-distinct_forAll :: forall a. ExprTable a => Query a -> Query a
+distinct_forAll :: forall a. Table Expr a => Query a -> Query a
 distinct_forAll query =
   liftOpaleye ( Opaleye.distinctExplicit distinctspec ( toOpaleye query ) )
 
@@ -543,20 +538,20 @@ catMaybe e =
   catMaybeTable $ MaybeTable (ifThenElse_ (isNull e) (lit Nothing) (lit (Just False))) (unsafeCoerceExpr e)
 
 
-values :: forall expr f. (ExprTable expr, Foldable f) => f expr -> Query expr
+values :: forall expr f. (Table Expr expr, Foldable f) => f expr -> Query expr
 values = liftOpaleye . Opaleye.valuesExplicit valuesspec . toList
   where
     valuesspec = Opaleye.ValuesspecSafe packmap unpackspec
       where
         packmap :: Opaleye.PackMap Opaleye.PrimExpr Opaleye.PrimExpr () expr
-        packmap = Opaleye.PackMap \f () ->
+        packmap = Opaleye.PackMap \f () -> undefined
-          fmap fromStructure $
+          -- fmap fromColumns $
-          htabulate (Proxy @DBType) \i -> MkC . fromPrimExpr <$> f (nullExpr i)
+          -- htabulate (Proxy @DBType) \i -> MkC . fromPrimExpr <$> f (nullExpr i)
-            where
+          --   where
-              nullExpr :: forall a w. DBType a => HField w a -> Opaleye.PrimExpr
+          --     nullExpr :: forall a w. DBType a => HField w a -> Opaleye.PrimExpr
-              nullExpr _ = Opaleye.CastExpr typeName (Opaleye.ConstExpr Opaleye.NullLit)
+          --     nullExpr _ = Opaleye.CastExpr typeName (Opaleye.ConstExpr Opaleye.NullLit)
-                where
+          --       where
-                  DatabaseType{ typeName } = typeInformation @a
+          --         DatabaseType{ typeName } = typeInformation @a
 
 
 filter :: (a -> Expr Bool) -> a -> Query a

src/Rel8/SimpleConstraints.hs

@@ -10,35 +10,34 @@
 {-# language UndecidableInstances #-}
 {-# language UndecidableSuperClasses #-}
 
-module Rel8.SimpleConstraints ( Selects, IsTableIn ) where
+module Rel8.SimpleConstraints where -- ( Selects, IsTableIn ) where
 
 import Rel8.ColumnSchema
 import Rel8.Expr
 import Rel8.Core
 
 
--- | @Selects m schema row@ says that in the monad @m@, the schema definition
+-- -- | @Selects m schema row@ says that in the monad @m@, the schema definition
--- @schema@ can be @SELECT@ed into the Haskell type @row@.
+-- -- @schema@ can be @SELECT@ed into the Haskell type @row@.
-class
+-- class
-  ( ExprTable row
+--   ( Context schema ~ ColumnSchema
-  , Context schema ~ ColumnSchema
+--   , Table schema
-  , Table schema
+--   , Structure row ~ Structure schema
-  , Structure row ~ Structure schema
+--   ) => Selects schema row
-  ) => Selects schema row
 
 
-instance
+-- instance
-  {-# overlapping #-}
+--   {-# overlapping #-}
-  ( ExprTable row
+--   ( ExprTable row
-  , Context schema ~ ColumnSchema
+--   , Context schema ~ ColumnSchema
-  , Table schema
+--   , Table schema
-  , Structure row ~ Structure schema
+--   , Structure row ~ Structure schema
-  ) => Selects schema row
+--   ) => Selects schema row
 
 
--- | Makes sure that a given table (@a@) contains expressions compatible with
+-- -- | Makes sure that a given table (@a@) contains expressions compatible with
--- the monad @m@. This type class is essentially a scoping check.
+-- -- the monad @m@. This type class is essentially a scoping check.
-class
+-- class
-  ( Table a
+--   ( Table a
-  , Context a ~ Expr
+--   , Context a ~ Expr
-  ) => a `IsTableIn` m
+--   ) => a `IsTableIn` m