Add Projection and Field (#112)

A `Projection a b` is a special type of function `a -> b` whereby the resulting `b` is guaranteed to be composed only from columns contained in `a`.

We can use this fact to give `ListTable` and `NonEmptyTable` a limit kind of functor. We call this functor `Projectable`, and its `fmap` is called `project`. There's also `Biprojectable` and `biproject` for `EitherTable` and `TheseTable`.

rel8.cabal

@@ -116,6 +116,7 @@ library
 
     Rel8.Schema.Context.Nullify
     Rel8.Schema.Dict
+    Rel8.Schema.Field
     Rel8.Schema.HTable
     Rel8.Schema.HTable.Either
     Rel8.Schema.HTable.Identity
@@ -159,6 +160,7 @@ library
     Rel8.Table.Opaleye
     Rel8.Table.Ord
     Rel8.Table.Order
+    Rel8.Table.Projection
     Rel8.Table.Rel8able
     Rel8.Table.Serialize
     Rel8.Table.These

src/Rel8.hs

@@ -173,6 +173,13 @@ module Rel8
   , Query
   , showQuery
 
+    -- ** Projection
+  , Projection
+  , Projectable( project )
+  , Biprojectable( biproject )
+  , Projecting
+  , Field
+
     -- ** Selecting rows
   , Selects
   , each
@@ -317,6 +324,7 @@ import Rel8.Query.SQL (showQuery)
 import Rel8.Query.Set
 import Rel8.Query.These
 import Rel8.Query.Values
+import Rel8.Schema.Field
 import Rel8.Schema.HTable
 import Rel8.Schema.Name
 import Rel8.Schema.Null hiding ( nullable )
@@ -342,6 +350,7 @@ import Rel8.Table.Name
 import Rel8.Table.NonEmpty
 import Rel8.Table.Ord
 import Rel8.Table.Order
+import Rel8.Table.Projection
 import Rel8.Table.Rel8able ()
 import Rel8.Table.Serialize
 import Rel8.Table.These

src/Rel8/Column/Either.hs

@@ -12,10 +12,7 @@ import Data.Kind ( Type )
 import Prelude
 
 -- rel8
-import Rel8.Aggregate ( Aggregate )
-import Rel8.Expr ( Expr )
 import qualified Rel8.Schema.Kind as K
-import Rel8.Schema.Name ( Name )
 import Rel8.Schema.Result ( Result )
 import Rel8.Table.Either ( EitherTable )
 
@@ -25,7 +22,5 @@ import Rel8.Table.Either ( EitherTable )
 -- 'Result' context.
 type HEither :: K.Context -> Type -> Type -> Type
 type family HEither context = either | either -> context where
-  HEither Aggregate = EitherTable Aggregate
-  HEither Expr = EitherTable Expr
-  HEither Name = EitherTable Name
   HEither Result = Either
+  HEither context = EitherTable context

src/Rel8/Column/List.hs

@@ -12,10 +12,7 @@ import Data.Kind ( Type )
 import Prelude ()
 
 -- rel8
-import Rel8.Aggregate ( Aggregate )
-import Rel8.Expr ( Expr )
 import qualified Rel8.Schema.Kind as K
-import Rel8.Schema.Name ( Name )
 import Rel8.Schema.Result ( Result )
 import Rel8.Table.List ( ListTable )
 
@@ -24,7 +21,5 @@ import Rel8.Table.List ( ListTable )
 -- @a@ in the 'Expr' context, and a @[a]@ in the 'Result' context.
 type HList :: K.Context -> Type -> Type
 type family HList context = list | list -> context where
-  HList Aggregate = ListTable Aggregate
-  HList Expr = ListTable Expr
-  HList Name = ListTable Name
   HList Result = []
+  HList context = ListTable context

src/Rel8/Column/Maybe.hs

@@ -12,10 +12,7 @@ import Data.Kind ( Type )
 import Prelude
 
 -- rel8
-import Rel8.Aggregate ( Aggregate )
-import Rel8.Expr ( Expr )
 import qualified Rel8.Schema.Kind as K
-import Rel8.Schema.Name ( Name )
 import Rel8.Schema.Result ( Result )
 import Rel8.Table.Maybe ( MaybeTable )
 
@@ -25,7 +22,5 @@ import Rel8.Table.Maybe ( MaybeTable )
 -- context.
 type HMaybe :: K.Context -> Type -> Type
 type family HMaybe context = maybe | maybe -> context where
-  HMaybe Aggregate = MaybeTable Aggregate
-  HMaybe Expr = MaybeTable Expr
-  HMaybe Name = MaybeTable Name
   HMaybe Result = Maybe
+  HMaybe context = MaybeTable context

src/Rel8/Column/NonEmpty.hs

@@ -13,10 +13,7 @@ import Data.List.NonEmpty ( NonEmpty )
 import Prelude ()
 
 -- rel8
-import Rel8.Aggregate ( Aggregate )
-import Rel8.Expr ( Expr )
 import qualified Rel8.Schema.Kind as K
-import Rel8.Schema.Name ( Name )
 import Rel8.Schema.Result ( Result )
 import Rel8.Table.NonEmpty ( NonEmptyTable )
 
@@ -26,7 +23,5 @@ import Rel8.Table.NonEmpty ( NonEmptyTable )
 -- 'Result' context.
 type HNonEmpty :: K.Context -> Type -> Type
 type family HNonEmpty context = nonEmpty | nonEmpty -> context where
-  HNonEmpty Aggregate = NonEmptyTable Aggregate
-  HNonEmpty Expr = NonEmptyTable Expr
-  HNonEmpty Name = NonEmptyTable Name
   HNonEmpty Result = NonEmpty
+  HNonEmpty context = NonEmptyTable context

src/Rel8/Column/These.hs

@@ -12,10 +12,7 @@ import Data.Kind ( Type )
 import Prelude ()
 
 -- rel8
-import Rel8.Aggregate ( Aggregate )
-import Rel8.Expr ( Expr )
 import qualified Rel8.Schema.Kind as K
-import Rel8.Schema.Name ( Name )
 import Rel8.Schema.Result ( Result )
 import Rel8.Table.These ( TheseTable )
 
@@ -28,7 +25,5 @@ import Data.These ( These )
 -- 'Result' context.
 type HThese :: K.Context -> Type -> Type -> Type
 type family HThese context = these | these -> context where
-  HThese Aggregate = TheseTable Aggregate
-  HThese Expr = TheseTable Expr
-  HThese Name = TheseTable Name
   HThese Result = These
+  HThese context = TheseTable context

src/Rel8/Generic/Rel8able.hs

@@ -6,6 +6,7 @@
 {-# language FlexibleInstances #-}
 {-# language LambdaCase #-}
 {-# language MultiParamTypeClasses #-}
+{-# language QuantifiedConstraints #-}
 {-# language ScopedTypeVariables #-}
 {-# language StandaloneKindSignatures #-}
 {-# language TypeApplications #-}
@@ -38,6 +39,7 @@ import Rel8.Generic.Table ( GAlgebra )
 import qualified Rel8.Generic.Table.Record as G
 import qualified Rel8.Kind.Algebra as K ( Algebra(..) )
 import Rel8.Kind.Context ( SContext(..) )
+import Rel8.Schema.Field ( Field )
 import Rel8.Schema.HTable ( HTable )
 import qualified Rel8.Schema.Kind as K
 import Rel8.Schema.Name ( Name )
@@ -149,26 +151,30 @@ class HTable (GColumns t) => Rel8able t where
   default gfromColumns :: forall context.
     ( SRel8able t Aggregate
     , SRel8able t Expr
+    , forall table. SRel8able t (Field table)
     , SRel8able t Name
     , SSerialize t
     )
     => SContext context -> GColumns t context -> t context
   gfromColumns = \case
     SAggregate -> sfromColumns
     SExpr -> sfromColumns
+    SField -> sfromColumns
     SName -> sfromColumns
     SResult -> sfromResult
 
   default gtoColumns :: forall context.
     ( SRel8able t Aggregate
     , SRel8able t Expr
+    , forall table. SRel8able t (Field table)
     , SRel8able t Name
     , SSerialize t
     )
     => SContext context -> t context -> GColumns t context
   gtoColumns = \case
     SAggregate -> stoColumns
     SExpr -> stoColumns
+    SField -> stoColumns
     SName -> stoColumns
     SResult -> stoResult
 
@@ -190,11 +196,18 @@ type GRep t context = Rep (Record (t context))
 
 
 type SRel8able :: K.Rel8able -> K.Context -> Constraint
-type SRel8able t context =
+class
   ( Generic (Record (t context))
   , G.GTable (TTable context) TColumns (GRep t context)
   , G.GColumns TColumns (GRep t context) ~ GColumns t
   )
+  => SRel8able t context
+instance
+  ( Generic (Record (t context))
+  , G.GTable (TTable context) TColumns (GRep t context)
+  , G.GColumns TColumns (GRep t context) ~ GColumns t
+  )
+  => SRel8able t context
 
 
 type SSerialize :: K.Rel8able -> Constraint

src/Rel8/Kind/Context.hs

@@ -16,6 +16,7 @@ import Prelude ()
 -- rel8
 import Rel8.Aggregate ( Aggregate )
 import Rel8.Expr ( Expr )
+import Rel8.Schema.Field ( Field )
 import Rel8.Schema.Kind ( Context )
 import Rel8.Schema.Name ( Name )
 import Rel8.Schema.Result ( Result )
@@ -25,6 +26,7 @@ type SContext :: Context -> Type
 data SContext context where
   SAggregate :: SContext Aggregate
   SExpr :: SContext Expr
+  SField :: SContext (Field table)
   SName :: SContext Name
   SResult :: SContext Result
 
@@ -42,6 +44,10 @@ instance Reifiable Expr where
   contextSing = SExpr
 
 
+instance Reifiable (Field table) where
+  contextSing = SField
+
+
 instance Reifiable Result where
   contextSing = SResult
 

src/Rel8/Schema/Context/Nullify.hs

@@ -31,6 +31,7 @@ import Rel8.Expr.Bool ( boolExpr )
 import Rel8.Expr.Null ( nullify, unsafeUnnullify )
 import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
 import Rel8.Kind.Context ( SContext(..) )
+import Rel8.Schema.Field ( Field )
 import qualified Rel8.Schema.Kind as K
 import Rel8.Schema.Name ( Name( Name ) )
 import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )
@@ -64,7 +65,8 @@ instance Nullifiable Name where
 
 type NonNullifiability :: K.Context -> Type
 data NonNullifiability context where
-  NNResult :: NonNullifiability Result
+  NField :: NonNullifiability (Field table)
+  NResult :: NonNullifiability Result
 
 
 nullifiableOrNot :: ()
@@ -73,8 +75,9 @@ nullifiableOrNot :: ()
 nullifiableOrNot = \case
   SAggregate -> Right NAggregate
   SExpr -> Right NExpr
+  SField -> Left NField
   SName -> Right NName
-  SResult -> Left NNResult
+  SResult -> Left NResult
 
 
 absurd :: Nullifiability context -> NonNullifiability context -> a
@@ -91,43 +94,44 @@ guarder :: ()
   -> (Expr tag -> Expr Bool)
   -> context (Maybe a)
   -> context (Maybe a)
-guarder SAggregate tag _ isNonNull (Aggregate a) =
-  mapInputs (toPrimExpr . run . fromPrimExpr) $
-  Aggregate $
-  run <$> a
-  where
-    mtag = foldInputs (\_ -> pure . fromPrimExpr) tag
-    run = maybe id (sguard . isNonNull) (getFirst mtag)
-guarder SExpr tag _ isNonNull a = sguard condition a
-  where
-    condition = isNonNull tag
-guarder SName _ _ _ name = name
-guarder SResult (Identity tag) isNonNull _ (Identity a) =
-  Identity (bool Nothing a condition)
-  where
-    condition = isNonNull tag
+guarder = \case
+  SAggregate -> \tag _ isNonNull (Aggregate a) ->
+    let
+      mtag = foldInputs (\_ -> pure . fromPrimExpr) tag
+      run = maybe id (sguard . isNonNull) (getFirst mtag)
+    in
+      mapInputs (toPrimExpr . run . fromPrimExpr) $
+      Aggregate $
+      run <$> a
+  SExpr -> \tag _ isNonNull a -> sguard (isNonNull tag) a
+  SField -> \_ _ _ field -> field
+  SName -> \_ _ _ name -> name
+  SResult -> \(Identity tag) isNonNull _ (Identity a) ->
+    Identity (bool Nothing a (isNonNull tag))
 
 
 nullifier :: ()
   => Nullifiability context
   -> Spec a
   -> context a
   -> context (Nullify a)
-nullifier NAggregate Spec {nullity} (Aggregate a) =
-  Aggregate $ snullify nullity <$> a
-nullifier NExpr Spec {nullity} a = snullify nullity a
-nullifier NName _ (Name a) = Name a
+nullifier = \case
+  NAggregate -> \Spec {nullity} (Aggregate a) ->
+    Aggregate $ snullify nullity <$> a
+  NExpr -> \Spec {nullity} a -> snullify nullity a
+  NName -> \_ (Name a) -> Name a
 
 
 unnullifier :: ()
   => Nullifiability context
   -> Spec a
   -> context (Nullify a)
   -> context a
-unnullifier NAggregate Spec {nullity} (Aggregate a) =
-  Aggregate $ sunnullify nullity <$> a
-unnullifier NExpr Spec {nullity} a = sunnullify nullity a
-unnullifier NName _ (Name a) = Name a
+unnullifier = \case
+  NAggregate -> \Spec {nullity} (Aggregate a) ->
+    Aggregate $ sunnullify nullity <$> a
+  NExpr -> \Spec {nullity} a -> sunnullify nullity a
+  NName -> \_ (Name a) -> Name a
 
 
 sguard :: Expr Bool -> Expr (Maybe a) -> Expr (Maybe a)

src/Rel8/Schema/Field.hs

@@ -0,0 +1,50 @@
+{-# language DataKinds #-}
+{-# language FlexibleContexts #-}
+{-# language MultiParamTypeClasses #-}
+{-# language StandaloneKindSignatures #-}
+{-# language TypeFamilies #-}
+
+module Rel8.Schema.Field
+  ( Field(..)
+  , fields
+  )
+where
+
+-- base
+import Data.Functor.Identity ( Identity( Identity ) )
+import Data.Kind ( Type )
+import Prelude
+
+-- rel8
+import Rel8.Schema.HTable ( HField, htabulate )
+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
+import Rel8.Schema.Kind as K
+import Rel8.Schema.Null ( Sql )
+import Rel8.Table
+  ( Table, Columns, Context, fromColumns, toColumns
+  , FromExprs, fromResult, toResult
+  , Transpose
+  )
+import Rel8.Table.Transpose ( Transposes )
+import Rel8.Type ( DBType )
+
+
+-- | A special context used in the construction of 'Rel8.Projection's.
+type Field :: Type -> K.Context
+newtype Field table a = Field (HField (Columns table) a)
+
+
+instance Sql DBType a => Table (Field table) (Field table a) where
+  type Columns (Field table a) = HIdentity a
+  type Context (Field table a) = Field table
+  type FromExprs (Field table a) = a
+  type Transpose to (Field table a) = to a
+
+  toColumns = HIdentity
+  fromColumns (HIdentity a) = a
+  toResult a = HIdentity (Identity a)
+  fromResult (HIdentity (Identity a)) = a
+
+
+fields :: Transposes context (Field table) table fields => fields
+fields = fromColumns $ htabulate Field