Complete overhaul of Rel8.Schema.Generic

rel8.cabal

@@ -87,7 +87,6 @@ library
 
     Rel8.Schema.Column
     Rel8.Schema.Context
-    Rel8.Schema.Context.Identity
     Rel8.Schema.Context.Label
     Rel8.Schema.Context.Nullify
     Rel8.Schema.Dict
@@ -117,6 +116,7 @@ library
     Rel8.Schema.Spec
     Rel8.Schema.Spec.ConstrainDBType
     Rel8.Schema.Spec.ConstrainType
+    Rel8.Schema.Structure
     Rel8.Schema.Table
 
     Rel8.Statement.Delete
@@ -133,7 +133,6 @@ library
     Rel8.Table.Either
     Rel8.Table.Eq
     Rel8.Table.Insert
-    Rel8.Table.Lifted
     Rel8.Table.List
     Rel8.Table.Maybe
     Rel8.Table.Name
@@ -163,8 +162,6 @@ library
     Rel8.Type.Sum
     Rel8.Type.Tag
 
-    Rel8.Schema.Structure
-
 test-suite tests
   type:             exitcode-stdio-1.0
   build-depends:

src/Rel8.hs

@@ -28,7 +28,7 @@ module Rel8
     -- * Tables and higher-kinded tables
   , Rel8able
   , Column, Field, Necessity( Required, Optional )
-  , Default, Label
+  , Default
   , HMaybe
   , HList
   , HNonEmpty
@@ -268,7 +268,7 @@ import Rel8.Query.These
 import Rel8.Query.Values
 import Rel8.Schema.Column
 import Rel8.Schema.Context.Label
-import Rel8.Schema.Field (Field)
+import Rel8.Schema.Field
 import Rel8.Schema.Generic
 import Rel8.Schema.HTable
 import Rel8.Schema.Name
@@ -307,5 +307,3 @@ import Rel8.Type.ReadShow
 import Rel8.Type.Semigroup
 import Rel8.Type.String
 import Rel8.Type.Sum
-
-

src/Rel8/Expr/Eq.hs

@@ -22,7 +22,7 @@ import Prelude
 import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
 
 -- rel8
-import Rel8.Expr ( Expr )
+import {-# SOURCE #-} Rel8.Expr ( Expr )
 import Rel8.Expr.Bool ( (&&.), (||.), false, or_, coalesce )
 import Rel8.Expr.Null ( isNull, unsafeLiftOpNull )
 import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr, zipPrimExprsWith )

src/Rel8/Schema/Column.hs

@@ -3,67 +3,24 @@
 {-# language StandaloneKindSignatures #-}
 
 module Rel8.Schema.Column
-  ( Column, Default, Label
+  ( Column, Default
-  , HEither
-  , HList
-  , HMaybe
-  , HNonEmpty
-  , HThese
   )
 where
 
 -- base
-import Data.Functor.Identity ( Identity )
 import Data.Kind ( Type )
-import Data.List.NonEmpty ( NonEmpty )
+import Prelude ()
-import GHC.TypeLits ( Symbol )
-import Prelude
 
 -- rel8
-import Rel8.Aggregate ( Aggregate )
-import Rel8.Expr ( Expr )
-import Rel8.Kind.Labels ( Labels )
 import Rel8.Kind.Necessity ( Necessity( Required, Optional ) )
 import Rel8.Schema.Field ( Field )
-import Rel8.Schema.Insert ( Insert )
 import qualified Rel8.Schema.Kind as K
-import Rel8.Schema.Name ( Name )
-import Rel8.Schema.Structure
-  ( Structure
-  , Shape( Either, List, Maybe, NonEmpty, These )
-  , Shape1
-  , Shape2
-  )
-import Rel8.Table.Either ( EitherTable )
-import Rel8.Table.List ( ListTable )
-import Rel8.Table.Maybe ( MaybeTable )
-import Rel8.Table.NonEmpty ( NonEmptyTable )
-import Rel8.Table.These ( TheseTable )
-
--- these
-import Data.These ( These )
-
-
-type Label :: Symbol -> Type -> Type
-data Label label a
 
 
 type Default :: Type -> Type
 data Default a
 
 
-type GetLabel :: Type -> Labels
-type family GetLabel a where
-  GetLabel (Label label _) = '[label]
-  GetLabel _ = '[]
-
-
-type UnwrapLabel :: Type -> Type
-type family UnwrapLabel a where
-  UnwrapLabel (Label _ a) = a
-  UnwrapLabel a = a
-
-
 type GetNecessity :: Type -> Necessity
 type family GetNecessity a where
   GetNecessity (Default _) = 'Optional
@@ -82,61 +39,4 @@ type family UnwrapDefault a where
 -- both query data and rows decoded to Haskell.
 type Column :: K.Context -> Type -> Type
 type Column context a =
-  Field context (GetLabel a)
+  Field context (GetNecessity a) (UnwrapDefault a)
-    (GetNecessity (UnwrapLabel a))
-    (UnwrapDefault (UnwrapLabel a))
-
-
-type HEither :: K.Context -> Type -> Type -> Type
-type family HEither context where
-  HEither Structure = Shape2 'Either
-  HEither Aggregate = EitherTable
-  HEither Expr = EitherTable
-  HEither Identity = Either
-  HEither Insert = EitherTable
-  HEither Name = EitherTable
-  HEither _ = Either
-
-
-type HList :: K.Context -> Type -> Type
-type family HList context where
-  HList Structure = Shape1 'List
-  HList Aggregate = ListTable
-  HList Expr = ListTable
-  HList Identity = []
-  HList Insert = ListTable
-  HList Name = ListTable
-  HList _ = []
-
-
-type HMaybe :: K.Context -> Type -> Type
-type family HMaybe context where
-  HMaybe Structure = Shape1 'Maybe
-  HMaybe Aggregate = MaybeTable
-  HMaybe Expr = MaybeTable
-  HMaybe Identity = Maybe
-  HMaybe Insert = MaybeTable
-  HMaybe Name = MaybeTable
-  HMaybe _ = Maybe
-
-
-type HNonEmpty :: K.Context -> Type -> Type
-type family HNonEmpty context where
-  HNonEmpty Structure = Shape1 'NonEmpty
-  HNonEmpty Aggregate = NonEmptyTable
-  HNonEmpty Expr = NonEmptyTable
-  HNonEmpty Identity = NonEmpty
-  HNonEmpty Insert = NonEmptyTable
-  HNonEmpty Name = NonEmptyTable
-  HNonEmpty _ = NonEmpty
-
-
-type HThese :: K.Context -> Type -> Type -> Type
-type family HThese context where
-  HThese Structure = Shape2 'These
-  HThese Aggregate = TheseTable
-  HThese Expr = TheseTable
-  HThese Identity = These
-  HThese Insert = TheseTable
-  HThese Name = TheseTable
-  HThese _ = These

src/Rel8/Schema/Context/Identity.hs

@@ -1,196 +0,0 @@
-{-# language DataKinds #-}
-{-# language DisambiguateRecordFields #-}
-{-# language NamedFieldPuns #-}
-{-# language TypeFamilies #-}
-
-module Rel8.Schema.Context.Identity
-  ( fromHEitherTable, toHEitherTable
-  , fromHListTable, toHListTable
-  , fromHMaybeTable, toHMaybeTable
-  , fromHNonEmptyTable, toHNonEmptyTable
-  , fromHTheseTable, toHTheseTable
-  )
-where
-
--- base
-import Data.Functor ( ($>) )
-import Data.Functor.Identity ( Identity )
-import Data.List.NonEmpty ( NonEmpty )
-import Prelude hiding ( null )
-
--- rel8
-import Rel8.Schema.Context ( Col( Result ) )
-import Rel8.Schema.HTable ( HTable )
-import Rel8.Schema.HTable.Either ( HEitherTable(..) )
-import Rel8.Schema.HTable.Identity ( HIdentity(..) )
-import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
-import Rel8.Schema.HTable.List ( HListTable )
-import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
-import Rel8.Schema.HTable.Nullify ( hnulls, hnullify, hunnullify )
-import Rel8.Schema.HTable.These ( HTheseTable(..) )
-import Rel8.Schema.HTable.Vectorize ( hvectorize, hunvectorize )
-import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )
-import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
-import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ),  MaybeTag( IsJust ) )
-
--- these
-import Data.These ( These( This, That, These ) )
-import Data.These.Combinators ( justHere, justThere )
-
-
-toHEitherTable :: (HTable t, HTable u)
-  => Either (t (Col Identity)) (u (Col Identity))
-  -> HEitherTable t u (Col Identity)
-toHEitherTable = either hleft hright
-  where
-    hleft table = HEitherTable
-      { htag = HIdentity (Result IsLeft)
-      , hleft = hnullify nullifier table
-      , hright = hnulls null
-      }
-    hright table = HEitherTable
-      { htag = HIdentity (Result IsRight)
-      , hleft = hnulls null
-      , hright = hnullify nullifier table
-      }
-{-# INLINABLE toHEitherTable #-}
-
-
-fromHEitherTable :: (HTable t, HTable u)
-  => HEitherTable t u (Col Identity)
-  -> Either (t (Col Identity)) (u (Col Identity))
-fromHEitherTable HEitherTable {htag, hleft, hright} = case htag of
-  HIdentity (Result tag) -> case tag of
-    IsLeft -> maybe err Left $ hunnullify unnullifier hleft
-    IsRight -> maybe err Right $ hunnullify unnullifier hright
-  where
-    err = error "fromHEitherTable: mismatch between tag and data"
-{-# INLINABLE fromHEitherTable #-}
-
-
-toHListTable :: HTable t => [t (Col Identity)] -> HListTable t (Col Identity)
-toHListTable = hvectorize vectorizer
-{-# INLINABLE toHListTable #-}
-
-
-fromHListTable :: HTable t => HListTable t (Col Identity) -> [t (Col Identity)]
-fromHListTable = hunvectorize unvectorizer
-{-# INLINABLE fromHListTable #-}
-
-
-toHMaybeTable :: HTable t => Maybe (t (Col Identity)) -> HMaybeTable t (Col Identity)
-toHMaybeTable = maybe hnothing hjust
-  where
-    hnothing = HMaybeTable
-      { htag = HIdentity (Result Nothing)
-      , hjust = hnulls null
-      }
-    hjust table = HMaybeTable
-      { htag = HIdentity (Result (Just IsJust))
-      , hjust = hnullify nullifier table
-      }
-{-# INLINABLE toHMaybeTable #-}
-
-
-fromHMaybeTable :: HTable t => HMaybeTable t (Col Identity) -> Maybe (t (Col Identity))
-fromHMaybeTable HMaybeTable {htag, hjust} = case htag of
-  HIdentity (Result tag) -> tag $>
-    case hunnullify unnullifier hjust of
-      Nothing -> error "fromHMaybeTable: mismatch between tag and data"
-      Just just -> just
-{-# INLINABLE fromHMaybeTable #-}
-
-
-toHNonEmptyTable :: HTable t => NonEmpty (t (Col Identity)) -> HNonEmptyTable t (Col Identity)
-toHNonEmptyTable = hvectorize vectorizer
-{-# INLINABLE toHNonEmptyTable #-}
-
-
-fromHNonEmptyTable :: HTable t => HNonEmptyTable t (Col Identity) -> NonEmpty (t (Col Identity))
-fromHNonEmptyTable = hunvectorize unvectorizer
-{-# INLINABLE fromHNonEmptyTable #-}
-
-
-toHTheseTable :: (HTable t, HTable u)
-  => These (t (Col Identity)) (u (Col Identity))
-  -> HTheseTable t u (Col Identity)
-toHTheseTable tables = HTheseTable
-  { hhereTag = relabel hhereTag
-  , hhere
-  , hthereTag = relabel hthereTag
-  , hthere
-  }
-  where
-    HMaybeTable
-      { htag = hhereTag
-      , hjust = hhere
-      } = toHMaybeTable (justHere tables)
-    HMaybeTable
-      { htag = hthereTag
-      , hjust = hthere
-      } = toHMaybeTable (justThere tables)
-{-# INLINABLE toHTheseTable #-}
-
-
-fromHTheseTable :: (HTable t, HTable u)
-  => HTheseTable t u (Col Identity)
-  -> These (t (Col Identity)) (u (Col Identity))
-fromHTheseTable HTheseTable {hhereTag, hhere, hthereTag, hthere} =
-  case (fromHMaybeTable mhere, fromHMaybeTable mthere) of
-    (Just a, Nothing) -> This a
-    (Nothing, Just b) -> That b
-    (Just a, Just b) -> These a b
-    _ -> error "fromHTheseTable: mismatch between tags and data"
-  where
-    mhere = HMaybeTable
-      { htag = relabel hhereTag
-      , hjust = hhere
-      }
-    mthere = HMaybeTable
-      { htag = relabel hthereTag
-      , hjust = hthere
-      }
-{-# INLINABLE fromHTheseTable #-}
-
-
-null :: Col Identity ('Spec labels necessity (Maybe a))
-null = Result Nothing
-
-
-nullifier :: ()
-  => SSpec ('Spec labels necessity a)
-  -> Col Identity ('Spec labels necessity a)
-  -> Col Identity ('Spec labels necessity (Nullify a))
-nullifier SSpec {nullity} (Result a) = Result $ case nullity of
-  Null -> a
-  NotNull -> Just a
-
-
-unnullifier :: ()
-  => SSpec ('Spec labels necessity a)
-  -> Col Identity ('Spec labels necessity (Nullify a))
-  -> Maybe (Col Identity ('Spec labels necessity a))
-unnullifier SSpec {nullity} (Result a) =
-  case nullity of
-    Null -> pure $ Result a
-    NotNull -> Result <$> a
-
-
-vectorizer :: Functor f
-  => SSpec ('Spec labels necessity a)
-  -> f (Col Identity ('Spec labels necessity a))
-  -> Col Identity ('Spec labels necessity (f a))
-vectorizer _ = Result . fmap (\(Result a) -> a)
-
-
-unvectorizer :: Functor f
-  => SSpec ('Spec labels necessity a)
-  -> Col Identity ('Spec labels necessity (f a))
-  -> f (Col Identity ('Spec labels necessity a))
-unvectorizer _ (Result results) = Result <$> results
-
-
-relabel :: ()
-  => HIdentity ('Spec labels necessity a) (Col Identity)
-  -> HIdentity ('Spec relabels necessity a) (Col Identity)
-relabel (HIdentity (Result a)) = HIdentity (Result a)

src/Rel8/Schema/Field.hs

@@ -1,34 +1,725 @@
 {-# language DataKinds #-}
+{-# language FlexibleContexts #-}
+{-# language GADTs #-}
+{-# language LambdaCase #-}
+{-# language MultiParamTypeClasses #-}
 {-# language StandaloneKindSignatures #-}
 {-# language TypeFamilies #-}
+{-# language UndecidableInstances #-}
 
 module Rel8.Schema.Field
   ( Field
+  , HEither, HList, HMaybe, HNonEmpty, HThese
+  , Reify, hreify, hunreify
+  , Reifiable
+  , AField(..)
+  , AHEither(..), AHList(..), AHMaybe(..), AHNonEmpty(..), AHThese(..)
   )
 where
 
 -- base
+import Data.Bifunctor ( Bifunctor, bimap )
 import Data.Functor.Identity ( Identity )
-import Data.Kind ( Type )
+import Data.Kind ( Constraint, Type )
+import Data.List.NonEmpty ( NonEmpty )
 import Prelude
 
 -- rel8
-import Rel8.Aggregate ( Aggregate )
+import Rel8.Aggregate ( Aggregate, Col(..) )
-import Rel8.Expr ( Expr )
+import Rel8.Expr ( Expr, Col(..) )
-import Rel8.Kind.Labels ( Labels )
+import Rel8.Kind.Necessity
-import Rel8.Kind.Necessity ( Necessity( Required, Optional ) )
+  ( Necessity( Required, Optional )
-import Rel8.Schema.Insert ( Insert )
+  , SNecessity( SRequired, SOptional )
+  , KnownNecessity, necessitySing
+  )
+import Rel8.Schema.Context ( Interpretation, Col(..) )
+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
+import Rel8.Schema.HTable ( HTable, hfield, htabulate )
+import Rel8.Schema.HTable.Either ( HEitherTable )
+import Rel8.Schema.HTable.List ( HListTable )
+import Rel8.Schema.HTable.Maybe ( HMaybeTable )
+import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
+import Rel8.Schema.HTable.These ( HTheseTable )
+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
+import Rel8.Schema.Insert ( Insert, Col(..) )
 import qualified Rel8.Schema.Kind as K
+import Rel8.Schema.Name ( Name(..), Col(..) )
+import Rel8.Schema.Null ( Sql )
 import Rel8.Schema.Spec ( Spec( Spec ) )
-import Rel8.Schema.Structure ( Structure, Shape( Column ), Shape1 )
+import Rel8.Table
+  ( Table, Columns, Context, fromColumns, toColumns
+  , Congruent
+  )
+import Rel8.Table.Either ( EitherTable )
+import Rel8.Table.List ( ListTable( ListTable ) )
+import Rel8.Table.Maybe ( MaybeTable )
+import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) )
+import Rel8.Table.Recontextualize ( Recontextualize )
+import Rel8.Table.These ( TheseTable )
+import Rel8.Type ( DBType )
+
+-- these
+import Data.These ( These )
 
 
-type Field :: K.Context -> Labels -> Necessity -> Type -> Type
+type Field :: K.Context -> Necessity -> Type -> Type
-type family Field labels context necessity a where
+type family Field context necessity a where
-  Field Identity  _labels _necessity a = a
+  Field (Reify context) necessity  a = AField context necessity a
-  Field Expr      _labels _necessity a = Expr a
+  Field Identity        _necessity a = a
-  Field Insert    _labels 'Required  a = Expr a
+  Field Expr            _necessity a = Expr a
-  Field Insert    _labels 'Optional  a = Maybe (Expr a)
+  Field Insert          'Required  a = Expr a
-  Field Aggregate _labels _necessity a = Aggregate (Expr a)
+  Field Insert          'Optional  a = Maybe (Expr a)
-  Field Structure labels  necessity  a = Shape1 'Column ('Spec labels necessity a)
+  Field Aggregate       _necessity a = Aggregate (Expr a)
-  Field context   _labels _necessity a = context a
+  Field context         _necessity a = context a
+
+
+type HEither :: K.Context -> Type -> Type -> Type
+type family HEither context where
+  HEither (Reify context) = AHEither context
+  HEither Aggregate = EitherTable
+  HEither Expr = EitherTable
+  HEither Identity = Either
+  HEither Insert = EitherTable
+  HEither Name = EitherTable
+  HEither _ = Either
+
+
+type HList :: K.Context -> Type -> Type
+type family HList context where
+  HList (Reify context) = AHList context
+  HList Aggregate = ListTable
+  HList Expr = ListTable
+  HList Identity = []
+  HList Insert = ListTable
+  HList Name = ListTable
+  HList _ = []
+
+
+type HMaybe :: K.Context -> Type -> Type
+type family HMaybe context where
+  HMaybe (Reify context) = AHMaybe context
+  HMaybe Aggregate = MaybeTable
+  HMaybe Expr = MaybeTable
+  HMaybe Identity = Maybe
+  HMaybe Insert = MaybeTable
+  HMaybe Name = MaybeTable
+  HMaybe _ = Maybe
+
+
+type HNonEmpty :: K.Context -> Type -> Type
+type family HNonEmpty context where
+  HNonEmpty (Reify context) = AHNonEmpty context
+  HNonEmpty Aggregate = NonEmptyTable
+  HNonEmpty Expr = NonEmptyTable
+  HNonEmpty Identity = NonEmpty
+  HNonEmpty Insert = NonEmptyTable
+  HNonEmpty Name = NonEmptyTable
+  HNonEmpty _ = NonEmpty
+
+
+type HThese :: K.Context -> Type -> Type -> Type
+type family HThese context where
+  HThese (Reify context) = AHThese context
+  HThese Aggregate = TheseTable
+  HThese Expr = TheseTable
+  HThese Identity = These
+  HThese Insert = TheseTable
+  HThese Name = TheseTable
+  HThese _ = These
+
+
+type AField :: K.Context -> Necessity -> Type -> Type
+newtype AField context necessity a = AField (Field context necessity a)
+
+
+instance (Reifiable context, KnownNecessity necessity, Sql DBType a) =>
+  Table (Reify context) (AField context necessity a)
+ where
+  type Context (AField context necessity a) = Reify context
+  type Columns (AField context necessity a) = HIdentity ('Spec '[""] necessity a)
+
+  fromColumns (HIdentity (Reify a)) = sfromColumn contextSing a
+  toColumns = HIdentity . Reify . stoColumn contextSing necessitySing
+
+
+instance
+  ( Reifiable context, Reifiable context'
+  , KnownNecessity necessity, Sql DBType a
+  ) =>
+  Recontextualize
+    (Reify context)
+    (Reify context')
+    (AField context necessity a)
+    (AField context' necessity a)
+
+
+type AHEither :: K.Context -> Type -> Type -> Type
+newtype AHEither context a b = AHEither (HEither context a b)
+
+
+instance Reifiable context => Bifunctor (AHEither context) where
+  bimap = sbimapEither contextSing
+
+
+instance Reifiable context => Functor (AHEither context a) where
+  fmap = bimap id
+
+
+instance (Reifiable context, Table (Reify context) a, Table (Reify context) b)
+  => Table (Reify context) (AHEither context a b)
+ where
+  type Context (AHEither context a b) = Reify context
+  type Columns (AHEither context a b) = HEitherTable (Columns a) (Columns b)
+
+  fromColumns = sfromColumnsEither contextSing
+  toColumns = stoColumnsEither contextSing
+
+
+instance
+  ( Reifiable context, Reifiable context'
+  , Recontextualize (Reify context) (Reify context') a a'
+  , Recontextualize (Reify context) (Reify context') b b'
+  ) =>
+  Recontextualize
+    (Reify context)
+    (Reify context')
+    (AHEither context a b)
+    (AHEither context' a' b')
+
+
+type AHList :: K.Context -> Type -> Type
+newtype AHList context a = AHList (HList context a)
+
+
+instance (Reifiable context, Table (Reify context) a) =>
+  Table (Reify context) (AHList context a)
+ where
+  type Context (AHList context a) = Reify context
+  type Columns (AHList context a) = HListTable (Columns a)
+
+  fromColumns = sfromColumnsList contextSing
+  toColumns = stoColumnsList contextSing
+
+
+instance
+  ( Reifiable context, Reifiable context'
+  , Recontextualize (Reify context) (Reify context') a a'
+  ) =>
+  Recontextualize
+    (Reify context)
+    (Reify context')
+    (AHList context a)
+    (AHList context' a')
+
+
+type AHMaybe :: K.Context -> Type -> Type
+newtype AHMaybe context a = AHMaybe (HMaybe context a)
+
+
+instance Reifiable context => Functor (AHMaybe context) where
+  fmap = smapMaybe contextSing
+
+
+instance (Reifiable context, Table (Reify context) a) =>
+  Table (Reify context) (AHMaybe context a)
+ where
+  type Context (AHMaybe context a) = Reify context
+  type Columns (AHMaybe context a) = HMaybeTable (Columns a)
+
+  fromColumns = sfromColumnsMaybe contextSing
+  toColumns = stoColumnsMaybe contextSing
+
+
+instance
+  ( Reifiable context, Reifiable context'
+  , Recontextualize (Reify context) (Reify context') a a'
+  ) =>
+  Recontextualize
+    (Reify context)
+    (Reify context')
+    (AHMaybe context a)
+    (AHMaybe context' a')
+
+
+type AHNonEmpty :: K.Context -> Type -> Type
+newtype AHNonEmpty context a = AHNonEmpty (HNonEmpty context a)
+
+
+instance (Reifiable context, Table (Reify context) a) =>
+  Table (Reify context) (AHNonEmpty context a)
+ where
+  type Context (AHNonEmpty context a) = Reify context
+  type Columns (AHNonEmpty context a) = HNonEmptyTable (Columns a)
+
+  fromColumns = sfromColumnsNonEmpty contextSing
+  toColumns = stoColumnsNonEmpty contextSing
+
+
+instance
+  ( Reifiable context, Reifiable context'
+  , Recontextualize (Reify context) (Reify context') a a'
+  ) =>
+  Recontextualize
+    (Reify context)
+    (Reify context')
+    (AHNonEmpty context a)
+    (AHNonEmpty context' a')
+
+
+type AHThese :: K.Context -> Type -> Type -> Type
+newtype AHThese context a b = AHThese (HThese context a b)
+
+
+instance Reifiable context => Bifunctor (AHThese context) where
+  bimap = sbimapThese contextSing
+
+
+instance Reifiable context => Functor (AHThese context a) where
+  fmap = bimap id
+
+
+instance (Reifiable context, Table (Reify context) a, Table (Reify context) b)
+  => Table (Reify context) (AHThese context a b)
+ where
+  type Context (AHThese context a b) = Reify context
+  type Columns (AHThese context a b) = HTheseTable (Columns a) (Columns b)
+
+  fromColumns = sfromColumnsThese contextSing
+  toColumns = stoColumnsThese contextSing
+
+
+instance
+  ( Reifiable context, Reifiable context'
+  , Recontextualize (Reify context) (Reify context') a a'
+  , Recontextualize (Reify context) (Reify context') b b'
+  ) =>
+  Recontextualize
+    (Reify context)
+    (Reify context')
+    (AHThese context a b)
+    (AHThese context' a' b')
+
+
+type SContext :: K.Context -> Type
+data SContext context where
+  SAggregate :: SContext Aggregate
+  SExpr :: SContext Expr
+  SIdentity :: SContext Identity
+  SInsert :: SContext Insert
+  SName :: SContext Name
+  SReify :: SContext context -> SContext (Reify context)
+
+
+type Reifiable :: K.Context -> Constraint
+class Interpretation context => Reifiable context where
+  contextSing :: SContext context
+
+
+instance Reifiable Aggregate where
+  contextSing = SAggregate
+
+
+instance Reifiable Expr where
+  contextSing = SExpr
+
+
+instance Reifiable Identity where
+  contextSing = SIdentity
+
+
+instance Reifiable Insert where
+  contextSing = SInsert
+
+
+instance Reifiable Name where
+  contextSing = SName
+
+
+type Reify :: K.Context -> K.Context
+data Reify context a
+
+
+instance Interpretation (Reify context) where
+  newtype Col (Reify context) spec = Reify (Col context spec)
+
+
+instance Labelable context => Labelable (Reify context) where
+  labeler (Reify a) = Reify (labeler a)
+  unlabeler (Reify a) = Reify (unlabeler a)
+
+
+instance Reifiable context => Reifiable (Reify context) where
+  contextSing = SReify contextSing
+
+
+sfromColumn :: ()
+  => SContext context
+  -> Col context ('Spec labels necessity a)
+  -> AField context necessity a
+sfromColumn = \case
+  SAggregate -> \(Aggregation a) -> AField a
+  SExpr -> \(DB a) -> AField a
+  SIdentity -> \(Result a) -> AField a
+  SInsert -> \case
+    RequiredInsert a -> AField a
+    OptionalInsert a -> AField a
+  SName -> \(NameCol a) -> AField (Name a)
+  SReify context -> \(Reify a) -> AField (sfromColumn context a)
+
+
+stoColumn :: ()
+  => SContext context
+  -> SNecessity necessity
+  -> AField context necessity a
+  -> Col context ('Spec labels necessity a)
+stoColumn = \case
+  SAggregate -> \_ (AField a) -> Aggregation a
+  SExpr -> \_ (AField a) -> DB a
+  SIdentity -> \_ (AField a) -> Result a
+  SInsert -> \case
+    SRequired -> \(AField a) -> RequiredInsert a
+    SOptional -> \(AField a) -> OptionalInsert a
+  SName -> \_ (AField (Name a)) -> NameCol a
+  SReify context ->
+    \necessity (AField a) -> Reify (stoColumn context necessity a)
+
+
+sbimapEither :: ()
+  => SContext context
+  -> (a -> c)
+  -> (b -> d)
+  -> AHEither context a b
+  -> AHEither context c d
+sbimapEither = \case
+  SAggregate -> \f g (AHEither a) -> AHEither (bimap f g a)
+  SExpr -> \f g (AHEither a) -> AHEither (bimap f g a)
+  SIdentity -> \f g (AHEither a) -> AHEither (bimap f g a)
+  SInsert -> \f g (AHEither a) -> AHEither (bimap f g a)
+  SName -> \f g (AHEither a) -> AHEither (bimap f g a)
+  SReify context -> \f g (AHEither a) -> AHEither (sbimapEither context f g a)
+
+
+sfromColumnsEither :: (Table (Reify context) a, Table (Reify context) b)
+  => SContext context
+  -> HEitherTable (Columns a) (Columns b) (Col (Reify context))
+  -> AHEither context a b
+sfromColumnsEither = \case
+  SAggregate ->
+    AHEither .
+    bimap (fromColumns . hreify) (fromColumns . hreify) .
+    fromColumns .
+    hunreify
+  SExpr ->
+    AHEither .
+    bimap (fromColumns . hreify) (fromColumns . hreify) .
+    fromColumns .
+    hunreify
+  SIdentity ->
+    AHEither .
+    bimap (fromColumns . hreify) (fromColumns . hreify) .
+    fromColumns .
+    hunreify
+  SInsert ->
+    AHEither .
+    bimap (fromColumns . hreify) (fromColumns . hreify) .
+    fromColumns .
+    hunreify
+  SName ->
+    AHEither .
+    bimap (fromColumns . hreify) (fromColumns . hreify) .
+    fromColumns .
+    hunreify
+  SReify context ->
+    AHEither .
+    sbimapEither context (fromColumns . hreify) (fromColumns . hreify) .
+    sfromColumnsEither context .
+    hunreify
+
+
+stoColumnsEither :: (Table (Reify context) a, Table (Reify context) b)
+  => SContext context
+  -> AHEither context a b
+  -> HEitherTable (Columns a) (Columns b) (Col (Reify context))
+stoColumnsEither = \case
+  SAggregate ->
+    hreify .
+    toColumns .
+    bimap (hunreify . toColumns) (hunreify . toColumns) .
+    (\(AHEither a) -> a)
+  SExpr ->
+    hreify .
+    toColumns .
+    bimap (hunreify . toColumns) (hunreify . toColumns) .
+    (\(AHEither a) -> a)
+  SIdentity ->
+    hreify .
+    toColumns .
+    bimap (hunreify . toColumns) (hunreify . toColumns) .
+    (\(AHEither a) -> a)
+  SInsert ->
+    hreify .
+    toColumns .
+    bimap (hunreify . toColumns) (hunreify . toColumns) .
+    (\(AHEither a) -> a)
+  SName ->
+    hreify .
+    toColumns .
+    bimap (hunreify . toColumns) (hunreify . toColumns) .
+    (\(AHEither a) -> a)
+  SReify context ->
+    hreify .
+    stoColumnsEither context .
+    sbimapEither context (hunreify . toColumns) (hunreify . toColumns) .
+    (\(AHEither a) -> a)
+
+
+smapList :: Congruent a b
+  => SContext context
+  -> (a -> b)
+  -> (HListTable (Columns a) (Col (Context a)) -> HListTable (Columns b) (Col (Context b)))
+  -> AHList context a
+  -> AHList context b
+smapList = \case
+  SAggregate -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))
+  SExpr -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))
+  SIdentity -> \f _ (AHList as) -> AHList (fmap f as)
+  SInsert -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))
+  SName -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))
+  SReify context -> \f g (AHList as) -> AHList (smapList context f g as)
+
+
+sfromColumnsList :: Table (Reify context) a
+  => SContext context
+  -> HListTable (Columns a) (Col (Reify context))
+  -> AHList context a
+sfromColumnsList = \case
+  SAggregate -> AHList . ListTable
+  SExpr -> AHList . ListTable
+  SIdentity -> AHList . fmap (fromColumns . hreify) . fromColumns . hunreify
+  SInsert -> AHList . ListTable
+  SName -> AHList . ListTable
+  SReify context ->
+    AHList .
+    smapList context (fromColumns . hreify) hreify .
+    sfromColumnsList context .
+    hunreify
+
+
+stoColumnsList :: Table (Reify context) a
+  => SContext context
+  -> AHList context a
+  -> HListTable (Columns a) (Col (Reify context))
+stoColumnsList = \case
+  SAggregate -> \(AHList (ListTable a)) -> a
+  SExpr -> \(AHList (ListTable a)) -> a
+  SIdentity ->
+    hreify . toColumns . fmap (hunreify . toColumns) . (\(AHList a) -> a)
+  SInsert -> \(AHList (ListTable a)) -> a
+  SName -> \(AHList (ListTable a)) -> a
+  SReify context ->
+    hreify .
+    stoColumnsList context .
+    smapList context (hunreify . toColumns) hunreify .
+    (\(AHList a) -> a)
+
+
+smapMaybe :: ()
+  => SContext context
+  -> (a -> b)
+  -> AHMaybe context a
+  -> AHMaybe context b
+smapMaybe = \case
+  SAggregate -> \f (AHMaybe a) -> AHMaybe (fmap f a)
+  SExpr -> \f (AHMaybe a) -> AHMaybe (fmap f a)
+  SIdentity -> \f (AHMaybe a) -> AHMaybe (fmap f a)
+  SInsert -> \f (AHMaybe a) -> AHMaybe (fmap f a)
+  SName -> \f (AHMaybe a) -> AHMaybe (fmap f a)
+  SReify context -> \f (AHMaybe a) -> AHMaybe (smapMaybe context f a)
+
+
+sfromColumnsMaybe :: Table (Reify context) a
+  => SContext context
+  -> HMaybeTable (Columns a) (Col (Reify context))
+  -> AHMaybe context a
+sfromColumnsMaybe = \case
+  SAggregate -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
+  SExpr -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
+  SIdentity -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
+  SInsert -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
+  SName -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
+  SReify context ->
+    AHMaybe .
+    smapMaybe context (fromColumns . hreify) .
+    sfromColumnsMaybe context .
+    hunreify
+
+
+stoColumnsMaybe :: Table (Reify context) a
+  => SContext context
+  -> AHMaybe context a
+  -> HMaybeTable (Columns a) (Col (Reify context))
+stoColumnsMaybe = \case
+  SAggregate ->
+    hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)
+  SExpr ->
+    hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)
+  SIdentity ->
+    hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)
+  SInsert ->
+    hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)
+  SName ->
+    hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)
+  SReify context ->
+    hreify .
+    stoColumnsMaybe context .
+    smapMaybe context (hunreify . toColumns) .
+    (\(AHMaybe a) -> a)
+
+
+smapNonEmpty :: Congruent a b
+  => SContext context
+  -> (a -> b)
+  -> (HNonEmptyTable (Columns a) (Col (Context a)) -> HNonEmptyTable (Columns b) (Col (Context b)))
+  -> AHNonEmpty context a
+  -> AHNonEmpty context b
+smapNonEmpty = \case
+  SAggregate -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))
+  SExpr -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))
+  SIdentity -> \f _ (AHNonEmpty as) -> AHNonEmpty (fmap f as)
+  SInsert -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))
+  SName -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))
+  SReify context -> \f g (AHNonEmpty as) -> AHNonEmpty (smapNonEmpty context f g as)
+
+
+sfromColumnsNonEmpty :: Table (Reify context) a
+  => SContext context
+  -> HNonEmptyTable (Columns a) (Col (Reify context))
+  -> AHNonEmpty context a
+sfromColumnsNonEmpty = \case
+  SAggregate -> AHNonEmpty . NonEmptyTable
+  SExpr -> AHNonEmpty . NonEmptyTable
+  SIdentity ->
+    AHNonEmpty . fmap (fromColumns . hreify) . fromColumns . hunreify
+  SInsert -> AHNonEmpty . NonEmptyTable
+  SName -> AHNonEmpty . NonEmptyTable
+  SReify context ->
+    AHNonEmpty .
+    smapNonEmpty context (fromColumns . hreify) hreify .
+    sfromColumnsNonEmpty context .
+    hunreify
+
+
+stoColumnsNonEmpty :: Table (Reify context) a
+  => SContext context
+  -> AHNonEmpty context a
+  -> HNonEmptyTable (Columns a) (Col (Reify context))
+stoColumnsNonEmpty = \case
+  SAggregate -> \(AHNonEmpty (NonEmptyTable a)) -> a
+  SExpr -> \(AHNonEmpty (NonEmptyTable a)) -> a
+  SIdentity ->
+    hreify . toColumns . fmap (hunreify . toColumns) . (\(AHNonEmpty a) -> a)
+  SInsert -> \(AHNonEmpty (NonEmptyTable a)) -> a
+  SName -> \(AHNonEmpty (NonEmptyTable a)) -> a
+  SReify context ->
+    hreify .
+    stoColumnsNonEmpty context .
+    smapNonEmpty context (hunreify . toColumns) hunreify .
+    (\(AHNonEmpty a) -> a)
+
+
+sbimapThese :: ()
+  => SContext context
+  -> (a -> c)
+  -> (b -> d)
+  -> AHThese context a b
+  -> AHThese context c d
+sbimapThese = \case
+  SAggregate -> \f g (AHThese a) -> AHThese (bimap f g a)
+  SExpr -> \f g (AHThese a) -> AHThese (bimap f g a)
+  SIdentity -> \f g (AHThese a) -> AHThese (bimap f g a)
+  SInsert -> \f g (AHThese a) -> AHThese (bimap f g a)
+  SName -> \f g (AHThese a) -> AHThese (bimap f g a)
+  SReify context -> \f g (AHThese a) -> AHThese (sbimapThese context f g a)
+
+
+sfromColumnsThese :: (Table (Reify context) a, Table (Reify context) b)
+  => SContext context
+  -> HTheseTable (Columns a) (Columns b) (Col (Reify context))
+  -> AHThese context a b
+sfromColumnsThese = \case
+  SAggregate ->
+    AHThese .
+    bimap (fromColumns . hreify) (fromColumns . hreify) .
+    fromColumns .
+    hunreify
+  SExpr ->
+    AHThese .
+    bimap (fromColumns . hreify) (fromColumns . hreify) .
+    fromColumns .
+    hunreify
+  SIdentity ->
+    AHThese .
+    bimap (fromColumns . hreify) (fromColumns . hreify) .
+    fromColumns .
+    hunreify
+  SInsert ->
+    AHThese .
+    bimap (fromColumns . hreify) (fromColumns . hreify) .
+    fromColumns .
+    hunreify
+  SName ->
+    AHThese .
+    bimap (fromColumns . hreify) (fromColumns . hreify) .
+    fromColumns .
+    hunreify
+  SReify context ->
+    AHThese .
+    sbimapThese context (fromColumns . hreify) (fromColumns . hreify) .
+    sfromColumnsThese context .
+    hunreify
+
+
+stoColumnsThese :: (Table (Reify context) a, Table (Reify context) b)
+  => SContext context
+  -> AHThese context a b
+  -> HTheseTable (Columns a) (Columns b) (Col (Reify context))
+stoColumnsThese = \case
+  SAggregate ->
+    hreify .
+    toColumns .
+    bimap (hunreify . toColumns) (hunreify . toColumns) .
+    (\(AHThese a) -> a)
+  SExpr ->
+    hreify .
+    toColumns .
+    bimap (hunreify . toColumns) (hunreify . toColumns) .
+    (\(AHThese a) -> a)
+  SIdentity ->
+    hreify .
+    toColumns .
+    bimap (hunreify . toColumns) (hunreify . toColumns) .
+    (\(AHThese a) -> a)
+  SInsert ->
+    hreify .
+    toColumns .
+    bimap (hunreify . toColumns) (hunreify . toColumns) .
+    (\(AHThese a) -> a)
+  SName ->
+    hreify .
+    toColumns .
+    bimap (hunreify . toColumns) (hunreify . toColumns) .
+    (\(AHThese a) -> a)
+  SReify context ->
+    hreify .
+    stoColumnsThese context .
+    sbimapThese context (hunreify . toColumns) (hunreify . toColumns) .
+    (\(AHThese a) -> a)
+
+
+hreify :: HTable t => t (Col context) -> t (Col (Reify context))
+hreify a = htabulate $ \field -> Reify (hfield a field)
+
+
+hunreify :: HTable t => t (Col (Reify context)) -> t (Col context)
+hunreify a = htabulate $ \field -> case hfield a field of
+  Reify x -> x

src/Rel8/Schema/Generic/Test.hs

@@ -4,8 +4,6 @@
 {-# language DerivingStrategies #-}
 {-# language DuplicateRecordFields #-}
 
-{-# options_ghc -O0 #-}
-
 module Rel8.Schema.Generic.Test
   ( module Rel8.Schema.Generic.Test
   )
@@ -17,6 +15,7 @@ import Prelude
 
 -- rel8
 import Rel8.Schema.Column
+import Rel8.Schema.Field
 import Rel8.Schema.Generic
 
 -- text
@@ -24,7 +23,7 @@ import Data.Text ( Text )
 
 
 data Table f = Table
-  { foo :: Column f (Label "blah" Bool)
+  { foo :: Column f Bool
   , bar :: Column f (Maybe Bool)
   }
   deriving stock Generic
@@ -40,7 +39,7 @@ data TablePair f = TablePair
 
 
 data TableMaybe f = TableMaybe
-  { foo :: Column f (Label "ABC" [Maybe Bool])
+  { foo :: Column f [Maybe Bool]
   , bars :: HMaybe f (TablePair f, TablePair f)
   }
   deriving stock Generic
@@ -49,7 +48,7 @@ data TableMaybe f = TableMaybe
 
 data TableEither f = TableEither
   { foo :: Column f Bool
-  , bars :: HEither f (HMaybe f (TablePair f, TablePair f)) (Column f (Label "XYZ" Char))
+  , bars :: HEither f (HMaybe f (TablePair f, TablePair f)) (Column f Char)
   }
   deriving stock Generic
   deriving anyclass Rel8able

src/Rel8/Schema/HTable/Either.hs

@@ -2,27 +2,22 @@
 {-# language DeriveAnyClass #-}
 {-# language DeriveGeneric #-}
 {-# language DerivingStrategies #-}
-{-# language FlexibleInstances #-}
 {-# language StandaloneKindSignatures #-}
-{-# language UndecidableInstances #-}
-{-# language UndecidableSuperClasses #-}
 
 module Rel8.Schema.HTable.Either
   ( HEitherTable(..)
-  , HEitherNullifiable
   )
 where
 
 -- base
-import Data.Kind ( Constraint )
 import GHC.Generics ( Generic )
 import Prelude ()
 
 -- rel8
 import Rel8.Kind.Necessity ( Necessity( Required ) )
-import Rel8.Schema.Context.Nullify ( HNullifiable, HConstrainTag )
 import Rel8.Schema.HTable ( HTable )
 import Rel8.Schema.HTable.Identity ( HIdentity(..) )
+import Rel8.Schema.HTable.Label ( HLabel )
 import Rel8.Schema.HTable.Nullify ( HNullify )
 import qualified Rel8.Schema.Kind as K
 import Rel8.Schema.Spec ( Spec( Spec ) )
@@ -32,13 +27,8 @@ import Rel8.Type.Tag ( EitherTag )
 type HEitherTable :: K.HTable -> K.HTable -> K.HTable
 data HEitherTable left right context = HEitherTable
   { htag :: HIdentity ('Spec '["isRight"] 'Required EitherTag) context
-  , hleft :: HNullify left context
+  , hleft :: HLabel "Left" (HNullify left) context
-  , hright :: HNullify right context
+  , hright :: HLabel "Right" (HNullify right) context
   }
   deriving stock Generic
   deriving anyclass HTable
-
-
-type HEitherNullifiable :: K.HContext -> Constraint
-class (HNullifiable context, HConstrainTag context EitherTag) => HEitherNullifiable context
-instance (HNullifiable context, HConstrainTag context EitherTag) => HEitherNullifiable context

src/Rel8/Schema/HTable/MapTable.hs

@@ -35,13 +35,15 @@ import Rel8.Schema.Dict ( Dict( Dict ) )
 
 
 type HMapTable :: (a -> Exp b) -> ((a -> Type) -> Type) -> (b -> Type) -> Type
-data HMapTable f t g where
+newtype HMapTable f t g = HMapTable
-  HMapTable :: { unHMapTable :: t (Precompose f g) } -> HMapTable f t g
+  { unHMapTable :: t (Precompose f g)
+  }
 
 
 type Precompose :: (a -> Exp b) -> (b -> Type) -> a -> Type
-newtype Precompose f g x where
+newtype Precompose f g x = Precompose
-  Precompose :: { precomposed :: g (Eval (f x)) } -> Precompose f g x
+  { precomposed :: g (Eval (f x))
+  }
 
 
 type HMapTableField :: (Spec -> Exp a) -> K.HTable -> a -> Type
@@ -64,6 +66,7 @@ instance (HTable t, MapSpec f) => HTable (HMapTable f t) where
 
   htraverse f (HMapTable x) = 
     HMapTable <$> htraverse (fmap Precompose . f . precomposed) x
+  {-# INLINABLE htraverse #-}
 
   hdicts :: forall c. HConstrainTable (HMapTable f t) c => HMapTable f t (Dict c)
   hdicts = 
@@ -73,6 +76,7 @@ instance (HTable t, MapSpec f) => HTable (HMapTable f t) where
 
   hspecs = 
     HMapTable $ htabulate $ Precompose . mapInfo @f . hfield hspecs
+  {-# INLINABLE hspecs #-}
 
 
 type MapSpec :: (Spec -> Exp Spec) -> Constraint

src/Rel8/Schema/HTable/Maybe.hs

@@ -2,42 +2,32 @@
 {-# language DeriveAnyClass #-}
 {-# language DeriveGeneric #-}
 {-# language DerivingStrategies #-}
-{-# language FlexibleInstances #-}
 {-# language StandaloneKindSignatures #-}
-{-# language UndecidableInstances #-}
-{-# language UndecidableSuperClasses #-}
 
 module Rel8.Schema.HTable.Maybe
   ( HMaybeTable(..)
-  , HMaybeNullifiable
   )
 where
 
 -- base
-import Data.Kind ( Constraint )
 import GHC.Generics ( Generic )
 import Prelude
 
 -- rel8
 import Rel8.Kind.Necessity ( Necessity( Required ) )
-import Rel8.Schema.Context.Nullify ( HConstrainTag, HNullifiable )
 import Rel8.Schema.HTable ( HTable )
 import Rel8.Schema.HTable.Identity ( HIdentity(..) )
+import Rel8.Schema.HTable.Label ( HLabel )
+import Rel8.Schema.HTable.Nullify ( HNullify )
 import qualified Rel8.Schema.Kind as K
 import Rel8.Schema.Spec ( Spec( Spec ) )
 import Rel8.Type.Tag ( MaybeTag )
-import Rel8.Schema.HTable.Nullify ( HNullify )
 
 
 type HMaybeTable :: K.HTable -> K.HTable
 data HMaybeTable table context = HMaybeTable
   { htag :: HIdentity ('Spec '["isJust"] 'Required (Maybe MaybeTag)) context
-  , hjust :: HNullify table context
+  , hjust :: HLabel "Just" (HNullify table) context
   }
   deriving stock Generic
   deriving anyclass HTable
-
-
-type HMaybeNullifiable :: K.HContext -> Constraint
-class (HNullifiable context, HConstrainTag context MaybeTag) => HMaybeNullifiable context
-instance (HNullifiable context, HConstrainTag context MaybeTag) => HMaybeNullifiable context

src/Rel8/Schema/HTable/These.hs

@@ -17,6 +17,7 @@ import Prelude
 import Rel8.Kind.Necessity ( Necessity( Required ) )
 import Rel8.Schema.HTable ( HTable )
 import Rel8.Schema.HTable.Identity ( HIdentity )
+import Rel8.Schema.HTable.Label ( HLabel )
 import Rel8.Schema.HTable.Nullify ( HNullify )
 import qualified Rel8.Schema.Kind as K
 import Rel8.Schema.Spec ( Spec( Spec ) )
@@ -26,9 +27,9 @@ import Rel8.Type.Tag ( MaybeTag )
 type HTheseTable :: K.HTable -> K.HTable -> K.HTable
 data HTheseTable here there context = HTheseTable
   { hhereTag :: HIdentity ('Spec '["hasHere"] 'Required (Maybe MaybeTag)) context
-  , hhere :: HNullify here context
+  , hhere :: HLabel "Here" (HNullify here) context
   , hthereTag :: HIdentity ('Spec '["hasThere"] 'Required (Maybe MaybeTag)) context
-  , hthere :: HNullify there context
+  , hthere :: HLabel "There" (HNullify there) context
   }
   deriving stock Generic
   deriving anyclass HTable

src/Rel8/Schema/HTable/Vectorize.hs

@@ -23,7 +23,6 @@ module Rel8.Schema.HTable.Vectorize
   ( HVectorize
   , hvectorize, hunvectorize
   , happend, hempty
-  , hrelabel
   )
 where
 
@@ -150,10 +149,3 @@ hempty empty = HVectorize $ htabulate $ \(HMapTableField field) -> case hfield h
 instance HLabelable g => HLabelable (Precompose (Vectorize list) g) where
   hlabeler = Precompose . hlabeler . precomposed
   hunlabeler = Precompose . hunlabeler . precomposed
-
-
-hrelabel :: HLabelable context
-  => (forall ctx. HLabelable ctx => t ctx -> u ctx)
-  -> HVectorize list t context
-  -> HVectorize list u context
-hrelabel f (HVectorize (HMapTable table)) = HVectorize (HMapTable (f table))

src/Rel8/Schema/Insert.hs

@@ -15,8 +15,8 @@ module Rel8.Schema.Insert
   ( Insert(..)
   , OnConflict(..)
   , Col( RequiredInsert, OptionalInsert )
-  , Insertion(..)
   , Inserts
+  , Insertion(..)
   )
 where
 
@@ -35,7 +35,7 @@ import Rel8.Schema.Context.Nullify
   ( Nullifiable, encodeTag, decodeTag, nullifier, unnullifier
   , runTag, unnull
   )
-import Rel8.Schema.HTable.Type ( HType(HType) )
+import Rel8.Schema.HTable.Type ( HType( HType ) )
 import qualified Rel8.Schema.Kind as K
 import Rel8.Schema.Name ( Name, Selects )
 import Rel8.Schema.Null ( Sql )

src/Rel8/Schema/Structure.hs

@@ -1,54 +1,17 @@
 {-# language DataKinds #-}
 {-# language StandaloneKindSignatures #-}
-{-# language PolyKinds #-}
-{-# language TypeFamilies #-}
 
 module Rel8.Schema.Structure
   ( Structure
-  , Shape( Column, Either, List, Maybe, NonEmpty, These )
-  , Shape1
-  , Shape2
-  , IsStructure
   )
 where
 
 -- base
-import Data.Kind ( Type )
+import Prelude ()
-import Prelude
 
 -- rel8
-import qualified Rel8.Schema.Kind as K
+import Rel8.Schema.Kind ( Context )
-import Rel8.Schema.Spec ( Spec )
 
 
-type Structure :: K.Context
+type Structure :: Context
 data Structure a
-
-
-type Shape :: Type
-data Shape
-  = Column Spec
-  | Either Type Type
-  | List Type
-  | Maybe Type
-  | NonEmpty Type
-  | These Type Type
-
-
-type Shape1 :: (a -> Shape) -> a -> Type
-data Shape1 shape a
-
-
-type Shape2 :: (a -> b -> Shape) -> a -> b -> Type
-data Shape2 shape a b
-
-
-type IsStructure :: Type -> Bool
-type family IsStructure a where
-  IsStructure (Shape1 _ _) = 'True
-  IsStructure (Shape2 _ _ _) = 'True
-  IsStructure (_, _) = 'True
-  IsStructure (_, _, _) = 'True
-  IsStructure (_, _, _, _) = 'True
-  IsStructure (_, _, _, _, _) = 'True
-  IsStructure _ = 'False

src/Rel8/Table.hs

@@ -3,8 +3,11 @@
 {-# language FlexibleContexts #-}
 {-# language FlexibleInstances #-}
 {-# language FunctionalDependencies #-}
+{-# language LambdaCase #-}
+{-# language NamedFieldPuns #-}
 {-# language StandaloneKindSignatures #-}
 {-# language TypeFamilies #-}
+{-# language TypeOperators #-}
 {-# language UndecidableInstances #-}
 
 module Rel8.Table
@@ -15,25 +18,39 @@ module Rel8.Table
 where
 
 -- base
+import Data.Functor ( ($>) )
 import Data.Functor.Identity ( Identity( Identity ) )
 import Data.Kind ( Constraint, Type )
-import Prelude
+import Data.List.NonEmpty ( NonEmpty )
+import Prelude hiding ( null )
 
 -- rel8
 import Rel8.Schema.Context ( Col(..) )
 import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
 import Rel8.Schema.HTable ( HTable )
+import Rel8.Schema.HTable.Either ( HEitherTable(..) )
 import Rel8.Schema.HTable.Identity ( HIdentity(..) )
 import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
+import Rel8.Schema.HTable.List ( HListTable )
+import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
+import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
+import Rel8.Schema.HTable.Nullify ( hnulls, hnullify, hunnullify )
 import Rel8.Schema.HTable.Pair ( HPair(..) )
 import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
 import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
+import Rel8.Schema.HTable.These ( HTheseTable(..) )
 import Rel8.Schema.HTable.Trio ( HTrio(..) )
 import Rel8.Schema.HTable.Type ( HType( HType ) )
+import Rel8.Schema.HTable.Vectorize ( hvectorize, hunvectorize )
 import qualified Rel8.Schema.Kind as K
-import Rel8.Schema.Null ( Sql )
+import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql )
-import Rel8.Schema.Spec ( KnownSpec )
+import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..), KnownSpec )
 import Rel8.Type ( DBType )
+import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ),  MaybeTag( IsJust ) )
+
+-- these
+import Data.These ( These( This, That, These ) )
+import Data.These.Combinators ( justHere, justThere )
 
 
 -- | @Table@s are one of the foundational elements of Rel8, and describe data
@@ -85,6 +102,106 @@ instance Sql DBType a => Table Identity (Identity a) where
   fromColumns (HType (Result a)) = Identity a
 
 
+instance (Table Identity a, Table Identity b) => Table Identity (Either a b)
+ where
+  type Columns (Either a b) = HEitherTable (Columns a) (Columns b)
+  type Context (Either a b) = Identity
+
+  toColumns = \case
+    Left table -> HEitherTable
+      { htag = HIdentity (Result IsLeft)
+      , hleft = hlabel labeler (hnullify nullifier (toColumns table))
+      , hright = hlabel labeler (hnulls null)
+      }
+    Right table -> HEitherTable
+      { htag = HIdentity (Result IsRight)
+      , hleft = hlabel labeler (hnulls null)
+      , hright = hlabel labeler (hnullify nullifier (toColumns table))
+      }
+
+  fromColumns HEitherTable {htag, hleft, hright} = case htag of
+    HIdentity (Result tag) -> case tag of
+      IsLeft -> maybe err (Left . fromColumns) $ hunnullify unnullifier (hunlabel unlabeler hleft)
+      IsRight -> maybe err (Right . fromColumns) $ hunnullify unnullifier (hunlabel unlabeler hright)
+    where
+      err = error "Either.fromColumns: mismatch between tag and data"
+
+
+instance Table Identity a => Table Identity [a] where
+  type Columns [a] = HListTable (Columns a)
+  type Context [a] = Identity
+
+  toColumns = hvectorize vectorizer . fmap toColumns
+  fromColumns = fmap fromColumns . hunvectorize unvectorizer
+
+
+instance Table Identity a => Table Identity (Maybe a) where
+  type Columns (Maybe a) = HMaybeTable (Columns a)
+  type Context (Maybe a) = Identity
+
+  toColumns = \case
+    Nothing -> HMaybeTable
+      { htag = HIdentity (Result Nothing)
+      , hjust = hlabel labeler (hnulls null)
+      }
+    Just table -> HMaybeTable
+      { htag = HIdentity (Result (Just IsJust))
+      , hjust = hlabel labeler (hnullify nullifier (toColumns table))
+      }
+
+  fromColumns HMaybeTable {htag, hjust} = case htag of
+    HIdentity (Result tag) -> tag $>
+      case hunnullify unnullifier (hunlabel unlabeler hjust) of
+        Nothing -> error "Maybe.fromColumns: mismatch between tag and data"
+        Just just -> fromColumns just
+
+
+instance Table Identity a => Table Identity (NonEmpty a) where
+  type Columns (NonEmpty a) = HNonEmptyTable (Columns a)
+  type Context (NonEmpty a) = Identity
+
+  toColumns = hvectorize vectorizer . fmap toColumns
+  fromColumns = fmap fromColumns . hunvectorize unvectorizer
+
+
+instance (Table Identity a, Table Identity b) => Table Identity (These a b)
+ where
+  type Columns (These a b) = HTheseTable (Columns a) (Columns b)
+  type Context (These a b) = Identity
+
+  toColumns tables = HTheseTable
+    { hhereTag = relabel hhereTag
+    , hhere = hlabel labeler (hunlabel unlabeler (toColumns hhere))
+    , hthereTag = relabel hthereTag
+    , hthere = hlabel labeler (hunlabel unlabeler (toColumns hthere))
+    }
+    where
+      HMaybeTable
+        { htag = hhereTag
+        , hjust = hhere
+        } = toColumns (justHere tables)
+      HMaybeTable
+        { htag = hthereTag
+        , hjust = hthere
+        } = toColumns (justThere tables)
+
+  fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} =
+    case (fromColumns mhere, fromColumns mthere) of
+      (Just a, Nothing) -> This (fromColumns a)
+      (Nothing, Just b) -> That (fromColumns b)
+      (Just a, Just b) -> These (fromColumns a) (fromColumns b)
+      _ -> error "These.fromColumns: mismatch between tags and data"
+    where
+      mhere = HMaybeTable
+        { htag = relabel hhereTag
+        , hjust = hlabel labeler (hunlabel unlabeler hhere)
+        }
+      mthere = HMaybeTable
+        { htag = relabel hthereTag
+        , hjust = hlabel labeler (hunlabel unlabeler hthere)
+        }
+
+
 instance
   ( Table context a, Table context b
   , Labelable context
@@ -192,3 +309,46 @@ instance
 type Congruent :: Type -> Type -> Constraint
 class Columns a ~ Columns b => Congruent a b
 instance Columns a ~ Columns b => Congruent a b
+
+
+null :: Col Identity ('Spec labels necessity (Maybe a))
+null = Result Nothing
+
+
+nullifier :: ()
+  => SSpec ('Spec labels necessity a)
+  -> Col Identity ('Spec labels necessity a)
+  -> Col Identity ('Spec labels necessity (Nullify a))
+nullifier SSpec {nullity} (Result a) = Result $ case nullity of
+  Null -> a
+  NotNull -> Just a
+
+
+unnullifier :: ()
+  => SSpec ('Spec labels necessity a)
+  -> Col Identity ('Spec labels necessity (Nullify a))
+  -> Maybe (Col Identity ('Spec labels necessity a))
+unnullifier SSpec {nullity} (Result a) =
+  case nullity of
+    Null -> pure $ Result a
+    NotNull -> Result <$> a
+
+
+vectorizer :: Functor f
+  => SSpec ('Spec labels necessity a)
+  -> f (Col Identity ('Spec labels necessity a))
+  -> Col Identity ('Spec labels necessity (f a))
+vectorizer _ = Result . fmap (\(Result a) -> a)
+
+
+unvectorizer :: Functor f
+  => SSpec ('Spec labels necessity a)
+  -> Col Identity ('Spec labels necessity (f a))
+  -> f (Col Identity ('Spec labels necessity a))
+unvectorizer _ (Result results) = Result <$> results
+
+
+relabel :: ()
+  => HIdentity ('Spec labels necessity a) (Col Identity)
+  -> HIdentity ('Spec relabels necessity a) (Col Identity)
+relabel (HIdentity (Result a)) = HIdentity (Result a)

src/Rel8/Table/Either.hs

@@ -30,23 +30,25 @@ import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )
 import Rel8.Expr ( Expr )
 import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
 import Rel8.Expr.Serialize ( litExpr )
-import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler, hlabeler )
+import Rel8.Schema.Context.Label
+  ( Labelable
+  , HLabelable, hlabeler, hunlabeler
+  )
 import Rel8.Schema.Context.Nullify
   ( Nullifiable, ConstrainTag
+  , HNullifiable, HConstrainTag
   , hencodeTag, hdecodeTag
   , hnullifier, hunnullifier
   )
-import Rel8.Schema.HTable.Either ( HEitherTable(..), HEitherNullifiable )
+import Rel8.Schema.HTable ( HTable )
+import Rel8.Schema.HTable.Either ( HEitherTable(..) )
 import Rel8.Schema.HTable.Identity ( HIdentity(..) )
-import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
+import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
 import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
 import Rel8.Schema.Name ( Name )
 import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
 import Rel8.Table.Bool ( bool )
 import Rel8.Table.Eq ( EqTable, eqTable )
-import Rel8.Table.Lifted
-  ( Table2, Columns2, ConstrainHContext2, fromColumns2, toColumns2
-  )
 import Rel8.Table.Ord ( OrdTable, ordTable )
 import Rel8.Table.Recontextualize ( Recontextualize )
 import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )
@@ -95,51 +97,17 @@ instance (Table Expr a, Table Expr b) => Semigroup (EitherTable a b) where
   a <> b = bool a b (isRightTable a)
 
 
-instance Table2 EitherTable where
-  type Columns2 EitherTable = HEitherTable
-  type ConstrainHContext2 EitherTable = HEitherNullifiable
-
-  toColumns2 f g EitherTable {tag, left, right} = HEitherTable
-    { htag
-    , hleft = hnullify (hnullifier tag isLeft) $ f left
-    , hright = hnullify (hnullifier tag isRight) $ g right
-    }
-    where
-      htag = HIdentity (hencodeTag tag)
-
-  fromColumns2 f g HEitherTable {htag = htag, hleft, hright} =
-    EitherTable
-      { tag
-      , left = f $ runIdentity $
-          hunnullify (\a -> pure . hunnullifier a) hleft
-      , right = g $ runIdentity $
-          hunnullify (\a -> pure . hunnullifier a) hright
-      }
-    where
-      tag = hdecodeTag $ unHIdentity htag
-
-  {-# INLINABLE fromColumns2 #-}
-  {-# INLINABLE toColumns2 #-}
-
-
 instance
   ( Table context a, Table context b
   , Labelable context, Nullifiable context, ConstrainTag context EitherTag
   ) =>
   Table context (EitherTable a b)
  where
-  type Columns (EitherTable a b) =
+  type Columns (EitherTable a b) = HEitherTable (Columns a) (Columns b)
-    HEitherTable (HLabel "Left" (Columns a)) (HLabel "Right" (Columns b))
   type Context (EitherTable a b) = Context a
 
-  toColumns =
+  toColumns = toColumns2 toColumns toColumns
-    toColumns2
+  fromColumns = fromColumns2 fromColumns fromColumns
-      (hlabel labeler . toColumns)
-      (hlabel labeler . toColumns)
-  fromColumns =
-    fromColumns2
-      (fromColumns . hunlabel unlabeler)
-      (fromColumns . hunlabel unlabeler)
 
 
 instance
@@ -152,15 +120,11 @@ instance
 
 
 instance (EqTable a, EqTable b) => EqTable (EitherTable a b) where
-  eqTable =
+  eqTable = toColumns2 id id (rightTableWith (eqTable @a) (eqTable @b))
-    toColumns2 (hlabel hlabeler) (hlabel hlabeler)
-      (rightTableWith (eqTable @a) (eqTable @b))
 
 
 instance (OrdTable a, OrdTable b) => OrdTable (EitherTable a b) where
-  ordTable =
+  ordTable = toColumns2 id id (rightTableWith (ordTable @a) (ordTable @b))
-    toColumns2 (hlabel hlabeler) (hlabel hlabeler)
-      (rightTableWith (ordTable @a) (ordTable @b))
 
 
 isLeftTable :: EitherTable a b -> Expr Bool
@@ -203,3 +167,49 @@ aggregateEitherTable f g EitherTable {tag, left, right} =
 
 nameEitherTable :: Name EitherTag -> a -> b -> EitherTable a b
 nameEitherTable = EitherTable . fromName
+
+
+toColumns2 ::
+  ( HTable t
+  , HTable u
+  , HConstrainTag context EitherTag
+  , HLabelable context
+  , HNullifiable context
+  )
+  => (a -> t context)
+  -> (b -> u context)
+  -> EitherTable a b
+  -> HEitherTable t u context
+toColumns2 f g EitherTable {tag, left, right} = HEitherTable
+  { htag
+  , hleft = hlabel hlabeler $ hnullify (hnullifier tag isLeft) $ f left
+  , hright = hlabel hlabeler $ hnullify (hnullifier tag isRight) $ g right
+  }
+  where
+    htag = HIdentity (hencodeTag tag)
+
+
+fromColumns2 ::
+  ( HTable t
+  , HTable u
+  , HConstrainTag context EitherTag
+  , HLabelable context
+  , HNullifiable context
+  )
+  => (t context -> a)
+  -> (u context -> b)
+  -> HEitherTable t u context
+  -> EitherTable a b
+fromColumns2 f g HEitherTable {htag, hleft, hright} = EitherTable
+  { tag
+  , left = f $ runIdentity $
+     hunnullify (\a -> pure . hunnullifier a) $
+     hunlabel hunlabeler
+     hleft
+  , right = g $ runIdentity $
+     hunnullify (\a -> pure . hunnullifier a) $
+     hunlabel hunlabeler
+     hright
+  }
+  where
+    tag = hdecodeTag $ unHIdentity htag

src/Rel8/Table/Lifted.hs

@@ -1,81 +0,0 @@
-{-# language ConstraintKinds #-}
-{-# language DataKinds #-}
-{-# language FlexibleContexts #-}
-{-# language FlexibleInstances #-}
-{-# language MultiParamTypeClasses #-}
-{-# language QuantifiedConstraints #-}
-{-# language StandaloneKindSignatures #-}
-{-# language TypeFamilies #-}
-{-# language UndecidableInstances #-}
-
-module Rel8.Table.Lifted
-  ( Table1( Columns1, ConstrainHContext1, toColumns1, fromColumns1 )
-  , Table2( Columns2, ConstrainHContext2, toColumns2, fromColumns2 )
-  , ConstrainContext
-  )
-where
-
--- base
-import Data.Kind ( Constraint, Type )
-import Prelude ()
-
--- rel8
-import Rel8.Schema.Context ( Col )
-import Rel8.Schema.HTable ( HTable )
-import Rel8.Schema.HTable.Pair
-import qualified Rel8.Schema.Kind as K
-
-
-type Table1 :: (Type -> Type) -> Constraint
-class Table1 f where
-  type Columns1 f :: K.HTable -> K.HTable
-  type ConstrainHContext1 f :: K.HContext -> Constraint
-  type ConstrainHContext1 _ = DefaultConstrainContext
-
-  toColumns1 :: (ConstrainHContext1 f context, HTable t)
-    => (a -> t context)
-    -> f a
-    -> Columns1 f t context
-
-  fromColumns1 :: (ConstrainHContext1 f context, HTable t)
-    => (t context -> a)
-    -> Columns1 f t context
-    -> f a
-
-
-type Table2 :: (Type -> Type -> Type) -> Constraint
-class Table2 p where
-  type Columns2 p :: K.HTable -> K.HTable -> K.HTable
-  type ConstrainHContext2 p :: K.HContext -> Constraint
-  type ConstrainHContext2 _ = DefaultConstrainContext
-
-  toColumns2 :: (ConstrainHContext2 p context, HTable t, HTable u)
-    => (a -> t context)
-    -> (b -> u context)
-    -> p a b
-    -> Columns2 p t u context
-
-  fromColumns2 :: (ConstrainHContext2 p context, HTable t, HTable u)
-    => (t context -> a)
-    -> (u context -> b)
-    -> Columns2 p t u context
-    -> p a b
-
-
-instance Table2 (,) where
-  type Columns2 (,) = HPair
-
-  toColumns2 f g (a, b) = HPair (f a) (g b)
-  fromColumns2 f g (HPair a b) = (f a, g b)
-
-
-type DefaultConstrainContext :: K.HContext -> Constraint
-class DefaultConstrainContext context
-instance DefaultConstrainContext context
-
-
-type ConstrainContext :: (K.Context -> Constraint) -> K.HContext -> Constraint
-class (forall context. hcontext ~ Col context => constraint context)
-  => ConstrainContext constraint hcontext
-instance (hcontext ~ Col context, constraint context) =>
-  ConstrainContext constraint hcontext

src/Rel8/Table/Maybe.hs

@@ -24,7 +24,7 @@ where
 -- base
 import Data.Functor.Identity ( runIdentity )
 import Data.Kind ( Type )
-import Prelude hiding ( null, repeat, undefined, zipWith )
+import Prelude hiding ( null, undefined )
 
 -- rel8
 import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )
@@ -32,15 +32,19 @@ import Rel8.Expr ( Expr )
 import Rel8.Expr.Bool ( boolExpr )
 import Rel8.Expr.Null ( isNull, isNonNull, null, nullify )
 import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
-import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler, hlabeler )
+import Rel8.Schema.Context.Label
+  ( Labelable, HLabelable, hlabeler, hunlabeler
+  )
 import Rel8.Schema.Context.Nullify
   ( Nullifiable, ConstrainTag
+  , HNullifiable, HConstrainTag
   , hencodeTag, hdecodeTag
   , hnullifier, hunnullifier
   )
+import Rel8.Schema.HTable ( HTable )
 import Rel8.Schema.HTable.Identity ( HIdentity(..) )
-import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
+import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
-import Rel8.Schema.HTable.Maybe ( HMaybeTable(..), HMaybeNullifiable )
+import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
 import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
 import Rel8.Schema.Name ( Name )
 import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql, nullable )
@@ -51,9 +55,6 @@ import Rel8.Table.Alternative
   )
 import Rel8.Table.Bool ( bool )
 import Rel8.Table.Eq ( EqTable, eqTable )
-import Rel8.Table.Lifted
-  ( Table1, Columns1, ConstrainHContext1, fromColumns1, toColumns1
-  )
 import Rel8.Table.Ord ( OrdTable, ordTable )
 import Rel8.Table.Recontextualize ( Recontextualize )
 import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )
@@ -127,40 +128,17 @@ instance (Table Expr a, Semigroup a) => Monoid (MaybeTable a) where
   mempty = nothingTable
 
 
-instance Table1 MaybeTable where
-  type Columns1 MaybeTable = HMaybeTable
-  type ConstrainHContext1 MaybeTable = HMaybeNullifiable
-
-  toColumns1 f MaybeTable {tag, just} = HMaybeTable
-    { htag
-    , hjust = hnullify (hnullifier tag isNonNull) $ f just
-    }
-    where
-      htag = HIdentity (hencodeTag tag)
-
-  fromColumns1 f HMaybeTable {htag = HIdentity htag, hjust} = MaybeTable
-    { tag
-    , just = f $ runIdentity $
-        hunnullify (\a -> pure . hunnullifier a) hjust
-    }
-    where
-      tag = hdecodeTag htag
-
-  {-# INLINABLE fromColumns1 #-}
-  {-# INLINABLE toColumns1 #-}
-
-
 instance
   ( Table context a
   , Labelable context, Nullifiable context
   , ConstrainTag context MaybeTag
   ) => Table context (MaybeTable a)
  where
-  type Columns (MaybeTable a) = HMaybeTable (HLabel "Just" (Columns a))
+  type Columns (MaybeTable a) = HMaybeTable (Columns a)
   type Context (MaybeTable a) = Context a
 
-  toColumns = toColumns1 (hlabel labeler . toColumns)
+  toColumns = toColumns1 toColumns
-  fromColumns = fromColumns1 (fromColumns . hunlabel unlabeler)
+  fromColumns = fromColumns1 fromColumns
 
 
 instance
@@ -171,11 +149,11 @@ instance
 
 
 instance EqTable a => EqTable (MaybeTable a) where
-  eqTable = toColumns1 (hlabel hlabeler) (justTable (eqTable @a))
+  eqTable = toColumns1 id (justTable (eqTable @a))
 
 
 instance OrdTable a => OrdTable (MaybeTable a) where
-  ordTable = toColumns1 (hlabel hlabeler) (justTable (ordTable @a))
+  ordTable = toColumns1 id (justTable (ordTable @a))
 
 
 -- | Check if a @MaybeTable@ is absent of any row. Like 'Data.Maybe.isNothing'.
@@ -226,3 +204,38 @@ aggregateMaybeTable f MaybeTable {tag = tag@Tag {aggregator, expr}, just} =
 
 nameMaybeTable :: Name (Maybe MaybeTag) -> a -> MaybeTable a
 nameMaybeTable = MaybeTable . fromName
+
+
+toColumns1 ::
+  ( HTable t
+  , HConstrainTag context MaybeTag
+  , HLabelable context
+  , HNullifiable context
+  )
+  => (a -> t context)
+  -> MaybeTable a
+  -> HMaybeTable t context
+toColumns1 f MaybeTable {tag, just} = HMaybeTable
+  { htag
+  , hjust = hlabel hlabeler $ hnullify (hnullifier tag isNonNull) $ f just
+  }
+  where
+    htag = HIdentity (hencodeTag tag)
+
+
+fromColumns1 ::
+  ( HTable t
+  , HConstrainTag context MaybeTag
+  , HLabelable context
+  , HNullifiable context
+  )
+  => (t context -> a)
+  -> HMaybeTable t context
+  -> MaybeTable a
+fromColumns1 f HMaybeTable {htag = HIdentity htag, hjust} = MaybeTable
+  { tag
+  , just = f $ runIdentity $
+      hunnullify (\a -> pure . hunnullifier a) (hunlabel hunlabeler hjust)
+  }
+  where
+    tag = hdecodeTag htag

src/Rel8/Table/Serialize.hs

@@ -31,13 +31,6 @@ import qualified Hasql.Decoders as Hasql
 import Rel8.Expr ( Expr, Col(..) )
 import Rel8.Expr.Serialize ( slitExpr, sparseValue )
 import Rel8.Schema.Context ( Col(..) )
-import Rel8.Schema.Context.Identity
-  ( fromHEitherTable, toHEitherTable
-  , fromHListTable, toHListTable
-  , fromHMaybeTable, toHMaybeTable
-  , fromHNonEmptyTable, toHNonEmptyTable
-  , fromHTheseTable, toHTheseTable
-  )
 import Rel8.Schema.Context.Label ( labeler, unlabeler )
 import Rel8.Schema.HTable ( HTable, htabulate, htabulateA, hfield, hspecs )
 import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
@@ -104,50 +97,38 @@ instance (ToExprs a exprs1, ToExprs b exprs2, x ~ EitherTable exprs1 exprs2) =>
   ToExprs (Either a b) x
  where
   fromIdentity =
-    bimap
+    bimap (fromIdentity' @exprs1) (fromIdentity' @exprs2) .
-      (fromIdentity' @exprs1 . hunlabel unlabeler)
+    fromColumns
-      (fromIdentity' @exprs2 . hunlabel unlabeler) .
-    fromHEitherTable
   toIdentity =
-    toHEitherTable .
+    toColumns .
-    bimap
+    bimap (toIdentity' @exprs1) (toIdentity' @exprs2)
-      (hlabel labeler . toIdentity' @exprs1)
-      (hlabel labeler . toIdentity' @exprs2)
 
 
 instance ToExprs a exprs => ToExprs [a] (ListTable exprs) where
-  fromIdentity = fmap (fromIdentity' @exprs) . fromHListTable
+  fromIdentity = fmap (fromIdentity' @exprs) . fromColumns
-  toIdentity = toHListTable . fmap (toIdentity' @exprs)
+  toIdentity = toColumns . fmap (toIdentity' @exprs)
 
 
 instance ToExprs a exprs => ToExprs (Maybe a) (MaybeTable exprs) where
-  fromIdentity =
+  fromIdentity = fmap (fromIdentity' @exprs) . fromColumns
-    fmap (fromIdentity' @exprs . hunlabel unlabeler) .
+  toIdentity = toColumns . fmap (toIdentity' @exprs)
-    fromHMaybeTable
-  toIdentity =
-    toHMaybeTable .
-    fmap (hlabel labeler . toIdentity' @exprs)
 
 
 instance ToExprs a exprs => ToExprs (NonEmpty a) (NonEmptyTable exprs)
  where
-  fromIdentity = fmap (fromIdentity' @exprs) . fromHNonEmptyTable
+  fromIdentity = fmap (fromIdentity' @exprs) . fromColumns
-  toIdentity = toHNonEmptyTable . fmap (toIdentity' @exprs)
+  toIdentity = toColumns . fmap (toIdentity' @exprs)
 
 
 instance (ToExprs a exprs1, ToExprs b exprs2, x ~ TheseTable exprs1 exprs2) =>
   ToExprs (These a b) x
  where
   fromIdentity =
-    bimap
+    bimap (fromIdentity' @exprs1) (fromIdentity' @exprs2) .
-      (fromIdentity' @exprs1 . hunlabel unlabeler)
+    fromColumns
-      (fromIdentity' @exprs2 . hunlabel unlabeler) .
-    fromHTheseTable
   toIdentity =
-    toHTheseTable .
+    toColumns .
-    bimap
+    bimap (toIdentity' @exprs1) (toIdentity' @exprs2)
-      (hlabel labeler . toIdentity' @exprs1)
-      (hlabel labeler . toIdentity' @exprs2)
 
 
 instance (ToExprs a exprs1, ToExprs b exprs2, x ~ (exprs1, exprs2)) =>
@@ -251,22 +232,22 @@ instance (KnownSpec spec, x ~ Col Expr spec) =>
 
 
 type FromExprs :: Type -> Type
-type family FromExprs a where
+type family FromExprs a
-  FromExprs (Expr a) = a
+type instance FromExprs (Expr a) = a
-  FromExprs (Col Expr spec) = Col Identity spec
+type instance FromExprs (Col Expr spec) = Col Identity spec
-  FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)
+type instance FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)
-  FromExprs (ListTable a) = [FromExprs a]
+type instance FromExprs (ListTable a) = [FromExprs a]
-  FromExprs (MaybeTable a) = Maybe (FromExprs a)
+type instance FromExprs (MaybeTable a) = Maybe (FromExprs a)
-  FromExprs (NonEmptyTable a) = NonEmpty (FromExprs a)
+type instance FromExprs (NonEmptyTable a) = NonEmpty (FromExprs a)
-  FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)
+type instance FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)
-  FromExprs (a, b) = (FromExprs a, FromExprs b)
+type instance FromExprs (a, b) = (FromExprs a, FromExprs b)
-  FromExprs (a, b, c) = (FromExprs a, FromExprs b, FromExprs c)
+type instance FromExprs (a, b, c) = (FromExprs a, FromExprs b, FromExprs c)
-  FromExprs (a, b, c, d) =
+type instance FromExprs (a, b, c, d) =
-    (FromExprs a, FromExprs b, FromExprs c, FromExprs d)
+  (FromExprs a, FromExprs b, FromExprs c, FromExprs d)
-  FromExprs (a, b, c, d, e) =
+type instance FromExprs (a, b, c, d, e) =
-    (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e)
+  (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e)
-  FromExprs (t Expr) = t Identity
+type instance FromExprs (t Expr) = t Identity
-  FromExprs (t (Col Expr)) = t (Col Identity)
+type instance FromExprs (t (Col Expr)) = t (Col Identity)
 
 
 -- | @Serializable@ witnesses the one-to-one correspondence between the type

src/Rel8/Table/These.hs

@@ -34,23 +34,24 @@ import Rel8.Aggregate ( Aggregate )
 import Rel8.Expr ( Expr )
 import Rel8.Expr.Bool ( (&&.), not_ )
 import Rel8.Expr.Null ( isNonNull )
-import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler, hlabeler )
+import Rel8.Schema.Context.Label
+  ( Labelable
+  , HLabelable, hlabeler, hunlabeler
+  )
 import Rel8.Schema.Context.Nullify
   ( Nullifiable, ConstrainTag
+  , HNullifiable, HConstrainTag
   , hencodeTag, hdecodeTag
   , hnullifier, hunnullifier
   )
-import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
+import Rel8.Schema.HTable ( HTable )
+import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
 import Rel8.Schema.HTable.Identity ( HIdentity(..) )
-import Rel8.Schema.HTable.Maybe ( HMaybeNullifiable )
 import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
 import Rel8.Schema.HTable.These ( HTheseTable(..) )
 import Rel8.Schema.Name ( Name  )
 import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
 import Rel8.Table.Eq ( EqTable, eqTable )
-import Rel8.Table.Lifted
-  ( Table2, Columns2, ConstrainHContext2, fromColumns2, toColumns2
-  )
 import Rel8.Table.Maybe
   ( MaybeTable(..)
   , maybeTable, justTable, nothingTable
@@ -117,66 +118,16 @@ instance (Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>
     }
 
 
-instance Table2 TheseTable where
-  type Columns2 TheseTable = HTheseTable
-  type ConstrainHContext2 TheseTable = HMaybeNullifiable
-
-  toColumns2 f g TheseTable {here, there} = HTheseTable
-    { hhereTag = HIdentity $ hencodeTag (toHereTag (tag here))
-    , hhere =
-        hnullify (hnullifier (tag here) isNonNull) $ f (just here)
-    , hthereTag = HIdentity $ hencodeTag (toThereTag (tag there))
-    , hthere =
-        hnullify (hnullifier (tag there) isNonNull) $ g (just there)
-    }
-
-  fromColumns2 f g HTheseTable {hhereTag, hhere, hthereTag, hthere} =
-    TheseTable
-      { here =
-          let
-            tag = hdecodeTag $ unHIdentity hhereTag
-          in
-            MaybeTable
-              { tag
-              , just = f $
-                  runIdentity $
-                  hunnullify (\a -> pure . hunnullifier a)
-                  hhere
-              }
-      , there =
-          let
-            tag = hdecodeTag $ unHIdentity hthereTag
-          in
-            MaybeTable
-              { tag
-              , just = g $
-                  runIdentity $
-                  hunnullify (\a -> pure . hunnullifier a)
-                  hthere
-              }
-      }
-
-  {-# INLINABLE fromColumns2 #-}
-  {-# INLINABLE toColumns2 #-}
-
-
 instance
   ( Table context a, Table context b
   , Labelable context, Nullifiable context, ConstrainTag context MaybeTag
   ) => Table context (TheseTable a b)
  where
-  type Columns (TheseTable a b) =
+  type Columns (TheseTable a b) = HTheseTable (Columns a) (Columns b)
-    HTheseTable (HLabel "Here" (Columns a)) (HLabel "There" (Columns b))
   type Context (TheseTable a b) = Context a
 
-  toColumns =
+  toColumns = toColumns2 toColumns toColumns
-    toColumns2
+  fromColumns = fromColumns2 fromColumns fromColumns
-      (hlabel labeler . toColumns)
-      (hlabel labeler . toColumns)
-  fromColumns =
-    fromColumns2
-      (fromColumns . hunlabel unlabeler)
-      (fromColumns . hunlabel unlabeler)
 
 
 instance
@@ -189,15 +140,11 @@ instance
 
 
 instance (EqTable a, EqTable b) => EqTable (TheseTable a b) where
-  eqTable =
+  eqTable = toColumns2 id id (thoseTable (eqTable @a) (eqTable @b))
-    toColumns2 (hlabel hlabeler) (hlabel hlabeler)
-      (thoseTable (eqTable @a) (eqTable @b))
 
 
 instance (OrdTable a, OrdTable b) => OrdTable (TheseTable a b) where
-  ordTable =
+  ordTable = toColumns2 id id (thoseTable (ordTable @a) (ordTable @b))
-    toColumns2 (hlabel hlabeler) (hlabel hlabeler)
-      (thoseTable (ordTable @a) (ordTable @b))
 
 
 toHereTag :: Tag "isJust" a -> Tag "hasHere" a
@@ -277,3 +224,63 @@ nameTheseTable here there a b =
     { here = nameMaybeTable here a
     , there = nameMaybeTable there b
     }
+
+
+toColumns2 ::
+  ( HTable t
+  , HTable u
+  , HConstrainTag context MaybeTag
+  , HLabelable context
+  , HNullifiable context
+  )
+  => (a -> t context)
+  -> (b -> u context)
+  -> TheseTable a b
+  -> HTheseTable t u context
+toColumns2 f g TheseTable {here, there} = HTheseTable
+  { hhereTag = HIdentity $ hencodeTag (toHereTag (tag here))
+  , hhere =
+      hlabel hlabeler $ hnullify (hnullifier (tag here) isNonNull) $ f (just here)
+  , hthereTag = HIdentity $ hencodeTag (toThereTag (tag there))
+  , hthere =
+      hlabel hlabeler $ hnullify (hnullifier (tag there) isNonNull) $ g (just there)
+  }
+
+
+fromColumns2 ::
+  ( HTable t
+  , HTable u
+  , HConstrainTag context MaybeTag
+  , HLabelable context
+  , HNullifiable context
+  )
+  => (t context -> a)
+  -> (u context -> b)
+  -> HTheseTable t u context
+  -> TheseTable a b
+fromColumns2 f g HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable
+  { here =
+      let
+        tag = hdecodeTag $ unHIdentity hhereTag
+      in
+        MaybeTable
+          { tag
+          , just = f $
+              runIdentity $
+              hunnullify (\a -> pure . hunnullifier a) $
+              hunlabel hunlabeler
+              hhere
+          }
+  , there =
+      let
+        tag = hdecodeTag $ unHIdentity hthereTag
+      in
+        MaybeTable
+          { tag
+          , just = g $
+              runIdentity $
+              hunnullify (\a -> pure . hunnullifier a) $
+              hunlabel hunlabeler
+              hthere
+          }
+  }

src/Rel8/Type/Array.hs

@@ -32,6 +32,7 @@ array TypeInformation {typeName} =
   fromPrimArray .
   Opaleye.CastExpr (typeName <> "[]") .
   Opaleye.ArrayExpr . toList
+{-# INLINABLE array #-}
 
 
 listTypeInformation :: ()

src/Rel8/Type/Tag.hs

@@ -19,7 +19,7 @@ import Prelude
 import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
 
 -- rel8
-import Rel8.Expr ( Expr )
+import {-# SOURCE #-} Rel8.Expr ( Expr )
 import Rel8.Expr.Eq ( (==.) )
 import Rel8.Expr.Opaleye ( zipPrimExprsWith )
 import Rel8.Expr.Serialize ( litExpr )