Merge branch 'two-dot-oh' of github.com:circuithub/rel8 into two-dot-oh

rel8.cabal

@@ -24,6 +24,7 @@ library
     src
   exposed-modules:
     Rel8
+    Rel8.HigherKindedTable
     Rel8.Table
     Rel8.Tabulate
   other-modules:
@@ -42,6 +43,7 @@ library
     Rel8.Query
     Rel8.Query
     Rel8.SimpleConstraints
+    Rel8.Stuff
     Rel8.TableSchema
     Rel8.Tests
     Rel8.Unconstrained

src/Rel8.hs

@@ -15,6 +15,7 @@ module Rel8
 
     -- * Writing Queries
   , MonadQuery
+  , Nest
   , Table
   , each
   , where_
@@ -111,6 +112,7 @@ import Rel8.FromRow
 import Rel8.HigherKindedTable
 import Rel8.MaybeTable
 import Rel8.MonadQuery
+import Rel8.Nest
 import Rel8.Query
 import Rel8.Table
 import Rel8.TableSchema

src/Rel8/Aggregate.hs

@@ -22,6 +22,7 @@ module Rel8.Aggregate
   ) where
 
 import Data.Functor
+import Data.Functor.Identity
 import Data.Monoid
 import Data.Profunctor ( dimap, lmap )
 import qualified Opaleye.Aggregate as Opaleye
@@ -36,7 +37,6 @@ import Rel8.MonadQuery
 import Rel8.Nest
 import Rel8.SimpleConstraints
 import Rel8.Table
-import Rel8.Unconstrained
 
 
 {-| @groupAndAggregate@ is the fundamental aggregation operator in Rel8. Like
@@ -126,7 +126,7 @@ groupAndAggregate_forAll f query =
 -- | Aggregate a table to a single row. This is like @groupAndAggregate@, but
 -- where there is only one group.
 aggregate
-  :: ( MonadQuery m , MonoidTable b , Promote m b' b )
+  :: ( MonadQuery m, MonoidTable b, Promote m b' b )
   => ( a -> b ) -> Nest m a -> m b'
 aggregate = aggregate_forAll
 
@@ -238,7 +238,7 @@ instance ( Context k ~ Context v, Context ( MapTable f k ) ~ Context ( MapTable
     ValueFields i -> ValueFields ( reverseFieldMapping @_ @f i )
 
 
-instance ( Recontextualise k Id, Context v ~ Expr m, Table k, Context k ~ Expr m, MonoidTable v ) => MonoidTable ( GroupBy k v ) where
+instance ( Context v ~ Expr m, Table k, Context k ~ Expr m, MonoidTable v ) => MonoidTable ( GroupBy k v ) where
   aggregator =
     GroupBy
       <$> lmap key group
@@ -249,4 +249,6 @@ instance ( Recontextualise k Id, Context v ~ Expr m, Table k, Context k ~ Expr m
       group :: Opaleye.Aggregator k k
       group =
         Opaleye.Aggregator $ Opaleye.PackMap \f ->
-          traverseTable @Id ( traverseC \x -> fromPrimExpr <$> f ( Nothing, toPrimExpr x ) )
+          fmap runIdentity
+            . traverseTable @Id ( traverseC \x -> fromPrimExpr <$> f ( Nothing, toPrimExpr x ) )
+            . Identity

src/Rel8/EqTable.hs

@@ -13,7 +13,6 @@ import Rel8.DBEq
 import Rel8.Expr
 import Rel8.HigherKindedTable
 import Rel8.Table
-import Rel8.Unconstrained
 
 
 -- | The class of database tables (containing one or more columns) that can be

src/Rel8/FromRow.hs

@@ -19,7 +19,6 @@ import Rel8.Expr
 import Rel8.HigherKindedTable
 import Rel8.Query
 import Rel8.Table hiding ( field )
-import Rel8.Unconstrained
 
 
 -- | @FromRow@ witnesses the one-to-one correspondence between the type @sql@,
@@ -47,16 +46,16 @@ instance m ~ Query => FromRow ( Expr m Bool ) Bool where
 
 
 instance
-  ( HigherKindedTable t
-  , t ~ t'
+  ( t ~ t'
   , f ~ Expr Query
   , g ~ Identity
-  , HConstrainTable t ( Null ( Expr Query ) ) Unconstrained
-  , HConstrainTable t ( Null ( Expr Query ) ) ( HoldsUnderMaybe Unconstrained )
-  , HConstrainTable t Identity FromField
-  , HConstrainTable t Identity Unconstrained
   , HConstrainTable t ( Expr Query ) Unconstrained
   , HConstrainTable t ( Null ( Expr Query ) ) FromField
+  , HConstrainTable t ( Null ( Expr Query ) ) Unconstrained
+  , HConstrainTable t Identity FromField
+  , HigherKindedTable t
+  , Table ( MaybeTable ( t f ) )
+  , Table ( t' g )
   ) => FromRow ( MaybeTable ( t f ) ) ( Maybe ( t' g ) ) where
 
   rowParser ( MaybeTable _ t ) = do

src/Rel8/HigherKindedTable.hs

@@ -18,18 +18,15 @@
 
 {-# options -fno-warn-orphans #-}
 
-module Rel8.HigherKindedTable where
+module Rel8.HigherKindedTable ( HigherKindedTable(..) ) where
 
 import Data.Functor.Identity
 import Data.Kind
 import GHC.Generics hiding ( C )
 import Rel8.Column
-import Rel8.ColumnSchema
 import Rel8.Expr
 import Rel8.Nest
-import Rel8.Query ( Query )
 import Rel8.Table
-import Rel8.Unconstrained
 
 
 {-| Higher-kinded data types.
@@ -140,50 +137,19 @@ instance ( ConstrainTable ( t f ) Unconstrained, HigherKindedTable t ) => Table
     hfield x i
 
 
-instance ( HigherKindedTable t, HConstrainTable t f Unconstrained ) => Recontextualise ( t f ) Id where
-  type MapTable Id ( t f ) = t f
-  fieldMapping ( F i ) = F i
-  reverseFieldMapping ( F i ) = F i
+type family Reduce ( f :: * -> * ) :: ( * -> * ) where
+  Reduce ( Id x ) = x
+  Reduce ( Select ( Expr m ) ) = Identity
+  Reduce ( Null ( Expr m ) ) = Null ( Expr m )
+  Reduce ( NotNull ( Null m ) ) = Reduce m
+  Reduce ( Expr m ) = Expr m
+  Reduce ( Structure f ) = Spine
+  Reduce ( From m f ) = Expr m
+  Reduce ( Demote ( Expr ( Nest m ) ) ) = Expr m
 
 
-instance ( HConstrainTable t ColumnSchema Unconstrained, HigherKindedTable t, HConstrainTable t ( Expr m ) Unconstrained ) => Recontextualise ( t ColumnSchema ) ( From m ) where
-  type MapTable ( From m ) ( t ColumnSchema ) = t ( Expr m )
-  fieldMapping ( F i ) = F i
-  reverseFieldMapping ( F i ) = F i
-
-
-instance ( HConstrainTable t ( Null f ) Unconstrained, HigherKindedTable t, HConstrainTable t f Unconstrained ) => Recontextualise ( t f ) Null where
-  type MapTable Null ( t f ) = t ( Null f )
-  fieldMapping ( F i ) = F i
-  reverseFieldMapping ( F i ) = F i
-
-
-instance ( HConstrainTable t ( Expr ( Nest m ) ) Unconstrained, HigherKindedTable t, HConstrainTable t ( Expr m ) Unconstrained ) => Recontextualise ( t ( Expr ( Nest m ) ) ) Demote where
-  type MapTable Demote ( t ( Expr ( Nest m ) ) ) = t ( Expr m )
-  fieldMapping ( F i ) = F i
-  reverseFieldMapping ( F i ) = F i
-
-
-instance ( HigherKindedTable t, HConstrainTable t f Unconstrained, HConstrainTable t Spine Unconstrained ) => Recontextualise ( t f ) Structure where
-  type MapTable Structure ( t f ) = t Spine
-  fieldMapping ( F i ) = F i
-  reverseFieldMapping ( F i ) = F i
-
-
-instance ( HConstrainTable t Identity Unconstrained, HigherKindedTable t, HConstrainTable t ( Expr Query ) Unconstrained, HConstrainTable t ( Expr Query ) Unconstrained ) => Recontextualise ( t ( Expr Query ) ) Select where
-  type MapTable Select ( t ( Expr Query ) ) = t Identity
-  fieldMapping ( F i ) = F i
-  reverseFieldMapping ( F i ) = F i
-
-
-instance ( HConstrainTable t ( Null Identity ) Unconstrained, HigherKindedTable t, HConstrainTable t ( Null ( Expr Query ) ) Unconstrained, HConstrainTable t ( Null ( Expr Query ) ) Unconstrained ) => Recontextualise ( t ( Null ( Expr Query ) ) ) Select where
-  type MapTable Select ( t ( Null ( Expr Query ) ) ) = t ( Null Identity )
-  fieldMapping ( F i ) = F i
-  reverseFieldMapping ( F i ) = F i
-
-
-instance ( HConstrainTable t f Unconstrained, HConstrainTable t ( Null f ) Unconstrained, HigherKindedTable t ) => Recontextualise ( t ( Null f ) ) NotNull where
-  type MapTable NotNull ( t ( Null f ) ) = t f
+instance ( HigherKindedTable t, HConstrainTable t ( Reduce ( g f ) ) Unconstrained, HConstrainTable t f Unconstrained ) => Recontextualise ( t f ) g where
+  type MapTable g ( t f ) = t ( Reduce ( g f ) )
   fieldMapping ( F i ) = F i
   reverseFieldMapping ( F i ) = F i
 

src/Rel8/MaybeTable.hs

@@ -19,7 +19,6 @@ module Rel8.MaybeTable where
 import Data.Proxy
 import Rel8.Column
 import Rel8.Table
-import Rel8.Unconstrained
 
 
 {-| @MaybeTable t@ is the table @t@, but as the result of an outer join. If the
@@ -53,9 +52,6 @@ class c ( Maybe ( DropMaybe x ) ) => HoldsUnderMaybe c x
 instance c ( Maybe ( DropMaybe x ) ) => HoldsUnderMaybe c x
 
 
-holdsUnderMaybe :: proxy c -> Proxy ( HoldsUnderMaybe c )
-holdsUnderMaybe _ = Proxy
-
 
 instance
   ( Table ( MapTable Null t )
@@ -89,20 +85,7 @@ instance
             ( holdsUnderMaybe proxy )
             ( fmap ( \( MkC x ) -> MkC x ) . f . MaybeTableField )
 
+    where
 
-instance
-  ( ConstrainTable ( MapTable Null t ) Unconstrained
-  , Context ( MapTable Null t ) ~ Null ( Context t )
-  , ConstrainTable ( MapTable Null t ) ( HoldsUnderMaybe Unconstrained )
-  , Recontextualise ( MapTable Null t ) Id
-  ) => Recontextualise ( MaybeTable t ) Id where
-  type MapTable Id ( MaybeTable t ) =
-    MaybeTable t
-
-  fieldMapping = \case
-    MaybeTableIsNull -> MaybeTableIsNull
-    MaybeTableField i -> MaybeTableField ( fieldMapping @_ @Id i )
-
-  reverseFieldMapping = \case
-    MaybeTableIsNull -> MaybeTableIsNull
-    MaybeTableField i -> MaybeTableField ( reverseFieldMapping @_ @Id i )
+      holdsUnderMaybe :: proxy c -> Proxy ( HoldsUnderMaybe c )
+      holdsUnderMaybe _ = Proxy

src/Rel8/MonadQuery.hs

@@ -17,6 +17,7 @@
 module Rel8.MonadQuery where
 
 import Control.Applicative ( liftA2 )
+import Data.Functor.Identity
 import Numeric.Natural
 import Rel8.Column
 import Rel8.ColumnSchema
@@ -94,7 +95,7 @@ each_forAll schema =
     unpackspec =
       Opaleye.Unpackspec
         $ Opaleye.PackMap \f ->
-            traverseTable @Id ( traverseC ( traversePrimExpr f ) )
+            fmap runIdentity . traverseTable @Id ( traverseC ( traversePrimExpr f ) ) . Identity
 
 
     writer :: Opaleye.Writer () row
@@ -165,7 +166,7 @@ leftJoin_forAll joinTable condition =
            { nullTag =
                liftNull tag
            , maybeTable =
-               mapTable @Null ( \( MkC x ) -> MkC ( retype x ) ) renamed
+               mapTable @Null ( mapC retype ) renamed
            }
        , Opaleye.Join
            Opaleye.LeftJoin
@@ -252,10 +253,11 @@ distinct_forAll query =
 
     distinctspec :: Opaleye.Distinctspec a a
     distinctspec =
-      Opaleye.Distinctspec $ Opaleye.Aggregator $ Opaleye.PackMap \f a ->
-        traverseTable @Id
-          ( traverseC \x -> fromPrimExpr <$> f ( Nothing, toPrimExpr x ) )
-          a
+      Opaleye.Distinctspec $ Opaleye.Aggregator $ Opaleye.PackMap \f ->
+        fmap runIdentity
+          . traverseTable @Id
+              ( traverseC \x -> fromPrimExpr <$> f ( Nothing, toPrimExpr x ) )
+          . Identity
 
 
 -- | @limit n@ select at most @n@ rows from a query.

src/Rel8/Query.hs

@@ -1,3 +1,4 @@
+{-# language ApplicativeDo #-}
 {-# language BlockArguments #-}
 {-# language DisambiguateRecordFields #-}
 {-# language DuplicateRecordFields #-}
@@ -14,6 +15,7 @@ module Rel8.Query where
 
 import Control.Monad
 import Control.Monad.IO.Class
+import Data.Functor.Identity
 import Data.Int
 import Data.String ( fromString )
 import qualified Database.PostgreSQL.Simple
@@ -37,7 +39,6 @@ import qualified Rel8.Optimize
 import Rel8.SimpleConstraints
 import Rel8.Table
 import Rel8.TableSchema
-import Rel8.Unconstrained
 import {-# source #-} Rel8.FromRow
 
 
@@ -111,7 +112,7 @@ unpackspec
   => Opaleye.Unpackspec row row
 unpackspec =
   Opaleye.Unpackspec $ Opaleye.PackMap \f ->
-    traverseTable @Id ( traverseC ( traversePrimExpr f ) )
+    fmap runIdentity . traverseTable @Id ( traverseC ( traversePrimExpr f ) ) . Identity
 
 
 -- | Run an @INSERT@ statement
@@ -129,7 +130,6 @@ insert connection Insert{ into, values, onConflict, returning } =
       :: forall schema result value
        . ( Context value ~ Expr Query
          , Context schema ~ ColumnSchema
-         , Table schema
          , MapTable ( From Query ) schema ~ value
          , Recontextualise schema ( From Query )
          )
@@ -161,7 +161,6 @@ writer
   :: forall value schema
    . ( Context value ~ Expr Query
      , Context schema ~ ColumnSchema
-     , Table schema
      , Selects Query schema value
      , MapTable ( From Query ) schema ~ value
      )
@@ -178,12 +177,14 @@ writer into_ =
       void
         ( traverseTableWithIndexC
             @Unconstrained
-            @Id
-            @schema
-            @schema
+            @( From Query )
             ( \i ->
-                traverseC \c@ColumnSchema{ columnName } ->
-                  c <$ f ( toPrimExpr . toColumn . flip field ( reverseFieldMapping @_ @( From Query ) i ) <$> xs, columnName )
+                traverseC \ColumnSchema{ columnName } -> do
+                  f ( toPrimExpr . toColumn . flip field ( reverseFieldMapping @_ @( From Query ) i ) <$> xs
+                    , columnName
+                    )
+
+                  return ( column columnName )
             )
             ( tableColumns into_ )
         )
@@ -254,7 +255,7 @@ data OnConflict
 
 selectQuery
   :: forall a
-   . ( Context a ~ Expr Query, Recontextualise a Id )
+   . ( Table a, Context a ~ Expr Query )
   => Query a -> Maybe String
 selectQuery ( Query opaleye ) =
   showSqlForPostgresExplicit

src/Rel8/SimpleConstraints.hs

@@ -26,10 +26,8 @@ class
   , Context schema ~ ColumnSchema
   , MapTable ( From m ) schema ~ row
   , Recontextualise schema ( From m )
-  , Recontextualise row Id
   , Table schema
   , Table row
-  , Recontextualise schema Id
   ) => Selects m schema row
 
 
@@ -41,8 +39,6 @@ instance
   , Recontextualise schema ( From m )
   , Table row
   , Table schema
-  , Recontextualise row Id
-  , Recontextualise schema Id
   ) => Selects m schema row
 
 
@@ -67,7 +63,6 @@ data Hidden ( a :: k )
 class
   ( Table a
   , Context a ~ Expr m
-  , Recontextualise a Id
   ) => a `IsTableIn` m
 
 

src/Rel8/Table.hs

@@ -24,38 +24,34 @@ behind the scenes, and is safely exported if you want to use it in your own
 work, or if you want to understand further how Rel8 works.
 
 -}
-module Rel8.Table where
-  -- ( -- * Tables of kind @*@
-  --   Table(..)
-  -- , mapTable
-  -- , mapTableC
-  -- , traverseTable
-  -- , traverseTableC
-  -- , traverseTableWithIndexC
-  -- , zipTablesWithM
-  -- , zipTablesWithMC
+module Rel8.Table
+  ( -- * Tables of kind @*@
+    Table(..)
+  , mapTable
+  , mapTableC
+  , traverseTable
+  , traverseTableC
+  , traverseTableWithIndexC
+  , zipTablesWithM
+  , zipTablesWithMC
 
-  --   -- ** Sub-tables
-  -- , ConstrainedTable
-  -- , Unconstrained
+    -- ** Sub-tables
+  , Unconstrained
 
-  --   -- ** Relationships Between Tables
-  -- , CompatibleTables
-  -- , Compatible(..)
+    -- ** Relationships Between Tables
+  , Recontextualise(..)
 
-  --   -- * Higher-kinded tables
-  -- , HigherKindedTable
-
-  --   -- * Columns
-  -- , Column
-  -- , C( MkC )
-  -- , mapC
-  -- , traverseC
-  -- , traverseCC
-  -- , zipCWithM
-  -- , zipCWithMC
-  -- ) where
+    -- * Columns
+  , Column
+  , C( MkC )
+  , mapC
+  , traverseC
+  , traverseCC
+  , zipCWithM
+  , zipCWithMC
+  ) where
 
+import Data.Functor.Compose
 import Data.Functor.Identity
 import Data.Kind
 import Data.Monoid
@@ -135,7 +131,7 @@ instance Table HaskellPackage where
 @
 
 -}
-class ( ConstrainTable t Unconstrained, MapTable Id t ~ t, Recontextualise t Id ) => Table ( t :: Type ) where
+class ConstrainTable t Unconstrained => Table ( t :: Type ) where
   -- | The @Field@ type is a type where each value corresponds to a distinct
   -- field in the table. It describes not just the field itself, but also the
   -- type of values stored there.
@@ -249,20 +245,15 @@ instance Table a => Table ( Sum a ) where
     Sum <$> tabulateMCP proxy ( f . SumField )
 
 
-instance Table a => Recontextualise ( Sum a ) Id where
-  type MapTable Id ( Sum a ) =
-    Sum a
+instance Recontextualise a f => Recontextualise ( Sum a ) f where
+  type MapTable f ( Sum a ) =
+    Sum ( MapTable f a )
 
-  fieldMapping ( SumField i ) = SumField i
-  reverseFieldMapping ( SumField i ) = SumField i
+  fieldMapping ( SumField i ) =
+    SumField ( fieldMapping @_ @f i )
 
-
-instance Recontextualise a Demote => Recontextualise ( Sum a ) Demote where
-  type MapTable Demote ( Sum a ) =
-    Sum ( MapTable Demote a )
-
-  fieldMapping ( SumField i ) = SumField ( fieldMapping @_ @Demote i )
-  reverseFieldMapping ( SumField i ) = SumField ( reverseFieldMapping @_ @Demote i )
+  reverseFieldMapping ( SumField i ) =
+    SumField ( reverseFieldMapping @_ @f i )
 
 
 -- | Map a 'Table' from one type to another. The table types must be compatible,
@@ -277,6 +268,34 @@ mapTable f =
   runIdentity . traverseTable @f ( Identity . f )
 
 
+instance Table a => Table ( Identity a ) where
+  type Context ( Identity a ) =
+    Context a
+
+  type ConstrainTable ( Identity a ) c =
+    ConstrainTable a c
+
+  type Field ( Identity a ) =
+    Compose Identity ( Field a )
+
+  field ( Identity a ) ( Compose ( Identity x ) ) =
+    field a x
+
+  tabulateMCP proxy f =
+    Identity <$> tabulateMCP proxy ( f . Compose . Identity )
+
+
+instance Table a => Recontextualise ( Identity a ) Id where
+  type MapTable Id ( Identity a ) =
+    Identity a
+
+  fieldMapping ( Compose ( Identity i ) ) =
+    Compose ( Identity i )
+
+  reverseFieldMapping ( Compose ( Identity i ) ) =
+    Compose ( Identity i )
+
+
 -- | Map a 'Table' from one type to another, where all columns in the table are
 -- subject to a constraint. The table types must be compatible, see 'Compatible'
 -- for what that means.