rel8 1.0.0.1 → 1.1.0.0

raw patch · 106 files changed

+4490/−5006 lines, 106 filesdep +bifunctorsdep +comonaddep +hasql-transactiondep −lifted-basedep −monad-controldep ~opaleyePVP ok

version bump matches the API change (PVP)

Dependencies added: bifunctors, comonad, hasql-transaction, mmorph, pretty, product-profunctors

Dependencies removed: lifted-base, monad-control

Dependency ranges changed: opaleye

API changes (from Hackage documentation)

Files

• Changelog.md +66/−0
• README.md +4/−0
• rel8.cabal +26/−15
• src/Rel8.hs +33/−15
• src/Rel8/Aggregate.hs +21/−69
• src/Rel8/Aggregate.hs-boot +11/−0
• src/Rel8/Column.hs +5/−77
• src/Rel8/Column/ADT.hs +3/−68
• src/Rel8/Column/Either.hs +4/−140
• src/Rel8/Column/Lift.hs +3/−67
• src/Rel8/Column/List.hs +6/−126
• src/Rel8/Column/Maybe.hs +4/−105
• src/Rel8/Column/NonEmpty.hs +6/−127
• src/Rel8/Column/These.hs +5/−142
• src/Rel8/Expr.hs +16/−47
• src/Rel8/Expr.hs-boot +6/−8
• src/Rel8/Expr/Default.hs +35/−0
• src/Rel8/Expr/Eq.hs +1/−1
• src/Rel8/FCF.hs +3/−3
• src/Rel8/Generic/Construction.hs +146/−165
• src/Rel8/Generic/Construction/ADT.hs +31/−47
• src/Rel8/Generic/Construction/Record.hs +6/−11
• src/Rel8/Generic/Map.hs +20/−64
• src/Rel8/Generic/Reify.hs +0/−24
• src/Rel8/Generic/Rel8able.hs +170/−69
• src/Rel8/Generic/Rel8able/Test.hs +0/−157
• src/Rel8/Generic/Table.hs +24/−109
• src/Rel8/Generic/Table/ADT.hs +61/−204
• src/Rel8/Generic/Table/Record.hs +74/−99
• src/Rel8/Kind/Context.hs +8/−33
• src/Rel8/Kind/Labels.hs +0/−57
• src/Rel8/Order.hs +1/−1
• src/Rel8/Query.hs +168/−7
• src/Rel8/Query.hs-boot +3/−1
• src/Rel8/Query/Each.hs +3/−3
• src/Rel8/Query/Either.hs +10/−6
• src/Rel8/Query/Evaluate.hs +37/−51
• src/Rel8/Query/Exists.hs +15/−17
• src/Rel8/Query/Indexed.hs +34/−0
• src/Rel8/Query/List.hs +17/−15
• src/Rel8/Query/Maybe.hs +24/−29
• src/Rel8/Query/Opaleye.hs +41/−5
• src/Rel8/Query/SQL.hs +6/−59
• src/Rel8/Query/These.hs +50/−37
• src/Rel8/Schema/Context.hs +0/−20
• src/Rel8/Schema/Context/Label.hs +0/−62
• src/Rel8/Schema/Context/Nullify.hs +100/−136
• src/Rel8/Schema/Field.hs +50/−0
• src/Rel8/Schema/HTable.hs +22/−22
• src/Rel8/Schema/HTable/Either.hs +2/−3
• src/Rel8/Schema/HTable/Identity.hs +16/−28
• src/Rel8/Schema/HTable/Label.hs +37/−50
• src/Rel8/Schema/HTable/MapTable.hs +22/−12
• src/Rel8/Schema/HTable/Maybe.hs +2/−3
• src/Rel8/Schema/HTable/Nullify.hs +47/−32
• src/Rel8/Schema/HTable/These.hs +2/−3
• src/Rel8/Schema/HTable/Vectorize.hs +28/−44
• src/Rel8/Schema/Kind.hs +6/−15
• src/Rel8/Schema/Name.hs +34/−56
• src/Rel8/Schema/Name.hs-boot +11/−0
• src/Rel8/Schema/Reify.hs +0/−74
• src/Rel8/Schema/Result.hs +16/−41
• src/Rel8/Schema/Spec.hs +17/−37
• src/Rel8/Schema/Spec/ConstrainDBType.hs +0/−89
• src/Rel8/Schema/Table.hs +17/−0
• src/Rel8/Statement/Delete.hs +35/−48
• src/Rel8/Statement/Insert.hs +43/−72
• src/Rel8/Statement/OnConflict.hs +106/−0
• src/Rel8/Statement/Returning.hs +114/−10
• src/Rel8/Statement/SQL.hs +29/−0
• src/Rel8/Statement/Select.hs +116/−33
• src/Rel8/Statement/Set.hs +33/−0
• src/Rel8/Statement/Update.hs +38/−56
• src/Rel8/Statement/Using.hs +36/−0
• src/Rel8/Statement/View.hs +17/−27
• src/Rel8/Statement/Where.hs +31/−0
• src/Rel8/Table.hs +88/−252
• src/Rel8/Table/ADT.hs +32/−64
• src/Rel8/Table/Aggregate.hs +12/−13
• src/Rel8/Table/Bool.hs +5/−6
• src/Rel8/Table/Cols.hs +50/−0
• src/Rel8/Table/Either.hs +118/−123
• src/Rel8/Table/Eq.hs +12/−39
• src/Rel8/Table/HKD.hs +64/−105
• src/Rel8/Table/List.hs +53/−54
• src/Rel8/Table/Maybe.hs +103/−117
• src/Rel8/Table/Name.hs +17/−22
• src/Rel8/Table/NonEmpty.hs +54/−53
• src/Rel8/Table/Nullify.hs +184/−0
• src/Rel8/Table/Opaleye.hs +56/−26
• src/Rel8/Table/Ord.hs +14/−43
• src/Rel8/Table/Order.hs +13/−16
• src/Rel8/Table/Projection.hs +73/−0
• src/Rel8/Table/Recontextualize.hs +0/−90
• src/Rel8/Table/Rel8able.hs +29/−85
• src/Rel8/Table/Serialize.hs +18/−118
• src/Rel8/Table/Tag.hs +0/−97
• src/Rel8/Table/These.hs +146/−141
• src/Rel8/Table/Transpose.hs +46/−0
• src/Rel8/Table/Undefined.hs +5/−5
• src/Rel8/Table/Unreify.hs +0/−102
• src/Rel8/Tabulate.hs +637/−0
• src/Rel8/Type/Composite.hs +20/−19
• src/Rel8/Type/Tag.hs +1/−1
• tests/Main.hs +227/−162
• tests/Rel8/Generic/Rel8able/Test.hs +179/−0

@@ -1,3 +1,69 @@+# 1.1.0.0 (2021-07-16)++## New features++* You can derive `Rel8able` for "vanilla" higher-kinded data types - data types that don't use the `Column` type family. For example, the following is now possible:++  ```haskell+  data MyTable f = MyTable+    { myTableX :: f Int32+    , myTableY :: f Text+    } deriving (Generic, Rel8able)+  ```++* The `Projectable` and `Biprojectable` type classes have been introduced. These classes model a type of functors and bifunctors (respectively) on tables, where the mapping function is only able to rearrange columns. For example, the following is now possible:++  ```haskell+  x <- project myTableX <$> many ...+  ```++* `Insert`'s `onConflict` field now has a new option - `DoUpdate`. This maps to PostgreSQL's `ON CONFLICT DO UPDATE` syntax, which provides upsert support. ([#85](https://github.com/circuithub/rel8/pull/85))++* `Insert`, `Update` and `Delete` has all been expanded to work with `Query`s. In particular:++  * `Delete` now supports a `USING` sub-query+  * `Update` now supports a `FROM` sub-query+  * `Insert` can delete the result of any arbitrary `Query` (providing the types match)++* The new `Rel8.Tabulate` module has been added, which gives a `Map`-esque interface to writing and composing queries. ([#70](https://github.com/circuithub/rel8/pull/70))++* The new `indexed` `Query -> Query` function was added. This function augments each row in a query with it's 0-based index. ([#117](https://github.com/circuithub/rel8/pull/117))++## Breaking changes++* `Insert`, `Delete` and `Update` have all changed. In particular, for `Insert` users should now replace `rows = xs` with `rows = values xs`. ([#85](https://github.com/circuithub/rel8/pull/85))++* Rename `whereExists` and `whereNotExists` to `present` and `absent` respectively. ([#57](https://github.com/circuithub/rel8/pull/57))++* Simplify `evaluate` to run directly inside the `Query` monad, rendering the `Evaluate` monad unnecessary. ([#56](https://github.com/circuithub/rel8/pull/56))++* The `Labelable` type class has been removed as it's no longer necessary. This class was mostly internal, though was visible in some public API functions. ([#76](https://github.com/circuithub/rel8/pull/76))++* `EitherTable`, `ListTable`, `MaybeTable`, `NonEmptyTable` and `TheseTable` now all have an extra parameter which tracks the context of the table. If you manually specified any types before, you need to provide this parameter - usually `Expr` will be the correct choice. ([#101](https://github.com/circuithub/rel8/pull/101))++* We've done a lot of work to simplify the internals of Rel8, but some of these are breaking changes. However, most of these API changes shouldn't affect users as they are mostly types used in type inference, or affect classes where users don't need to define their own instances.++  * The kind of a `Rel8able` is now `(Type -> Type) -> Type`. Previously it was `(X -> Type) -> Type`.+  * `Table` has a new associated type - `FromExprs`. This was previously an open type family.+  * `Table` has a new associated type - `Transpose` - and `Recontextualise` has been renamed to `Transposes`. This `Transposes` class now operates in terms of `Transpose`.++* `select`, `insert`, `update` and `delete` now produce Hasql `Statement`s, rather than actually running the statement as IO. This allows Rel8 to be used with transaction/connection-managing monads like [`hasql-transaction`](https://hackage.haskell.org/package/hasql-transaction). ([#94](https://github.com/circuithub/rel8/pull/94))++## Bug fixes++* Fixes a bug where cartesian products of queries using `catListTable`, `catNonEmptyTable`, `catList` and `catNonEmpty` would incorrectly be zipped instead. ([#61](https://github.com/circuithub/rel8/pull/61))++* Require Opaleye 0.7.3.0. This version has better support for lateral queries, which can improve query plans, especially in `optional`/`LEFT JOIN` ([#72](https://github.com/circuithub/rel8/pull/72))++* Rel8 now compiles with GHC 9. ([#97](https://github.com/circuithub/rel8/pull/97))++## Other changes++* `exists` is now implemented in terms of the SQL `EXISTS` keyword. ([#69](https://github.com/circuithub/rel8/pull/69))++* `alignBy` no longer requires `Table`s. ([#67](https://github.com/circuithub/rel8/pull/67))++ # 1.0.0.1 (2021-06-21)  This release contains various fixes for documentation.

@@ -10,4 +10,8 @@  * *Familiar*: writing Rel8 queries should feel like normal Haskell programming. +Rel8 was presented at ZuriHac 2021. If you want to have a brief overview of what Rel8 is, and a tour of the API - check out the video below:++[![Rel8 presentation at ZuriHac 2021](https://img.youtube.com/vi/3uwrtjxiq6E/hqdefault.jpg)](http://www.youtube.com/watch?v=3uwrtjxiq6E)+ For more details, check out the [official documentation](https://rel8.readthedocs.io/en/latest/).

@@ -1,6 +1,6 @@ cabal-version:       2.0 name:                rel8-version:             1.0.0.1+version:             1.1.0.0 synopsis:            Hey! Hey! Can u rel8? license:             BSD3 license-file:        LICENSE@@ -21,23 +21,27 @@   build-depends:       aeson     , base ^>= 4.14 || ^>=4.15+    , bifunctors     , bytestring     , case-insensitive+    , comonad     , contravariant     , hasql ^>= 1.4.5.1-    , opaleye ^>= 0.7.1.0+    , opaleye ^>= 0.7.3.0+    , pretty     , profunctors+    , product-profunctors     , scientific     , semialign     , semigroupoids     , text     , these     , time-    , transformers     , uuid   default-language:     Haskell2010   ghc-options:+    -Werror=missing-methods -Werror=incomplete-patterns -Werror=missing-fields     -Weverything -Wno-unsafe -Wno-safe -Wno-missing-safe-haskell-mode     -Wno-missing-import-lists -Wno-prepositive-qualified-module     -Wno-monomorphism-restriction@@ -49,6 +53,7 @@     Rel8.Expr.Num     Rel8.Expr.Text     Rel8.Expr.Time+    Rel8.Tabulate    other-modules:     Rel8.Aggregate@@ -66,6 +71,7 @@     Rel8.Expr.Aggregate     Rel8.Expr.Array     Rel8.Expr.Bool+    Rel8.Expr.Default     Rel8.Expr.Eq     Rel8.Expr.Function     Rel8.Expr.Null@@ -79,16 +85,13 @@      Rel8.Kind.Algebra     Rel8.Kind.Context-    Rel8.Kind.Labels      Rel8.Generic.Construction     Rel8.Generic.Construction.ADT     Rel8.Generic.Construction.Record     Rel8.Generic.Map     Rel8.Generic.Record-    Rel8.Generic.Reify     Rel8.Generic.Rel8able-    Rel8.Generic.Rel8able.Test     Rel8.Generic.Table     Rel8.Generic.Table.ADT     Rel8.Generic.Table.Record@@ -103,6 +106,7 @@     Rel8.Query.Evaluate     Rel8.Query.Exists     Rel8.Query.Filter+    Rel8.Query.Indexed     Rel8.Query.Limit     Rel8.Query.List     Rel8.Query.Maybe@@ -114,10 +118,9 @@     Rel8.Query.These     Rel8.Query.Values -    Rel8.Schema.Context-    Rel8.Schema.Context.Label     Rel8.Schema.Context.Nullify     Rel8.Schema.Dict+    Rel8.Schema.Field     Rel8.Schema.HTable     Rel8.Schema.HTable.Either     Rel8.Schema.HTable.Identity@@ -133,24 +136,28 @@     Rel8.Schema.Kind     Rel8.Schema.Name     Rel8.Schema.Null-    Rel8.Schema.Reify     Rel8.Schema.Result     Rel8.Schema.Spec-    Rel8.Schema.Spec.ConstrainDBType     Rel8.Schema.Table      Rel8.Statement.Delete     Rel8.Statement.Insert+    Rel8.Statement.OnConflict     Rel8.Statement.Returning     Rel8.Statement.Select+    Rel8.Statement.Set+    Rel8.Statement.SQL     Rel8.Statement.Update+    Rel8.Statement.Using     Rel8.Statement.View+    Rel8.Statement.Where      Rel8.Table     Rel8.Table.ADT     Rel8.Table.Aggregate     Rel8.Table.Alternative     Rel8.Table.Bool+    Rel8.Table.Cols     Rel8.Table.Either     Rel8.Table.Eq     Rel8.Table.HKD@@ -158,16 +165,16 @@     Rel8.Table.Maybe     Rel8.Table.Name     Rel8.Table.NonEmpty+    Rel8.Table.Nullify     Rel8.Table.Opaleye     Rel8.Table.Ord     Rel8.Table.Order-    Rel8.Table.Recontextualize+    Rel8.Table.Projection     Rel8.Table.Rel8able     Rel8.Table.Serialize-    Rel8.Table.Tag     Rel8.Table.These+    Rel8.Table.Transpose     Rel8.Table.Undefined-    Rel8.Table.Unreify      Rel8.Type     Rel8.Type.Array@@ -194,9 +201,9 @@     , case-insensitive     , containers     , hasql+    , hasql-transaction     , hedgehog          ^>=1.0.2-    , lifted-base       ^>=0.2.3.12-    , monad-control     ^>=1.0.2.3+    , mmorph     , rel8     , scientific     , tasty@@ -204,7 +211,11 @@     , text     , time     , tmp-postgres      ^>=1.34.1.0+    , transformers     , uuid++  other-modules:+    Rel8.Generic.Rel8able.Test    main-is:          Main.hs   hs-source-dirs:   tests

@@ -43,7 +43,7 @@    , Table(..)   , HTable-  , Recontextualize+  , Transposes   , AltTable((<|>:))   , AlternativeTable( emptyTable )   , EqTable, (==:), (/=:)@@ -59,6 +59,7 @@   , optional   , catMaybeTable   , traverseMaybeTable+  , aggregateMaybeTable   , nameMaybeTable      -- ** @EitherTable@@@ -68,6 +69,7 @@   , keepLeftTable   , keepRightTable   , bitraverseEitherTable+  , aggregateEitherTable   , nameEitherTable      -- ** @TheseTable@@@ -83,6 +85,7 @@   , keepThatTable, loseThatTable   , keepThoseTable, loseThoseTable   , bitraverseTheseTable+  , aggregateTheseTable   , nameTheseTable      -- ** @ListTable@@@ -170,6 +173,13 @@   , Query   , showQuery +    -- ** Projection+  , Projection+  , Projectable( project )+  , Biprojectable( biproject )+  , Projecting+  , Field+     -- ** Selecting rows   , Selects   , each@@ -178,8 +188,8 @@     -- ** Filtering   , filter   , where_-  , whereExists-  , whereNotExists+  , present+  , absent   , distinct   , distinctOn   , distinctOnBy@@ -234,10 +244,15 @@   , nullsFirst   , nullsLast +    -- ** Window functions+  , indexed++    -- ** Bindings+  , rebind+     -- * IO   , Serializable-  , ToExprs(..)-  , FromExprs+  , ToExprs   , Result      -- * Running statements@@ -249,15 +264,20 @@     -- ** @INSERT@   , Insert(..)   , OnConflict(..)+  , Upsert(..)   , insert+  , unsafeDefault+  , showInsert      -- ** @DELETE@   , Delete(..)   , delete+  , showDelete      -- ** @UPDATE@-  , update   , Update(..)+  , update+  , showUpdate      -- ** @.. RETURNING@   , Returning(..)@@ -267,14 +287,7 @@      -- ** Sequences   , nextval--  , Evaluate-  , eval   , evaluate--    -- * Implementation details-  , Labelable-  , HKDT(..)   ) where  -- base@@ -293,6 +306,7 @@ import Rel8.Expr import Rel8.Expr.Aggregate import Rel8.Expr.Bool+import Rel8.Expr.Default import Rel8.Expr.Eq import Rel8.Expr.Function import Rel8.Expr.Null@@ -311,6 +325,7 @@ import Rel8.Query.Evaluate import Rel8.Query.Exists import Rel8.Query.Filter+import Rel8.Query.Indexed import Rel8.Query.Limit import Rel8.Query.List import Rel8.Query.Maybe@@ -320,7 +335,7 @@ import Rel8.Query.Set import Rel8.Query.These import Rel8.Query.Values-import Rel8.Schema.Context.Label+import Rel8.Schema.Field import Rel8.Schema.HTable import Rel8.Schema.Name import Rel8.Schema.Null hiding ( nullable )@@ -328,8 +343,10 @@ import Rel8.Schema.Table import Rel8.Statement.Delete import Rel8.Statement.Insert+import Rel8.Statement.OnConflict import Rel8.Statement.Returning import Rel8.Statement.Select+import Rel8.Statement.SQL import Rel8.Statement.Update import Rel8.Statement.View import Rel8.Table@@ -346,10 +363,11 @@ import Rel8.Table.NonEmpty import Rel8.Table.Ord import Rel8.Table.Order-import Rel8.Table.Recontextualize+import Rel8.Table.Projection import Rel8.Table.Rel8able () import Rel8.Table.Serialize import Rel8.Table.These+import Rel8.Table.Transpose import Rel8.Type import Rel8.Type.Composite import Rel8.Type.Eq

@@ -1,27 +1,23 @@ {-# language DataKinds #-}-{-# language DerivingVia #-} {-# language FlexibleContexts #-} {-# language FlexibleInstances #-}-{-# language GADTs #-} {-# language MultiParamTypeClasses #-} {-# language NamedFieldPuns #-}-{-# language PolyKinds #-}+{-# language RankNTypes #-} {-# language StandaloneKindSignatures #-} {-# language TypeFamilies #-} {-# language UndecidableInstances #-}-{-# language UndecidableSuperClasses #-}  module Rel8.Aggregate   ( Aggregate(..), foldInputs, mapInputs   , Aggregator(..), unsafeMakeAggregate   , Aggregates-  , Col( A, unA )   ) where  -- base import Data.Functor.Const ( Const( Const ), getConst )-import Data.Functor.Identity ( Identity )+import Data.Functor.Identity ( Identity( Identity ) ) import Data.Kind ( Constraint, Type ) import Prelude @@ -32,19 +28,15 @@  -- rel8 import Rel8.Expr ( Expr )-import Rel8.Schema.Context ( Interpretation(..) )-import Rel8.Schema.Context.Label ( Labelable(..) )-import Rel8.Schema.HTable.Identity ( HIdentity(..), HType )-import Rel8.Schema.Name ( Name )+import Rel8.Schema.HTable.Identity ( HIdentity(..) )+import qualified Rel8.Schema.Kind as K import Rel8.Schema.Null ( Sql )-import Rel8.Schema.Reify ( notReify )-import Rel8.Schema.Result ( Result )-import Rel8.Schema.Spec ( Spec( Spec ) ) import Rel8.Table   ( Table, Columns, Context, fromColumns, toColumns-  , reify, unreify+  , FromExprs, fromResult, toResult+  , Transpose   )-import Rel8.Table.Recontextualize ( Recontextualize )+import Rel8.Table.Transpose ( Transposes ) import Rel8.Type ( DBType )  @@ -53,70 +45,30 @@ -- @Aggregate@ is almost an 'Applicative' functor - but there is no 'pure' -- operation. This means 'Aggregate' is an instance of 'Apply', and you can -- combine @Aggregate@s using the @<.>@ combinator.-type Aggregate :: k -> Type-data Aggregate a where-  Aggregate :: !(Opaleye.Aggregator () (Expr a)) -> Aggregate a---instance Interpretation Aggregate where-  data Col Aggregate _spec where-    A :: ()-      => { unA :: !(Aggregate a) }-      -> Col Aggregate ('Spec labels a)+type Aggregate :: K.Context+newtype Aggregate a = Aggregate (Opaleye.Aggregator () (Expr a))   instance Sql DBType a => Table Aggregate (Aggregate a) where-  type Columns (Aggregate a) = HType a+  type Columns (Aggregate a) = HIdentity a   type Context (Aggregate a) = Aggregate--  toColumns = HIdentity . A-  fromColumns (HIdentity (A a)) = a--  reify = notReify-  unreify = notReify---instance Sql DBType a =>-  Recontextualize Aggregate Aggregate (Aggregate a) (Aggregate a)---instance Sql DBType a =>-  Recontextualize Aggregate Expr (Aggregate a) (Expr a)---instance Sql DBType a =>-  Recontextualize Aggregate Result (Aggregate a) (Identity a)---instance Sql DBType a =>-  Recontextualize Aggregate Name (Aggregate a) (Name a)---instance Sql DBType a =>-  Recontextualize Expr Aggregate (Expr a) (Aggregate a)---instance Sql DBType a =>-  Recontextualize Result Aggregate (Identity a) (Aggregate a)---instance Sql DBType a =>-  Recontextualize Name Aggregate (Name a) (Aggregate a)-+  type FromExprs (Aggregate a) = a+  type Transpose to (Aggregate a) = to a -instance Labelable Aggregate where-  labeler (A aggregate) = A aggregate-  unlabeler (A aggregate) = A aggregate+  toColumns = HIdentity+  fromColumns (HIdentity a) = a+  toResult = HIdentity . Identity+  fromResult (HIdentity (Identity a)) = a   -- | @Aggregates a b@ means that the columns in @a@ are all 'Aggregate' 'Expr's -- for the columns in @b@. type Aggregates :: Type -> Type -> Constraint-class Recontextualize Aggregate Expr aggregates exprs => Aggregates aggregates exprs-instance Recontextualize Aggregate Expr aggregates exprs => Aggregates aggregates exprs+class Transposes Aggregate Expr aggregates exprs => Aggregates aggregates exprs+instance Transposes Aggregate Expr aggregates exprs => Aggregates aggregates exprs  -foldInputs :: Monoid b+foldInputs :: forall (a :: Type) (b :: Type). Monoid b   => (Maybe Aggregator -> Opaleye.PrimExpr -> b) -> Aggregate a -> b foldInputs f (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =   getConst $ flip agg () $ \(aggregator, a) ->@@ -126,7 +78,7 @@       Aggregator {operation, ordering, distinction}  -mapInputs :: ()+mapInputs :: forall (a :: Type). ()   => (Opaleye.PrimExpr -> Opaleye.PrimExpr) -> Aggregate a -> Aggregate a mapInputs transform (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =   Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ agg . \f input ->@@ -141,7 +93,7 @@   }  -unsafeMakeAggregate :: ()+unsafeMakeAggregate :: forall (input :: Type) (output :: Type). ()   => (Expr input -> Opaleye.PrimExpr)   -> (Opaleye.PrimExpr -> Expr output)   -> Maybe Aggregator

@@ -0,0 +1,11 @@+{-# language PolyKinds #-}+{-# language RoleAnnotations #-}+{-# language StandaloneKindSignatures #-}++module Rel8.Aggregate where++import Data.Kind++type Aggregate :: k -> Type+type role Aggregate nominal+data Aggregate a

@@ -1,38 +1,21 @@ {-# language DataKinds #-}-{-# language FlexibleContexts #-}-{-# language LambdaCase #-}-{-# language MultiParamTypeClasses #-} {-# language StandaloneKindSignatures #-} {-# language TypeFamilies #-}  module Rel8.Column-  ( Column, AColumn(..)+  ( Column   , TColumn   ) where  -- base import Data.Kind ( Type )-import Prelude+import Prelude ()  -- rel8-import Rel8.Aggregate ( Aggregate, Col( A ) )-import Rel8.Expr ( Expr, Col( E ) ) import Rel8.FCF ( Eval, Exp )-import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) )-import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) ) import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Name ( Name(..), Col( N ) )-import Rel8.Schema.Null ( Sql )-import Rel8.Schema.Reify ( Reify, Col(..) )-import Rel8.Schema.Result ( Col( R ), Result )-import Rel8.Schema.Spec ( Spec( Spec ) )-import Rel8.Table-  ( Table, Columns, Context, fromColumns, toColumns-  , Unreify, reify, unreify-  )-import Rel8.Table.Recontextualize ( Recontextualize )-import Rel8.Type ( DBType )+import Rel8.Schema.Result ( Result )   -- | This type family is used to specify columns in 'Rel8able's. In @Column f@@ -40,63 +23,8 @@ -- 'Rel8able' definitions), and @a@ is the type of the column. type Column :: K.Context -> Type -> Type type family Column context a where-  Column (Reify context) a = AColumn context a-  Column Aggregate       a = Aggregate a-  Column Expr            a = Expr a-  Column Name            a = Name a-  Column Result          a = a---type AColumn :: K.Context -> Type -> Type-newtype AColumn context a = AColumn (Column context a)---instance (Reifiable context, Sql DBType a) =>-  Table (Reify context) (AColumn context a)- where-  type Context (AColumn context a) = Reify context-  type Columns (AColumn context a) = HIdentity ('Spec '[] a)-  type Unreify (AColumn context a) = Column context a--  fromColumns (HIdentity (Reify a)) = sfromColumn contextSing a-  toColumns = HIdentity . Reify . stoColumn contextSing-  reify _ = AColumn-  unreify _ (AColumn a) = a---instance-  ( Reifiable context, Reifiable context'-  , Sql DBType a-  ) =>-  Recontextualize-    (Reify context)-    (Reify context')-    (AColumn context a)-    (AColumn context' a)---sfromColumn :: ()-  => SContext context-  -> Col context ('Spec labels a)-  -> AColumn context a-sfromColumn = \case-  SAggregate -> \(A a) -> AColumn a-  SExpr -> \(E a) -> AColumn a-  SName -> \(N a) -> AColumn a-  SResult -> \(R a) -> AColumn a-  SReify context -> \(Reify a) -> AColumn (sfromColumn context a)---stoColumn :: ()-  => SContext context-  -> AColumn context a-  -> Col context ('Spec labels a)-stoColumn = \case-  SAggregate -> \(AColumn a) -> A a-  SExpr -> \(AColumn a) -> E a-  SName -> \(AColumn a) -> N a-  SResult -> \(AColumn a) -> R a-  SReify context -> \(AColumn a) -> Reify (stoColumn context a)+  Column Result  a = a+  Column context a = context a   data TColumn :: K.Context -> Type -> Exp Type

@@ -1,88 +1,23 @@ {-# language DataKinds #-}-{-# language LambdaCase #-}-{-# language MultiParamTypeClasses #-} {-# language StandaloneKindSignatures #-} {-# language TypeFamilies #-}-{-# language UndecidableInstances #-}  module Rel8.Column.ADT-  ( HADT, AHADT(..)+  ( HADT   ) where  -- base import Data.Kind ( Type )-import Prelude+import Prelude ()  -- rel8-import Rel8.Generic.Rel8able ( GColumns )-import Rel8.Kind.Context ( SContext(..), Reifiable, contextSing )-import Rel8.Schema.Context ( Col ) import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Reify ( Reify, hreify, hunreify ) import Rel8.Schema.Result ( Result )-import Rel8.Table-  ( Table, Columns, Context, fromColumns, toColumns-  , Unreify, reify, unreify-  )-import Rel8.Table.ADT ( ADT( ADT ), ADTable, fromADT, toADT )-import Rel8.Table.Recontextualize ( Recontextualize )+import Rel8.Table.ADT ( ADT )   type HADT :: K.Context -> K.Rel8able -> Type type family HADT context t where-  HADT (Reify context) t = AHADT context t   HADT Result t = t Result   HADT context t = ADT t context---type AHADT :: K.Context -> K.Rel8able -> Type-newtype AHADT context t = AHADT (HADT context t)---instance (ADTable t, Reifiable context) =>-  Table (Reify context) (AHADT context t)- where-  type Context (AHADT context t) = Reify context-  type Columns (AHADT context t) = GColumns (ADT t)-  type Unreify (AHADT context t) = HADT context t--  fromColumns = sfromColumnsADT contextSing-  toColumns = stoColumnsADT contextSing-  reify _ = AHADT-  unreify _ (AHADT a) = a---instance-  ( Reifiable context, Reifiable context'-  , ADTable t, t ~ t'-  )-  => Recontextualize-    (Reify context)-    (Reify context')-    (AHADT context t)-    (AHADT context' t')---sfromColumnsADT :: ADTable t-  => SContext context-  -> GColumns (ADT t) (Col (Reify context))-  -> AHADT context t-sfromColumnsADT = \case-  SAggregate -> AHADT . ADT . hunreify-  SExpr -> AHADT . ADT . hunreify-  SName -> AHADT . ADT . hunreify-  SResult -> AHADT . fromADT . ADT . hunreify-  SReify context -> AHADT . sfromColumnsADT context . hunreify---stoColumnsADT :: ADTable t-  => SContext context-  -> AHADT context t-  -> GColumns (ADT t) (Col (Reify context))-stoColumnsADT = \case-  SAggregate -> hreify . (\(AHADT (ADT a)) -> a)-  SExpr -> hreify . (\(AHADT (ADT a)) -> a)-  SName -> hreify . (\(AHADT (ADT a)) -> a)-  SResult -> hreify . (\(ADT a) -> a) . toADT . (\(AHADT a) -> a)-  SReify context -> hreify . stoColumnsADT context . (\(AHADT a) -> a)

@@ -1,162 +1,26 @@ {-# language DataKinds #-}-{-# language FlexibleContexts #-}-{-# language LambdaCase #-}-{-# language MultiParamTypeClasses #-} {-# language StandaloneKindSignatures #-}-{-# language TypeFamilies #-}-{-# language UndecidableInstances #-}+{-# language TypeFamilyDependencies #-}  module Rel8.Column.Either-  ( HEither, AHEither(..)+  ( HEither   ) where  -- base-import Control.Applicative ( liftA2 )-import Data.Bifunctor ( Bifunctor, bimap ) import Data.Kind ( Type ) import Prelude  -- rel8-import Rel8.Aggregate ( Aggregate )-import Rel8.Expr ( Expr )-import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) )-import Rel8.Schema.Context ( Col )-import Rel8.Schema.HTable.Either ( HEitherTable ) import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Name ( Name(..) )-import Rel8.Schema.Reify ( Reify, hreify, hunreify ) import Rel8.Schema.Result ( Result )-import Rel8.Table-  ( Table, Columns, Context, fromColumns, toColumns-  , Unreify, reify, unreify-  ) import Rel8.Table.Either ( EitherTable )-import Rel8.Table.Recontextualize ( Recontextualize )   -- | Nest an 'Either' value within a 'Rel8able'. @HEither f a b@ will produce a -- 'EitherTable' @a b@ in the 'Expr' context, and a 'Either' @a b@ in the -- 'Result' context. type HEither :: K.Context -> Type -> Type -> Type-type family HEither context where-  HEither (Reify context) = AHEither context-  HEither Aggregate = EitherTable-  HEither Expr = EitherTable-  HEither Name = EitherTable+type family HEither context = either | either -> context where   HEither Result = Either---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)-  type Unreify (AHEither context a b) = HEither context (Unreify a) (Unreify b)--  fromColumns = sfromColumnsEither contextSing-  toColumns = stoColumnsEither contextSing-  reify proof = liftA2 bimap reify reify proof . AHEither-  unreify proof = (\(AHEither a) -> a) . liftA2 bimap unreify unreify proof---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')---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)-  SResult -> \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-  SResult ->-    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)-  SResult ->-    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)+  HEither context = EitherTable context

@@ -1,87 +1,23 @@ {-# language DataKinds #-}-{-# language LambdaCase #-}-{-# language MultiParamTypeClasses #-} {-# language StandaloneKindSignatures #-} {-# language TypeFamilies #-}  module Rel8.Column.Lift-  ( Lift, ALift(..)+  ( Lift   ) where  -- base import Data.Kind ( Type )-import Prelude+import Prelude ()  -- rel8-import Rel8.Generic.Rel8able ( GColumns )-import Rel8.Kind.Context ( Reifiable(..), SContext(..) )-import Rel8.Schema.Context ( Col ) import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Reify ( Reify, hreify, hunreify ) import Rel8.Schema.Result ( Result )-import Rel8.Table-  ( Table, Columns, Context, fromColumns, toColumns-  , Unreify, reify, unreify-  )-import Rel8.Table.Rel8able ()-import Rel8.Table.HKD ( HKD( HKD ), HKDable, fromHKD, toHKD )-import Rel8.Table.Recontextualize ( Recontextualize )+import Rel8.Table.HKD ( HKD )   type Lift :: K.Context -> Type -> Type type family Lift context a where-  Lift (Reify context) a = ALift context a   Lift Result a = a   Lift context a = HKD a context---type ALift :: K.Context -> Type -> Type-newtype ALift context a = ALift-  { unALift :: Lift context a-  }---instance (Reifiable context, HKDable a) =>-  Table (Reify context) (ALift context a)- where-  type Context (ALift context a) = Reify context-  type Columns (ALift context a) = GColumns (HKD a)-  type Unreify (ALift context a) = Lift context a--  fromColumns = sfromColumnsLift contextSing-  toColumns = stoColumnsLift contextSing-  reify _ = ALift-  unreify _ (ALift a) = a---instance (Reifiable context, Reifiable context', HKDable a) =>-  Recontextualize-    (Reify context)-    (Reify context')-    (ALift context a)-    (ALift context' a)---sfromColumnsLift :: HKDable a-  => SContext context-  -> GColumns (HKD a) (Col (Reify context))-  -> ALift context a-sfromColumnsLift = \case-  SAggregate -> ALift . fromColumns . hunreify-  SExpr -> ALift . fromColumns . hunreify-  SName -> ALift . fromColumns . hunreify-  SResult -> ALift . fromHKD . HKD . hunreify-  SReify context -> ALift . sfromColumnsLift context . hunreify---stoColumnsLift :: HKDable a-  => SContext context-  -> ALift context a-  -> GColumns (HKD a) (Col (Reify context))-stoColumnsLift = \case-  SAggregate -> hreify . toColumns . unALift-  SExpr -> hreify . toColumns . unALift-  SName -> hreify . toColumns . unALift-  SResult -> hreify . (\(HKD a) -> a) . toHKD . unALift-  SReify context -> hreify . stoColumnsLift context . unALift

@@ -1,145 +1,25 @@ {-# language DataKinds #-}-{-# language FlexibleContexts #-}-{-# language LambdaCase #-}-{-# language MultiParamTypeClasses #-} {-# language StandaloneKindSignatures #-}-{-# language TypeFamilies #-}-{-# language UndecidableInstances #-}+{-# language TypeFamilyDependencies #-}  module Rel8.Column.List-  ( HList, AHList(..)+  ( HList   ) where  -- base import Data.Kind ( Type )-import Data.Type.Equality ( (:~:)( Refl ) )-import Prelude+import Prelude ()  -- rel8-import Rel8.Aggregate ( Aggregate )-import Rel8.Expr ( Expr )-import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) )-import Rel8.Schema.Context ( Col )-import Rel8.Schema.HTable.List ( HListTable ) import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Name ( Name )-import Rel8.Schema.Reify ( Reify, hreify, hunreify ) import Rel8.Schema.Result ( Result )-import Rel8.Table-  ( Table, Columns, Congruent, Context, fromColumns, toColumns-  , Unreify, reify, unreify-  )-import Rel8.Table.List ( ListTable( ListTable ) )-import Rel8.Table.Recontextualize ( Recontextualize )-import Rel8.Table.Unreify ( Unreifiability(..), Unreifiable, unreifiability )+import Rel8.Table.List ( ListTable )   -- | Nest a list within a 'Rel8able'. @HList f a@ will produce a 'ListTable' -- @a@ in the 'Expr' context, and a @[a]@ in the 'Result' context. type HList :: K.Context -> Type -> Type-type family HList context where-  HList (Reify context) = AHList context-  HList Aggregate = ListTable-  HList Expr = ListTable-  HList Name = ListTable+type family HList context = list | list -> context where   HList Result = []---type AHList :: K.Context -> Type -> Type-newtype AHList context a = AHList (HList context a)---instance (Reifiable context, Unreifiable a, 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)-  type Unreify (AHList context a) = HList context (Unreify a)--  fromColumns = sfromColumnsList contextSing-  toColumns = stoColumnsList contextSing--  reify _ = sreifyList (unreifiability contextSing)-  unreify _ = sunreifyList (unreifiability contextSing)---instance-  ( Reifiable context, Reifiable context'-  , Unreifiable a, Unreifiable a'-  , Recontextualize (Reify context) (Reify context') a a'-  )-  => Recontextualize-    (Reify context)-    (Reify context')-    (AHList context a)-    (AHList context' 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))-  SResult -> \f _ (AHList as) -> AHList (fmap f as)-  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-  SResult -> AHList . fmap (fromColumns . hreify) . fromColumns . hunreify-  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-  SResult ->-    hreify . toColumns . fmap (hunreify . toColumns) . (\(AHList a) -> a)-  SName -> \(AHList (ListTable a)) -> a-  SReify context ->-    hreify .-    stoColumnsList context .-    smapList context (hunreify . toColumns) hunreify .-    (\(AHList a) -> a)---sreifyList :: Table (Reify context) a-  => Unreifiability context a-  -> HList context (Unreify a)-  -> AHList context a-sreifyList = \case-  UResult -> AHList . fmap (reify Refl)-  Unreifiability context ->-    smapList context (reify Refl) hreify .-    AHList---sunreifyList :: Table (Reify context) a-  => Unreifiability context a-  -> AHList context a-  -> HList context (Unreify a)-sunreifyList = \case-  UResult -> fmap (unreify Refl) . (\(AHList a) -> a)-  Unreifiability context ->-    (\(AHList a) -> a) .-    smapList context (unreify Refl) hunreify+  HList context = ListTable context

@@ -1,14 +1,9 @@ {-# language DataKinds #-}-{-# language FlexibleContexts #-}-{-# language GADTs #-}-{-# language LambdaCase #-}-{-# language MultiParamTypeClasses #-} {-# language StandaloneKindSignatures #-}-{-# language TypeFamilies #-}-{-# language UndecidableInstances #-}+{-# language TypeFamilyDependencies #-}  module Rel8.Column.Maybe-  ( HMaybe, AHMaybe(..)+  ( HMaybe   ) where @@ -17,111 +12,15 @@ import Prelude  -- rel8-import Rel8.Aggregate ( Aggregate )-import Rel8.Expr ( Expr )-import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) )-import Rel8.Schema.Context ( Col )-import Rel8.Schema.HTable.Maybe ( HMaybeTable ) import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Name ( Name )-import Rel8.Schema.Reify ( Reify, hreify, hunreify ) import Rel8.Schema.Result ( Result )-import Rel8.Table-  ( Table, Columns, Context, fromColumns, toColumns-  , Unreify, reify, unreify-  ) import Rel8.Table.Maybe ( MaybeTable )-import Rel8.Table.Recontextualize ( Recontextualize )   -- | Nest a 'Maybe' value within a 'Rel8able'. @HMaybe f a@ will produce a -- 'MaybeTable' @a@ in the 'Expr' context, and a 'Maybe' @a@ in the 'Result' -- context. type HMaybe :: K.Context -> Type -> Type-type family HMaybe context where-  HMaybe (Reify context) = AHMaybe context-  HMaybe Aggregate = MaybeTable-  HMaybe Expr = MaybeTable-  HMaybe Name = MaybeTable+type family HMaybe context = maybe | maybe -> context where   HMaybe Result = Maybe---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)-  type Unreify (AHMaybe context a) = HMaybe context (Unreify a)--  fromColumns = sfromColumnsMaybe contextSing-  toColumns = stoColumnsMaybe contextSing-  reify proof = fmap fmap reify proof . AHMaybe-  unreify proof = (\(AHMaybe a) -> a) . fmap fmap unreify proof---instance-  ( Reifiable context, Reifiable context'-  , Recontextualize (Reify context) (Reify context') a a'-  ) =>-  Recontextualize-    (Reify context)-    (Reify context')-    (AHMaybe context a)-    (AHMaybe context' 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)-  SResult -> \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-  SResult -> 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)-  SResult ->-    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)+  HMaybe context = MaybeTable context

@@ -1,148 +1,27 @@ {-# language DataKinds #-}-{-# language FlexibleContexts #-}-{-# language LambdaCase #-}-{-# language MultiParamTypeClasses #-} {-# language StandaloneKindSignatures #-}-{-# language TypeFamilies #-}-{-# language UndecidableInstances #-}+{-# language TypeFamilyDependencies #-}  module Rel8.Column.NonEmpty-  ( HNonEmpty, AHNonEmpty(..)+  ( HNonEmpty   ) where  -- base import Data.Kind ( Type ) import Data.List.NonEmpty ( NonEmpty )-import Data.Type.Equality ( (:~:)( Refl ) )-import Prelude+import Prelude ()  -- rel8-import Rel8.Aggregate ( Aggregate )-import Rel8.Expr ( Expr )-import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) )-import Rel8.Schema.Context ( Col )-import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable ) import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Name ( Name )-import Rel8.Schema.Reify ( Reify, hreify, hunreify ) import Rel8.Schema.Result ( Result )-import Rel8.Table-  ( Table, Columns, Congruent, Context, fromColumns, toColumns-  , Unreify, reify, unreify-  )-import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) )-import Rel8.Table.Recontextualize ( Recontextualize )-import Rel8.Table.Unreify ( Unreifiability(..), Unreifiable, unreifiability )+import Rel8.Table.NonEmpty ( NonEmptyTable )   -- | Nest a 'NonEmpty' list within a 'Rel8able'. @HNonEmpty f a@ will produce a -- 'NonEmptyTable' @a@ in the 'Expr' context, and a 'NonEmpty' @a@ in the -- 'Result' context. type HNonEmpty :: K.Context -> Type -> Type-type family HNonEmpty context where-  HNonEmpty (Reify context) = AHNonEmpty context-  HNonEmpty Aggregate = NonEmptyTable-  HNonEmpty Expr = NonEmptyTable-  HNonEmpty Name = NonEmptyTable+type family HNonEmpty context = nonEmpty | nonEmpty -> context where   HNonEmpty Result = NonEmpty---type AHNonEmpty :: K.Context -> Type -> Type-newtype AHNonEmpty context a = AHNonEmpty (HNonEmpty context a)---instance (Reifiable context, Unreifiable a, 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)-  type Unreify (AHNonEmpty context a) = HNonEmpty context (Unreify a)--  fromColumns = sfromColumnsNonEmpty contextSing-  toColumns = stoColumnsNonEmpty contextSing--  reify _ = sreifyNonEmpty (unreifiability contextSing)-  unreify _ = sunreifyNonEmpty (unreifiability contextSing)---instance-  ( Reifiable context, Reifiable context'-  , Unreifiable a, Unreifiable a'-  , Recontextualize (Reify context) (Reify context') a a'-  )-  => Recontextualize-    (Reify context)-    (Reify context')-    (AHNonEmpty context a)-    (AHNonEmpty context' 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))-  SResult -> \f _ (AHNonEmpty as) -> AHNonEmpty (fmap f as)-  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-  SResult ->-    AHNonEmpty . fmap (fromColumns . hreify) . fromColumns . hunreify-  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-  SResult ->-    hreify . toColumns . fmap (hunreify . toColumns) . (\(AHNonEmpty a) -> a)-  SName -> \(AHNonEmpty (NonEmptyTable a)) -> a-  SReify context ->-    hreify .-    stoColumnsNonEmpty context .-    smapNonEmpty context (hunreify . toColumns) hunreify .-    (\(AHNonEmpty a) -> a)---sreifyNonEmpty :: Table (Reify context) a-  => Unreifiability context a-  -> HNonEmpty context (Unreify a)-  -> AHNonEmpty context a-sreifyNonEmpty = \case-  UResult -> AHNonEmpty . fmap (reify Refl)-  Unreifiability context ->-    smapNonEmpty context (reify Refl) hreify .-    AHNonEmpty---sunreifyNonEmpty :: Table (Reify context) a-  => Unreifiability context a-  -> AHNonEmpty context a-  -> HNonEmpty context (Unreify a)-sunreifyNonEmpty = \case-  UResult -> fmap (unreify Refl) . (\(AHNonEmpty a) -> a)-  Unreifiability context ->-    (\(AHNonEmpty a) -> a) .-    smapNonEmpty context (unreify Refl) hunreify+  HNonEmpty context = NonEmptyTable context

@@ -1,38 +1,19 @@ {-# language DataKinds #-}-{-# language FlexibleContexts #-}-{-# language GADTs #-}-{-# language LambdaCase #-}-{-# language MultiParamTypeClasses #-} {-# language StandaloneKindSignatures #-}-{-# language TypeFamilies #-}-{-# language UndecidableInstances #-}+{-# language TypeFamilyDependencies #-}  module Rel8.Column.These-  ( HThese, AHThese(..)+  ( HThese   ) where  -- base-import Control.Applicative ( liftA2 )-import Data.Bifunctor ( Bifunctor, bimap ) import Data.Kind ( Type )-import Prelude+import Prelude ()  -- rel8-import Rel8.Aggregate ( Aggregate )-import Rel8.Expr ( Expr )-import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) )-import Rel8.Schema.Context ( Col )-import Rel8.Schema.HTable.These ( HTheseTable ) import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Name ( Name )-import Rel8.Schema.Reify ( Reify, hreify, hunreify ) import Rel8.Schema.Result ( Result )-import Rel8.Table-  ( Table, Columns, Context, fromColumns, toColumns-  , Unreify, reify, unreify-  )-import Rel8.Table.Recontextualize ( Recontextualize ) import Rel8.Table.These ( TheseTable )  -- these@@ -43,124 +24,6 @@ -- 'TheseTable' @a b@ in the 'Expr' context, and a 'These' @a b@ in the -- 'Result' context. type HThese :: K.Context -> Type -> Type -> Type-type family HThese context where-  HThese (Reify context) = AHThese context-  HThese Aggregate = TheseTable-  HThese Expr = TheseTable-  HThese Name = TheseTable+type family HThese context = these | these -> context where   HThese Result = These---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)-  type Unreify (AHThese context a b) = HThese context (Unreify a) (Unreify b)--  fromColumns = sfromColumnsThese contextSing-  toColumns = stoColumnsThese contextSing-  reify proof = liftA2 bimap reify reify proof . AHThese-  unreify proof = (\(AHThese a) -> a) . liftA2 bimap unreify unreify proof---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')---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)-  SResult -> \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-  SResult ->-    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)-  SResult ->-    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)+  HThese context = TheseTable context

@@ -1,27 +1,20 @@ {-# language DataKinds #-} {-# language DerivingStrategies #-} {-# language FlexibleInstances #-}-{-# language GADTs #-} {-# language MultiParamTypeClasses #-}-{-# language PolyKinds #-}-{-# language RoleAnnotations #-} {-# language ScopedTypeVariables #-}-{-# language StandaloneDeriving #-} {-# language StandaloneKindSignatures #-} {-# language TypeApplications #-} {-# language TypeFamilies #-} {-# language UndecidableInstances #-}-{-# language UndecidableSuperClasses #-}  module Rel8.Expr   ( Expr(..)-  , Col( E, unE )   ) where  -- base-import Data.Functor.Identity ( Identity )-import Data.Kind ( Type )+import Data.Functor.Identity ( Identity( Identity ) ) import Data.String ( IsString, fromString ) import Prelude hiding ( null ) @@ -38,17 +31,14 @@   , zipPrimExprsWith   ) import Rel8.Expr.Serialize ( litExpr )-import Rel8.Schema.Context ( Interpretation, Col )-import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )-import Rel8.Schema.HTable.Identity ( HIdentity( HType ), HType )+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )+import qualified Rel8.Schema.Kind as K import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )-import Rel8.Schema.Reify ( notReify )-import Rel8.Schema.Result ( Result )-import Rel8.Schema.Spec ( Spec( Spec ) ) import Rel8.Table-  ( Table, Columns, Context, fromColumns, toColumns, reify, unreify+  ( Table, Columns, Context, fromColumns, toColumns+  , FromExprs, fromResult, toResult+  , Transpose   )-import Rel8.Table.Recontextualize ( Recontextualize ) import Rel8.Type ( DBType ) import Rel8.Type.Monoid ( DBMonoid, memptyExpr ) import Rel8.Type.Num ( DBFloating, DBFractional, DBNum )@@ -56,13 +46,9 @@   -- | Typed SQL expressions.-type role Expr representational-type Expr :: k -> Type-data Expr a where-  Expr :: k ~ Type => !Opaleye.PrimExpr -> Expr (a :: k)---deriving stock instance Show (Expr a)+type Expr :: K.Context+newtype Expr a = Expr Opaleye.PrimExpr+  deriving stock Show   instance Sql DBSemigroup a => Semigroup (Expr a) where@@ -126,30 +112,13 @@   atanh = function "atanh"  -instance Interpretation Expr where-  data Col Expr _spec where-    E :: {unE :: !(Expr a)} -> Col Expr ('Spec labels a)-- instance Sql DBType a => Table Expr (Expr a) where-  type Columns (Expr a) = HType a+  type Columns (Expr a) = HIdentity a   type Context (Expr a) = Expr--  toColumns a = HType (E a)-  fromColumns (HType (E a)) = a-  reify = notReify-  unreify = notReify---instance Sql DBType a => Recontextualize Expr Expr (Expr a) (Expr a)---instance Sql DBType a => Recontextualize Expr Result (Expr a) (Identity a)---instance Sql DBType a => Recontextualize Result Expr (Identity a) (Expr a)-+  type FromExprs (Expr a) = a+  type Transpose to (Expr a) = to a -instance Labelable Expr where-  labeler (E a) = E a-  unlabeler (E a) = E a+  toColumns a = HIdentity a+  fromColumns (HIdentity a) = a+  toResult a = HIdentity (Identity a)+  fromResult (HIdentity (Identity a)) = a

@@ -1,6 +1,4 @@-{-# language GADTs #-}-{-# language PolyKinds #-}-{-# language RoleAnnotations #-}+{-# language DataKinds #-} {-# language StandaloneKindSignatures #-}  module Rel8.Expr@@ -9,14 +7,14 @@ where  -- base-import Data.Kind ( Type ) import Prelude ()  -- opaleye import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye +-- rel8+import Rel8.Schema.Kind ( Context ) -type role Expr representational-type Expr :: k -> Type-data Expr a where-  Expr :: k ~ Type => !Opaleye.PrimExpr -> Expr (a :: k)++type Expr :: Context+newtype Expr a = Expr Opaleye.PrimExpr

@@ -0,0 +1,35 @@+module Rel8.Expr.Default+  ( unsafeDefault+  )+where++-- base+import Prelude ()++-- opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye++-- rel8+import Rel8.Expr ( Expr )+import Rel8.Expr.Opaleye ( fromPrimExpr )+++-- | Corresponds to the SQL @DEFAULT@ expression.+--+-- This 'Expr' is unsafe for numerous reasons, and should be used with care:+--+-- 1. This 'Expr' only makes sense in an @INSERT@ or @UPDATE@ statement.+--+-- 2. Rel8 is not able to verify that a particular column actually has a+-- @DEFAULT@ value. Trying to use @unsafeDefault@ where there is no default+-- will cause a runtime crash+--+-- 3. @DEFAULT@ values can not be transformed. For example, the innocuous Rel8+-- code @unsafeDefault + 1@ will crash, despite type checking.+--+-- Given all these caveats, we suggest avoiding the use of default values where+-- possible, instead being explicit. A common scenario where default values are+-- used is with auto-incrementing identifier columns. In this case, we suggest+-- using 'Rel8.nextval' instead.+unsafeDefault :: Expr a+unsafeDefault = fromPrimExpr Opaleye.DefaultInsertExpr

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

@@ -5,7 +5,7 @@  module Rel8.FCF   ( Exp, Eval-  , Compose+  , Id   ) where @@ -22,5 +22,5 @@ type family Eval a  -data Compose :: (Type -> Type) -> (Type -> Exp Type) -> Type -> Exp Type-type instance Eval (Compose f g a) = f (Eval (g a))+data Id :: a -> Exp a+type instance Eval (Id a) = a

@@ -2,9 +2,6 @@ {-# language ConstraintKinds #-} {-# language DataKinds #-} {-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language LambdaCase #-}-{-# language MultiParamTypeClasses #-} {-# language NamedFieldPuns #-} {-# language ScopedTypeVariables #-} {-# language StandaloneKindSignatures #-}@@ -28,18 +25,17 @@ import Data.Bifunctor ( first ) import Data.Kind ( Constraint, Type ) import Data.List.NonEmpty ( NonEmpty( (:|) ) )-import Data.Type.Equality ( (:~:)( Refl ) ) import GHC.TypeLits ( Symbol ) import Prelude  -- rel8-import Rel8.Aggregate ( Col( A ), Aggregate( Aggregate ) )-import Rel8.Expr ( Col( E ), Expr )+import Rel8.Aggregate ( Aggregate( Aggregate ) )+import Rel8.Expr ( Expr ) import Rel8.Expr.Aggregate ( groupByExpr ) import Rel8.Expr.Eq ( (==.) ) import Rel8.Expr.Null ( nullify, snull, unsafeUnnullify ) import Rel8.Expr.Serialize ( litExpr )-import Rel8.FCF ( Eval, Exp )+import Rel8.FCF ( Eval, Exp, Id ) import Rel8.Generic.Construction.ADT   ( GConstructorADT, GMakeableADT, gmakeADT   , GConstructableADT@@ -59,18 +55,16 @@   , KnownAlgebra, algebraSing   ) import qualified Rel8.Kind.Algebra as K-import Rel8.Schema.Context.Nullify ( runTag )+import Rel8.Schema.Context.Nullify ( sguard, snullify ) import Rel8.Schema.HTable ( HTable )-import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) ) import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Name ( Col( N ), Name( Name ) )+import Rel8.Schema.Name ( Name( Name ) ) import Rel8.Schema.Null ( Nullity( Null, NotNull ) )-import Rel8.Schema.Spec ( SSpec( SSpec, nullity, info ) )-import Rel8.Schema.Reify ( Col( Reify ), Reify, hreify, hunreify )-import Rel8.Schema.Result ( Result )+import Rel8.Schema.Spec ( Spec( Spec, nullity, info ) ) import Rel8.Table-  ( TTable, TColumns, TUnreify-  , Table, fromColumns, toColumns, reify, unreify+  ( TTable, TColumns+  , Table, fromColumns, toColumns   ) import Rel8.Table.Bool ( case_ ) import Rel8.Type.Tag ( Tag )@@ -79,10 +73,10 @@ type GGBuildable :: K.Algebra -> Symbol -> (K.Context -> Exp (Type -> Type)) -> Constraint type GGBuildable algebra name rep =   ( KnownAlgebra algebra-  , Eval (GGColumns algebra TColumns (Eval (rep (Reify Aggregate)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))-  , Eval (GGColumns algebra TColumns (Eval (rep (Reify Expr)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))-  , Eval (GGColumns algebra TColumns (Eval (rep (Reify Name)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))-  , HTable (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))))+  , Eval (GGColumns algebra TColumns (Eval (rep Aggregate))) ~ Eval (GGColumns algebra TColumns (Eval (rep Expr)))+  , Eval (GGColumns algebra TColumns (Eval (rep Expr))) ~ Eval (GGColumns algebra TColumns (Eval (rep Expr)))+  , Eval (GGColumns algebra TColumns (Eval (rep Name))) ~ Eval (GGColumns algebra TColumns (Eval (rep Expr)))+  , HTable (Eval (GGColumns algebra TColumns (Eval (rep Expr))))   , GGBuildable' algebra name rep   ) @@ -90,65 +84,63 @@ type GGBuildable' :: K.Algebra -> Symbol -> (K.Context -> Exp (Type -> Type)) -> Constraint type family GGBuildable' algebra name rep where   GGBuildable' 'K.Product name rep =-    ( name ~ GConstructor (Eval (rep (Reify Expr)))-    , Representable TUnreify (Eval (rep (Reify Expr)))-    , GConstructable (TTable (Reify Expr)) TColumns TUnreify (Col (Reify Expr)) (Eval (rep (Reify Expr)))+    ( name ~ GConstructor (Eval (rep Expr))+    , Representable Id (Eval (rep Expr))+    , GConstructable (TTable Expr) TColumns Id Expr (Eval (rep Expr))     )   GGBuildable' 'K.Sum name rep =-    ( Representable TUnreify (GConstructorADT name (Eval (rep (Reify Expr))))-    , GMakeableADT (TTable (Reify Expr)) TColumns TUnreify (Col (Reify Expr)) name (Eval (rep (Reify Expr)))+    ( Representable Id (GConstructorADT name (Eval (rep Expr)))+    , GMakeableADT (TTable Expr) TColumns Id Expr name (Eval (rep Expr))     )   type GGBuild :: K.Algebra -> Symbol -> (K.Context -> Exp (Type -> Type)) -> Type -> Type type family GGBuild algebra name rep r where   GGBuild 'K.Product _name rep r =-    GConstruct TUnreify (Eval (rep (Reify Expr))) r+    GConstruct Id (Eval (rep Expr)) r   GGBuild 'K.Sum name rep r =-    GConstruct TUnreify (GConstructorADT name (Eval (rep (Reify Expr)))) r+    GConstruct Id (GConstructorADT name (Eval (rep Expr))) r   ggbuild :: forall algebra name rep a. GGBuildable algebra name rep-  => (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Expr) -> a)+  => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr -> a)   -> GGBuild algebra name rep a ggbuild gfromColumns = case algebraSing @algebra of   SProduct ->-    gtabulate @TUnreify @(Eval (rep (Reify Expr))) @a $+    gtabulate @Id @(Eval (rep Expr)) @a $     gfromColumns .-    hunreify .     gconstruct-      @(TTable (Reify Expr))+      @(TTable Expr)       @TColumns-      @TUnreify-      @(Col (Reify Expr))-      @(Eval (rep (Reify Expr)))-      (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)+      @Id+      @Expr+      @(Eval (rep Expr))+      (const toColumns)   SSum ->-    gtabulate @TUnreify @(GConstructorADT name (Eval (rep (Reify Expr)))) @a $+    gtabulate @Id @(GConstructorADT name (Eval (rep Expr))) @a $     gfromColumns .-    hunreify .     gmakeADT-      @(TTable (Reify Expr))+      @(TTable Expr)       @TColumns-      @TUnreify-      @(Col (Reify Expr))+      @Id+      @Expr       @name-      @(Eval (rep (Reify Expr)))-      (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)-      (\SSpec {info} -> Reify (E (snull info)))-      (\SSpec {nullity} -> case nullity of+      @(Eval (rep Expr))+      (const toColumns)+      (\Spec {info} -> snull info)+      (\Spec {nullity} -> case nullity of         Null -> id-        NotNull -> \(Reify (E a)) -> Reify (E (nullify a)))-      (HType . Reify . E . litExpr)+        NotNull -> nullify)+      (HIdentity . litExpr)   type GGConstructable :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Constraint type GGConstructable algebra rep =   ( KnownAlgebra algebra-  , Eval (GGColumns algebra TColumns (Eval (rep (Reify Aggregate)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))-  , Eval (GGColumns algebra TColumns (Eval (rep (Reify Expr)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))-  , Eval (GGColumns algebra TColumns (Eval (rep (Reify Name)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))-  , HTable (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))))+  , Eval (GGColumns algebra TColumns (Eval (rep Aggregate))) ~ Eval (GGColumns algebra TColumns (Eval (rep Expr)))+  , Eval (GGColumns algebra TColumns (Eval (rep Expr))) ~ Eval (GGColumns algebra TColumns (Eval (rep Expr)))+  , Eval (GGColumns algebra TColumns (Eval (rep Name))) ~ Eval (GGColumns algebra TColumns (Eval (rep Expr)))+  , HTable (Eval (GGColumns algebra TColumns (Eval (rep Expr))))   , GGConstructable' algebra rep   ) @@ -156,105 +148,100 @@ type GGConstructable' :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Constraint type family GGConstructable' algebra rep where   GGConstructable' 'K.Product rep =-    ( Representable TUnreify (Eval (rep (Reify Aggregate)))-    , Representable TUnreify (Eval (rep (Reify Expr)))-    , Representable TUnreify (Eval (rep (Reify Name)))-    , GConstructable (TTable (Reify Aggregate)) TColumns TUnreify (Col (Reify Aggregate)) (Eval (rep (Reify Aggregate)))-    , GConstructable (TTable (Reify Expr)) TColumns TUnreify (Col (Reify Expr)) (Eval (rep (Reify Expr)))-    , GConstructable (TTable (Reify Name)) TColumns TUnreify (Col (Reify Name)) (Eval (rep (Reify Name)))+    ( Representable Id (Eval (rep Aggregate))+    , Representable Id (Eval (rep Expr))+    , Representable Id (Eval (rep Name))+    , GConstructable (TTable Aggregate) TColumns Id Aggregate (Eval (rep Aggregate))+    , GConstructable (TTable Expr) TColumns Id Expr (Eval (rep Expr))+    , GConstructable (TTable Name) TColumns Id Name (Eval (rep Name))     )   GGConstructable' 'K.Sum rep =-    ( RepresentableConstructors TUnreify (Eval (rep (Reify Expr)))-    , RepresentableFields TUnreify (Eval (rep (Reify Aggregate)))-    , RepresentableFields TUnreify (Eval (rep (Reify Expr)))-    , RepresentableFields TUnreify (Eval (rep (Reify Name)))-    , Functor (GConstructors TUnreify (Eval (rep (Reify Expr))))-    , GConstructableADT (TTable (Reify Aggregate)) TColumns TUnreify (Col (Reify Aggregate)) (Eval (rep (Reify Aggregate)))-    , GConstructableADT (TTable (Reify Expr)) TColumns TUnreify (Col (Reify Expr)) (Eval (rep (Reify Expr)))-    , GConstructableADT (TTable (Reify Name)) TColumns TUnreify (Col (Reify Name)) (Eval (rep (Reify Name)))+    ( RepresentableConstructors Id (Eval (rep Expr))+    , RepresentableFields Id (Eval (rep Aggregate))+    , RepresentableFields Id (Eval (rep Expr))+    , RepresentableFields Id (Eval (rep Name))+    , Functor (GConstructors Id (Eval (rep Expr)))+    , GConstructableADT (TTable Aggregate) TColumns Id Aggregate (Eval (rep Aggregate))+    , GConstructableADT (TTable Expr) TColumns Id Expr (Eval (rep Expr))+    , GConstructableADT (TTable Name) TColumns Id Name (Eval (rep Name))     )   type GGConstruct :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type type family GGConstruct algebra rep r where-  GGConstruct 'K.Product rep r =-    GConstruct TUnreify (Eval (rep (Reify Expr))) r -> r-  GGConstruct 'K.Sum rep r =-    GConstructADT TUnreify (Eval (rep (Reify Expr))) r r+  GGConstruct 'K.Product rep r = GConstruct Id (Eval (rep Expr)) r -> r+  GGConstruct 'K.Sum rep r = GConstructADT Id (Eval (rep Expr)) r r   ggconstruct :: forall algebra rep a. GGConstructable algebra rep-  => (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Expr) -> a)+  => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr -> a)   -> GGConstruct algebra rep a -> a ggconstruct gfromColumns f = case algebraSing @algebra of   SProduct ->     f $-    gtabulate @TUnreify @(Eval (rep (Reify Expr))) @a $+    gtabulate @Id @(Eval (rep Expr)) @a $     gfromColumns .-    hunreify .     gconstruct-      @(TTable (Reify Expr))+      @(TTable Expr)       @TColumns-      @TUnreify-      @(Col (Reify Expr))-      @(Eval (rep (Reify Expr)))-      (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)+      @Id+      @Expr+      @(Eval (rep Expr))+      (const toColumns)   SSum ->-    gcindex @TUnreify @(Eval (rep (Reify Expr))) @a f $-    fmap (gfromColumns . hunreify) $+    gcindex @Id @(Eval (rep Expr)) @a f $+    fmap gfromColumns $     gconstructADT-      @(TTable (Reify Expr))+      @(TTable Expr)       @TColumns-      @TUnreify-      @(Col (Reify Expr))-      @(Eval (rep (Reify Expr)))-      (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)-      (\SSpec {info} -> Reify (E (snull info)))-      (\SSpec {nullity} -> case nullity of+      @Id+      @Expr+      @(Eval (rep Expr))+      (const toColumns)+      (\Spec {info} -> snull info)+      (\Spec {nullity} -> case nullity of         Null -> id-        NotNull -> \(Reify (E a)) -> Reify (E (nullify a)))-      (HType . Reify . E . litExpr)+        NotNull -> nullify)+      (HIdentity . litExpr)   type GGDeconstruct :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type -> Type type family GGDeconstruct algebra rep a r where   GGDeconstruct 'K.Product rep a r =-    GConstruct TUnreify (Eval (rep (Reify Expr))) r -> a -> r+    GConstruct Id (Eval (rep Expr)) r -> a -> r   GGDeconstruct 'K.Sum rep a r =-    GConstructADT TUnreify (Eval (rep (Reify Expr))) r (a -> r)+    GConstructADT Id (Eval (rep Expr)) r (a -> r)   ggdeconstruct :: forall algebra rep a r. (GGConstructable algebra rep, Table Expr r)-  => (a -> Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Expr))+  => (a -> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr)   -> GGDeconstruct algebra rep a r ggdeconstruct gtoColumns = case algebraSing @algebra of   SProduct -> \build ->-    gindex @TUnreify @(Eval (rep (Reify Expr))) @r build .+    gindex @Id @(Eval (rep Expr)) @r build .     gdeconstruct-      @(TTable (Reify Expr))+      @(TTable Expr)       @TColumns-      @TUnreify-      @(Col (Reify Expr))-      @(Eval (rep (Reify Expr)))-      (\(_ :: proxy x) -> unreify @_ @x Refl . fromColumns) .-    hreify .+      @Id+      @Expr+      @(Eval (rep Expr))+      (const fromColumns) .     gtoColumns   SSum ->-    gctabulate @TUnreify @(Eval (rep (Reify Expr))) @r @(a -> r) $ \constructors as ->+    gctabulate @Id @(Eval (rep Expr)) @r @(a -> r) $ \constructors as ->       let-        (HType (Reify (E tag)), cases) =+        (HIdentity tag, cases) =           gdeconstructADT-            @(TTable (Reify Expr))+            @(TTable Expr)             @TColumns-            @TUnreify-            @(Col (Reify Expr))-            @(Eval (rep (Reify Expr)))-            (\(_ :: proxy x) -> unreify @_ @x Refl . fromColumns)-            (\SSpec {nullity} -> case nullity of+            @Id+            @Expr+            @(Eval (rep Expr))+            (const fromColumns)+            (\Spec {nullity} -> case nullity of               Null -> id-              NotNull -> \(Reify (E a)) -> Reify (E (unsafeUnnullify a)))+              NotNull -> unsafeUnnullify)             constructors $-          hreify $           gtoColumns as       in         case cases of@@ -264,108 +251,102 @@  type GGName :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type type family GGName algebra rep a where-  GGName 'K.Product rep a = GConstruct TUnreify (Eval (rep (Reify Name))) a-  GGName 'K.Sum rep a = Name Tag -> GBuildADT TUnreify (Eval (rep (Reify Name))) a+  GGName 'K.Product rep a = GConstruct Id (Eval (rep Name)) a+  GGName 'K.Sum rep a = Name Tag -> GBuildADT Id (Eval (rep Name)) a   ggname :: forall algebra rep a. GGConstructable algebra rep-  => (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Name) -> a)+  => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Name -> a)   -> GGName algebra rep a ggname gfromColumns = case algebraSing @algebra of   SProduct ->-    gtabulate @TUnreify @(Eval (rep (Reify Name))) @a $+    gtabulate @Id @(Eval (rep Name)) @a $     gfromColumns .-    hunreify .     gconstruct-      @(TTable (Reify Name))+      @(TTable Name)       @TColumns-      @TUnreify-      @(Col (Reify Name))-      @(Eval (rep (Reify Name)))-      (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)+      @Id+      @Name+      @(Eval (rep Name))+      (const toColumns)   SSum -> \tag ->-    gftabulate @TUnreify @(Eval (rep (Reify Name))) @a $+    gftabulate @Id @(Eval (rep Name)) @a $     gfromColumns .-    hunreify .     gbuildADT-      @(TTable (Reify Name))+      @(TTable Name)       @TColumns-      @TUnreify-      @(Col (Reify Name))-      @(Eval (rep (Reify Name)))-      (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)-      (\_ _ (Reify (N (Name a))) -> Reify (N (Name a)))-      (HType (Reify (N tag)))+      @Id+      @Name+      @(Eval (rep Name))+      (const toColumns)+      (\_ _ (Name a) -> Name a)+      (HIdentity tag)   type GGAggregate :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type type family GGAggregate algebra rep r where   GGAggregate 'K.Product rep r =-    GConstruct TUnreify (Eval (rep (Reify Aggregate))) r ->-      GConstruct TUnreify (Eval (rep (Reify Expr))) r+    GConstruct Id (Eval (rep Aggregate)) r ->+      GConstruct Id (Eval (rep Expr)) r   GGAggregate 'K.Sum rep r =-    GBuildADT TUnreify (Eval (rep (Reify Aggregate))) r ->-      GBuildADT TUnreify (Eval (rep (Reify Expr))) r+    GBuildADT Id (Eval (rep Aggregate)) r ->+      GBuildADT Id (Eval (rep Expr)) r   ggaggregate :: forall algebra rep exprs agg. GGConstructable algebra rep-  => (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Aggregate) -> agg)-  -> (exprs -> Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Expr))+  => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Aggregate -> agg)+  -> (exprs -> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr)   -> GGAggregate algebra rep agg -> exprs -> agg ggaggregate gfromColumns gtoColumns agg es = case algebraSing @algebra of   SProduct -> flip f exprs $     gfromColumns .-    hunreify .     gconstruct-      @(TTable (Reify Aggregate))+      @(TTable Aggregate)       @TColumns-      @TUnreify-      @(Col (Reify Aggregate))-      @(Eval (rep (Reify Aggregate)))-      (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)+      @Id+      @Aggregate+      @(Eval (rep Aggregate))+      (const toColumns)     where       f =-        gindex @TUnreify @(Eval (rep (Reify Expr))) @agg .+        gindex @Id @(Eval (rep Expr)) @agg .         agg .-        gtabulate @TUnreify @(Eval (rep (Reify Aggregate))) @agg+        gtabulate @Id @(Eval (rep Aggregate)) @agg       exprs =         gdeconstruct-          @(TTable (Reify Expr))+          @(TTable Expr)           @TColumns-          @TUnreify-          @(Col (Reify Expr))-          @(Eval (rep (Reify Expr)))-          (\(_ :: proxy x) -> unreify @_ @x Refl . fromColumns) $-        hreify $+          @Id+          @Expr+          @(Eval (rep Expr))+          (const fromColumns) $         gtoColumns es   SSum -> flip f exprs $     gfromColumns .-    hunreify .     gbuildADT-      @(TTable (Reify Aggregate))+      @(TTable Aggregate)       @TColumns-      @TUnreify-      @(Col (Reify Aggregate))-      @(Eval (rep (Reify Aggregate)))-      (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)-      (\tag' SSpec {nullity} (Reify (A (Aggregate a))) ->-        Reify $ A $ Aggregate $ runTag nullity (tag ==. litExpr tag') <$> a)-      (HType (Reify (A (groupByExpr tag))))+      @Id+      @Aggregate+      @(Eval (rep Aggregate))+      (const toColumns)+      (\tag' Spec {nullity} (Aggregate a) ->+        Aggregate $ sguard (tag ==. litExpr tag') . snullify nullity <$> a)+      (HIdentity (groupByExpr tag))     where       f =-        gfindex @TUnreify @(Eval (rep (Reify Expr))) @agg .+        gfindex @Id @(Eval (rep Expr)) @agg .         agg .-        gftabulate @TUnreify @(Eval (rep (Reify Aggregate))) @agg-      (HType (Reify (E tag)), exprs) =+        gftabulate @Id @(Eval (rep Aggregate)) @agg+      (HIdentity tag, exprs) =         gunbuildADT-          @(TTable (Reify Expr))+          @(TTable Expr)           @TColumns-          @TUnreify-          @(Col (Reify Expr))-          @(Eval (rep (Reify Expr)))-          (\(_ :: proxy x) -> unreify @_ @x Refl . fromColumns)-          (\SSpec {nullity} -> case nullity of+          @Id+          @Expr+          @(Eval (rep Expr))+          (const fromColumns)+          (\Spec {nullity} -> case nullity of             Null -> id-            NotNull -> \(Reify (E a)) -> Reify (E (unsafeUnnullify a))) $-        hreify $+            NotNull -> unsafeUnnullify) $         gtoColumns es

@@ -48,14 +48,13 @@   ) import Rel8.Generic.Table.ADT ( GColumnsADT, GColumnsADT' ) import Rel8.Generic.Table.Record ( GColumns )-import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler ) import Rel8.Schema.HTable ( HTable )-import Rel8.Schema.HTable.Identity ( HType )+import Rel8.Schema.HTable.Identity ( HIdentity ) import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel ) import Rel8.Schema.HTable.Nullify ( HNullify, hnulls, hnullify, hunnullify ) import Rel8.Schema.HTable.Product ( HProduct( HProduct ) ) import Rel8.Schema.Null ( Nullify )-import Rel8.Schema.Spec ( Spec( Spec ), SSpec )+import Rel8.Schema.Spec ( Spec ) import qualified Rel8.Schema.Kind as K import Rel8.Type.Tag ( Tag( Tag ) ) @@ -63,24 +62,16 @@ import Data.Text ( pack )  -type Null :: K.HContext -> Type-type Null context = forall labels a. ()-  => SSpec ('Spec labels a)-  -> context ('Spec labels (Nullify a))+type Null :: K.Context -> Type+type Null context = forall a. Spec a -> context (Nullify a)  -type Nullifier :: K.HContext -> Type-type Nullifier context = forall labels a. ()-  => SSpec ('Spec labels a)-  -> context ('Spec labels a)-  -> context ('Spec labels (Nullify a))+type Nullifier :: K.Context -> Type+type Nullifier context = forall a. Spec a -> context a -> context (Nullify a)  -type Unnullifier :: K.HContext -> Type-type Unnullifier context = forall labels a. ()-  => SSpec ('Spec labels a)-  -> context ('Spec labels (Nullify a))-  -> context ('Spec labels a)+type Unnullifier :: K.Context -> Type+type Unnullifier context = forall a. Spec a -> context (Nullify a) -> context a   type NoConstructor :: Symbol -> Symbol -> ErrorMessage@@ -189,12 +180,12 @@   :: (Type -> Exp Constraint)   -> (Type -> Exp K.HTable)   -> (Type -> Exp Type)-  -> K.HContext -> (Type -> Type) -> Constraint+  -> K.Context -> (Type -> Type) -> Constraint class GConstructableADT _Table _Columns f context rep where   gbuildADT :: ()     => ToColumns _Table _Columns f context     -> (Tag -> Nullifier context)-    -> HType Tag context+    -> HIdentity Tag context     -> GFieldsADT f rep     -> GColumnsADT _Columns rep context @@ -202,13 +193,13 @@     => FromColumns _Table _Columns f context     -> Unnullifier context     -> GColumnsADT _Columns rep context-    -> (HType Tag context, GFieldsADT f rep)+    -> (HIdentity Tag context, GFieldsADT f rep)    gconstructADT :: ()     => ToColumns _Table _Columns f context     -> Null context     -> Nullifier context-    -> (Tag -> HType Tag context)+    -> (Tag -> HIdentity Tag context)     -> GConstructors f rep (GColumnsADT _Columns rep context)    gdeconstructADT :: ()@@ -216,30 +207,29 @@     -> Unnullifier context     -> GConstructors f rep r     -> GColumnsADT _Columns rep context-    -> (HType Tag context, NonEmpty (Tag, r))+    -> (HIdentity Tag context, NonEmpty (Tag, r))   instance-  ( htable ~ HLabel "tag" (HType Tag)+  ( htable ~ HLabel "tag" (HIdentity Tag)   , GConstructableADT' _Table _Columns f context htable rep-  , HLabelable context   )   => GConstructableADT _Table _Columns f context (M1 D meta rep)  where   gbuildADT toColumns nullifier =     gbuildADT' @_Table @_Columns @f @context @htable @rep toColumns nullifier .-    hlabel hlabeler+    hlabel    gunbuildADT fromColumns unnullifier =-    first (hunlabel hunlabeler) .+    first hunlabel .     gunbuildADT' @_Table @_Columns @f @context @htable @rep fromColumns unnullifier    gconstructADT toColumns null nullifier mk =     gconstructADT' @_Table @_Columns @f @context @htable @rep toColumns null nullifier-      (hlabel hlabeler . mk)+      (hlabel . mk)    gdeconstructADT fromColumns unnullifier cases =-    first (hunlabel hunlabeler) .+    first hunlabel .     gdeconstructADT' @_Table @_Columns @f @context @htable @rep fromColumns unnullifier cases  @@ -247,7 +237,7 @@   :: (Type -> Exp Constraint)   -> (Type -> Exp K.HTable)   -> (Type -> Exp Type)-  -> K.HContext -> K.HTable -> (Type -> Type) -> Constraint+  -> K.Context -> K.HTable -> (Type -> Type) -> Constraint class GConstructableADT' _Table _Columns f context htable rep where   gbuildADT' :: ()     => ToColumns _Table _Columns f context@@ -334,7 +324,6 @@   ( HTable (GColumns _Columns rep)   , KnownSymbol label   , meta ~ 'MetaCons label _fixity _isRecord-  , HLabelable context   , GConstructable _Table _Columns f context rep   , GColumnsADT' _Columns htable (M1 C meta rep) ~       HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))@@ -343,7 +332,7 @@  where   gbuildADT' toColumns nullifier htable =     HProduct htable .-    hlabel hlabeler .+    hlabel .     hnullify (nullifier tag) .     gconstruct @_Table @_Columns @f @context @rep toColumns     where@@ -354,13 +343,13 @@     , gdeconstruct @_Table @_Columns @f @context @rep fromColumns $         runIdentity $         hunnullify (\spec -> pure . unnullifier spec) $-        hunlabel hunlabeler+        hunlabel         a     )    gconstructADT' toColumns _ nullifier mk =     HProduct htable .-    hlabel hlabeler .+    hlabel .     hnullify nullifier .     gconstruct @_Table @_Columns @f @context @rep toColumns     where@@ -375,35 +364,34 @@       a = gdeconstruct @_Table @_Columns @f @context @rep fromColumns $         runIdentity $         hunnullify (\spec -> pure . unnullifier spec) $-        hunlabel hunlabeler+        hunlabel         columns       tag = Tag $ pack $ symbolVal (Proxy @label) -  gfill null htable = HProduct htable (hlabel hlabeler (hnulls null))+  gfill null htable = HProduct htable (hlabel (hnulls null))   type GMakeableADT   :: (Type -> Exp Constraint)   -> (Type -> Exp K.HTable)   -> (Type -> Exp Type)-  -> K.HContext -> Symbol -> (Type -> Type) -> Constraint+  -> K.Context -> Symbol -> (Type -> Type) -> Constraint class GMakeableADT _Table _Columns f context name rep where   gmakeADT :: ()     => ToColumns _Table _Columns f context     -> Null context     -> Nullifier context-    -> (Tag -> HType Tag context)+    -> (Tag -> HIdentity Tag context)     -> GFields f (GConstructorADT name rep)     -> GColumnsADT _Columns rep context   instance-  ( htable ~ HLabel "tag" (HType Tag)+  ( htable ~ HLabel "tag" (HIdentity Tag)   , meta ~ 'MetaData datatype _module _package _newtype   , fallback ~ TypeError (NoConstructor datatype name)   , fields ~ GFields f (GConstructorADT' name rep fallback)   , GMakeableADT' _Table _Columns f context htable name rep fields-  , HLabelable context   , KnownSymbol name   )   => GMakeableADT _Table _Columns f context name (M1 D meta rep)@@ -414,14 +402,14 @@       toColumns null nullifier htable     where       tag = Tag $ pack $ symbolVal (Proxy @name)-      htable = hlabel hlabeler (wrap tag)+      htable = hlabel (wrap tag)   type GMakeableADT'   :: (Type -> Exp Constraint)   -> (Type -> Exp K.HTable)   -> (Type -> Exp Type)-  -> K.HContext -> K.HTable -> Symbol -> (Type -> Type) -> Type -> Constraint+  -> K.Context -> K.HTable -> Symbol -> (Type -> Type) -> Type -> Constraint class GMakeableADT' _Table _Columns f context htable name rep fields where   gmakeADT' :: ()     => ToColumns _Table _Columns f context@@ -462,8 +450,6 @@  instance {-# OVERLAPS #-}   ( HTable (GColumns _Columns rep)-  , KnownSymbol name-  , HLabelable context   , GConstructable _Table _Columns f context rep   , fields ~ GFields f rep   , GColumnsADT' _Columns htable (M1 C ('MetaCons name _fixity _isRecord) rep) ~@@ -473,15 +459,13 @@  where   gmakeADT' toColumns _ nullifier htable =     HProduct htable .-    hlabel hlabeler .+    hlabel .     hnullify nullifier .     gconstruct @_Table @_Columns @f @context @rep toColumns   instance {-# OVERLAPPABLE #-}   ( HTable (GColumns _Columns rep)-  , KnownSymbol label-  , HLabelable context   , GColumnsADT' _Columns htable (M1 C ('MetaCons label _fixity _isRecord) rep) ~       HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))   )@@ -489,5 +473,5 @@  where   gmakeADT' _ null _ htable _ =     HProduct htable $-    hlabel hlabeler $+    hlabel $     hnulls null

@@ -27,15 +27,13 @@   ) import GHC.TypeLits   ( ErrorMessage( (:<>:), Text ), TypeError-  , Symbol, KnownSymbol+  , Symbol   ) import Prelude  -- rel8 import Rel8.FCF ( Eval, Exp ) import Rel8.Generic.Table.Record ( GColumns )-import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler )-import Rel8.Schema.HTable ( HTable ) import Rel8.Schema.HTable.Label ( hlabel, hunlabel ) import Rel8.Schema.HTable.Product ( HProduct( HProduct ) ) import qualified Rel8.Schema.Kind as K@@ -45,7 +43,7 @@   :: (Type -> Exp Constraint)   -> (Type -> Exp K.HTable)   -> (Type -> Exp Type)-  -> K.HContext+  -> K.Context   -> Type type FromColumns _Table _Columns f context = forall proxy x.   Eval (_Table x) => proxy x -> Eval (_Columns x) context -> Eval (f x)@@ -55,7 +53,7 @@   :: (Type -> Exp Constraint)   -> (Type -> Exp K.HTable)   -> (Type -> Exp Type)-  -> K.HContext+  -> K.Context   -> Type type ToColumns _Table _Columns f context = forall proxy x.   Eval (_Table x) => proxy x -> Eval (f x) -> Eval (_Columns x) context@@ -119,7 +117,7 @@   :: (Type -> Exp Constraint)   -> (Type -> Exp K.HTable)   -> (Type -> Exp Type)-  -> K.HContext -> (Type -> Type) -> Constraint+  -> K.Context -> (Type -> Type) -> Constraint class GConstructable _Table _Columns f context rep where   gconstruct :: ()     => ToColumns _Table _Columns f context@@ -162,12 +160,9 @@  instance   ( Eval (_Table a)-  , HTable (Eval (_Columns a))-  , HLabelable context-  , KnownSymbol label   , meta ~ 'MetaSel ('Just label) _su _ss _ds   )   => GConstructable _Table _Columns f context (M1 S meta (K1 i a))  where-  gconstruct toColumns = hlabel hlabeler . toColumns (Proxy @a)-  gdeconstruct fromColumns = fromColumns (Proxy @a) . hunlabel hunlabeler+  gconstruct toColumns = hlabel . toColumns (Proxy @a)+  gdeconstruct fromColumns = fromColumns (Proxy @a) . hunlabel

@@ -1,26 +1,19 @@-{-# language AllowAmbiguousTypes #-} {-# language DataKinds #-}-{-# language EmptyCase #-}-{-# language FlexibleInstances #-}-{-# language LambdaCase #-}-{-# language MultiParamTypeClasses #-}-{-# language RankNTypes #-}-{-# language ScopedTypeVariables #-} {-# language StandaloneKindSignatures #-}-{-# language TypeApplications #-} {-# language TypeFamilies #-} {-# language TypeOperators #-} {-# language UndecidableInstances #-}  module Rel8.Generic.Map-  ( GMap, GMappable (gmap, gunmap)+  ( GMap+  , Map   ) where  -- base-import Data.Kind ( Constraint, Type )+import Data.Kind ( Type ) import GHC.Generics-  ( (:+:)( L1, R1 ), (:*:)( (:*:) ), K1( K1 ), M1( M1 ), U1( U1 ), V1+  ( (:+:), (:*:), K1, M1, U1, V1   ) import Prelude () @@ -38,56 +31,19 @@   GMap f (K1 i a) = K1 i (Eval (f a))  -type GMappable :: (Type -> Exp Constraint) -> (Type -> Type) -> Constraint-class GMappable constraint rep where-  gmap :: ()-    => proxy f-    -> (forall a. Eval (constraint a) => a -> Eval (f a))-    -> rep x-    -> GMap f rep x--  gunmap :: ()-    => proxy f-    -> (forall a. Eval (constraint a) => Eval (f a) -> a)-    -> GMap f rep x-    -> rep x---instance GMappable constraint rep => GMappable constraint (M1 i c rep) where-  gmap proxy f (M1 a) = M1 (gmap @constraint proxy f a)-  gunmap proxy f (M1 a) = M1 (gunmap @constraint proxy f a)---instance GMappable constraint V1 where-  gmap _ _ = \case-  gunmap _ _ = \case---instance (GMappable constraint rep1, GMappable constraint rep2) =>-  GMappable constraint (rep1 :+: rep2)- where-  gmap proxy f = \case-    L1 a -> L1 (gmap @constraint proxy f a)-    R1 a -> R1 (gmap @constraint proxy f a)-  gunmap proxy f = \case-    L1 a -> L1 (gunmap @constraint proxy f a)-    R1 a -> R1 (gunmap @constraint proxy f a)---instance GMappable constraint U1 where-  gmap _ _ U1 = U1-  gunmap _ _ U1 = U1---instance (GMappable constraint rep1, GMappable constraint rep2) =>-  GMappable constraint (rep1 :*: rep2)- where-  gmap proxy f (a :*: b) =-    gmap @constraint proxy f a :*: gmap @constraint proxy f b-  gunmap proxy f (a :*: b) =-    gunmap @constraint proxy f a :*: gunmap @constraint proxy f b---instance Eval (constraint a) => GMappable constraint (K1 i a) where-  gmap _ f (K1 a) = K1 (f a)-  gunmap _ f (K1 a) = K1 (f a)+-- | Map a @Type -> Type@ function over the @Type@-kinded type variables in+-- of a type constructor.+type Map :: (Type -> Exp Type) -> Type -> Type+type family Map f a where+  Map p (t a b c d e f g) =+    t (Eval (p a)) (Eval (p b)) (Eval (p c)) (Eval (p d)) (Eval (p e))+      (Eval (p f)) (Eval (p g))+  Map p (t a b c d e f) =+    t (Eval (p a)) (Eval (p b)) (Eval (p c)) (Eval (p d)) (Eval (p e))+      (Eval (p f))+  Map p (t a b c d e) =+    t (Eval (p a)) (Eval (p b)) (Eval (p c)) (Eval (p d)) (Eval (p e))+  Map p (t a b c d) = t (Eval (p a)) (Eval (p b)) (Eval (p c)) (Eval (p d))+  Map p (t a b c) = t (Eval (p a)) (Eval (p b)) (Eval (p c))+  Map p (t a b) = t (Eval (p a)) (Eval (p b))+  Map p (t a) = t (Eval (p a))

@@ -1,24 +0,0 @@-{-# language StandaloneKindSignatures #-}-{-# language TypeFamilies #-}--module Rel8.Generic.Reify-  ( ARep-  )-where---- base-import Data.Functor.Contravariant ( Contravariant, contramap )-import Data.Kind ( Type )-import Data.Void ( Void, absurd )-import GHC.Generics ( Generic, Rep, from, to )-import Prelude---type ARep :: (Type -> Type) -> Type-newtype ARep rep = ARep (rep Void)---instance (Contravariant rep, Functor rep) => Generic (ARep rep) where-  type Rep (ARep rep) = rep-  from (ARep a) = fmap absurd a-  to = ARep . contramap absurd

@@ -1,13 +1,18 @@ {-# language AllowAmbiguousTypes #-}+{-# language ConstraintKinds #-} {-# language DataKinds #-} {-# language DefaultSignatures #-} {-# language FlexibleContexts #-} {-# language FlexibleInstances #-}+{-# language LambdaCase #-} {-# language MultiParamTypeClasses #-}+{-# language PolyKinds #-}+{-# language QuantifiedConstraints #-} {-# language ScopedTypeVariables #-} {-# language StandaloneKindSignatures #-} {-# language TypeApplications #-}-{-# language TypeFamilies #-}+{-# language TypeFamilyDependencies #-}+{-# language TypeOperators #-} {-# language UndecidableInstances #-}  module Rel8.Generic.Rel8able@@ -15,36 +20,39 @@   , Algebra   , GRep   , GColumns, gfromColumns, gtoColumns-  , greify, gunreify-  , TUnreifyContext+  , GFromExprs, gfromResult, gtoResult+  , TSerialize, serialize, deserialize   ) where  -- base+import Data.Functor.Identity ( Identity ) import Data.Kind ( Constraint, Type )-import Data.Proxy ( Proxy( Proxy ) )-import Data.Type.Equality ( (:~:)( Refl ) )+import Data.Type.Bool ( type (&&) ) import GHC.Generics ( Generic, Rep, from, to ) import Prelude  -- rel8-import Rel8.Kind.Context ( Reifiable )-import Rel8.FCF ( Eval, Exp )-import Rel8.Generic.Map ( GMap, GMappable, gmap, gunmap )+import Rel8.Aggregate ( Aggregate )+import Rel8.Expr ( Expr )+import Rel8.FCF ( Exp, Eval ) import Rel8.Generic.Record ( Record(..) ) import Rel8.Generic.Table ( GAlgebra ) import qualified Rel8.Generic.Table.Record as G import qualified Rel8.Kind.Algebra as K ( Algebra(..) )-import Rel8.Schema.Context ( Col )-import Rel8.Schema.Context.Label ( Labelable )+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.Reify ( Reify, UnwrapReify )+import Rel8.Schema.Name ( Name ) import Rel8.Schema.Result ( Result ) import Rel8.Table-  ( fromColumns, toColumns, reify, unreify-  , TTable, TColumns, TContext, TUnreify+  ( Table, Columns, Context, fromColumns, toColumns+  , FromExprs, fromResult, toResult+  , Transpose+  , TTable, TColumns   )+import Rel8.Table.Transpose ( Transposes )   -- | The kind of 'Rel8able' types@@ -52,6 +60,54 @@ type KRel8able = K.Rel8able  +-- This is almost 'Data.Type.Equality.==', but we add an extra case.+type (==) :: k -> k -> Bool+type family a == b where+  -- This extra case is needed to solve the equation "a == Identity a", +  -- which occurs when we have polymorphic Rel8ables +  -- (e.g., newtype T a f = T { x :: Column f a })+  a == Identity a = 'False+  +  -- These cases are exactly the same as those in 'Data.Type.Equality.==.+  f a == g b = f == g && a == b+  a == a = 'True+  _ == _ = 'False+++type Serialize :: Bool -> Type -> Type -> Constraint+class transposition ~ (a == Transpose Result expr) =>+  Serialize transposition expr a+ where+  serialize :: a -> Columns expr Result+  deserialize :: Columns expr Result -> a+++instance+  ( (a == Transpose Result expr) ~ 'True+  , Transposes Expr Result expr a+  )+  => Serialize 'True expr a+ where+  serialize = toColumns+  deserialize = fromColumns+++instance+  ( (a == Transpose Result expr) ~ 'False+  , Table (Context expr) expr+  , FromExprs expr ~ a+  )+  => Serialize 'False expr a+ where+  serialize = toResult @_ @expr+  deserialize = fromResult @_ @expr+++data TSerialize :: Type -> Type -> Exp Constraint+type instance Eval (TSerialize expr a) =+  Serialize (a == Transpose Result expr) expr a++ -- | This type class allows you to define custom 'Table's using higher-kinded -- data types. Higher-kinded data types are data types of the pattern: --@@ -97,79 +153,124 @@ type Rel8able :: K.Rel8able -> Constraint class HTable (GColumns t) => Rel8able t where   type GColumns t :: K.HTable--  gfromColumns :: (Labelable context, Reifiable context)-    => GColumns t (Col (Reify context)) -> t (Reify context)--  gtoColumns :: (Labelable context, Reifiable context)-    => t (Reify context) -> GColumns t (Col (Reify context))+  type GFromExprs t :: Type -  greify :: (Labelable context, Reifiable context)-    => t context -> t (Reify context)+  gfromColumns :: SContext context -> GColumns t context -> t context+  gtoColumns :: SContext context -> t context -> GColumns t context -  gunreify :: (Labelable context, Reifiable context)-    => t (Reify context) -> t context+  gfromResult :: GColumns t Result -> GFromExprs t+  gtoResult :: GFromExprs t -> GColumns t Result -  type GColumns t = G.GColumns TColumns (GRep t (Reify Result))+  type GColumns t = G.GColumns TColumns (GRep t Expr)+  type GFromExprs t = t Result    default gfromColumns :: forall context.-    ( Generic (Record (t (Reify context)))-    , G.GTable (TTable (Reify context)) TColumns (Col (Reify context)) (GRep t (Reify context))-    , G.GColumns TColumns (GRep t (Reify context)) ~ GColumns t+    ( SRel8able t Aggregate+    , SRel8able t Expr+    , forall table. SRel8able t (Field table)+    , SRel8able t Name+    , SSerialize t     )-    => GColumns t (Col (Reify context)) -> t (Reify context)-  gfromColumns =-    unrecord .-    to .-    G.gfromColumns @(TTable (Reify context)) @TColumns fromColumns+    => SContext context -> GColumns t context -> t context+  gfromColumns = \case+    SAggregate -> sfromColumns+    SExpr -> sfromColumns+    SField -> sfromColumns+    SName -> sfromColumns+    SResult -> sfromResult    default gtoColumns :: forall context.-    ( Generic (Record (t (Reify context)))-    , G.GTable (TTable (Reify context)) TColumns (Col (Reify context)) (GRep t (Reify context))-    , G.GColumns TColumns (GRep t (Reify context)) ~ GColumns t+    ( SRel8able t Aggregate+    , SRel8able t Expr+    , forall table. SRel8able t (Field table)+    , SRel8able t Name+    , SSerialize t     )-    => t (Reify context) -> GColumns t (Col (Reify context))-  gtoColumns =-    G.gtoColumns @(TTable (Reify context)) @TColumns toColumns .-    from .-    Record+    => SContext context -> t context -> GColumns t context+  gtoColumns = \case+    SAggregate -> stoColumns+    SExpr -> stoColumns+    SField -> stoColumns+    SName -> stoColumns+    SResult -> stoResult -  default greify :: forall context.-    ( Generic (Record (t context))-    , Generic (Record (t (Reify context)))-    , GMappable (TTable (Reify context)) (GRep t (Reify context))-    , GRep t context ~ GMap TUnreify (GRep t (Reify context))-    )-    => t context -> t (Reify context)-  greify =-    unrecord .-    to .-    gunmap @(TTable (Reify context)) (Proxy @TUnreify) (reify Refl) .-    from .-    Record+  default gfromResult :: (SSerialize t, GFromExprs t ~ t Result)+    => GColumns t Result -> GFromExprs t+  gfromResult = sfromResult -  default gunreify :: forall context.-    ( Generic (Record (t context))-    , Generic (Record (t (Reify context)))-    , GMappable (TTable (Reify context)) (GRep t (Reify context))-    , GRep t context ~ GMap TUnreify (GRep t (Reify context))-    )-    => t (Reify context) -> t context-  gunreify =-    unrecord .-    to .-    gmap @(TTable (Reify context)) (Proxy @TUnreify) (unreify Refl) .-    from .-    Record+  default gtoResult :: (SSerialize t, GFromExprs t ~ t Result)+    => GFromExprs t -> GColumns t Result+  gtoResult = stoResult   type Algebra :: K.Rel8able -> K.Algebra-type Algebra t = GAlgebra (GRep t (Reify Result))+type Algebra t = GAlgebra (GRep t Expr)   type GRep :: K.Rel8able -> K.Context -> Type -> Type type GRep t context = Rep (Record (t context))  -data TUnreifyContext :: Type -> Exp K.Context-type instance Eval (TUnreifyContext a) = UnwrapReify (Eval (TContext a))+type SRel8able :: K.Rel8able -> K.Context -> Constraint+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+type SSerialize t =+  ( Generic (Record (t Result))+  , G.GSerialize TSerialize TColumns (GRep t Expr) (GRep t Result)+  , G.GColumns TColumns (GRep t Expr) ~ GColumns t+  )+++sfromColumns :: forall t context. SRel8able t context+  => GColumns t context -> t context+sfromColumns =+  unrecord .+  to .+  G.gfromColumns @(TTable context) @TColumns fromColumns+++stoColumns :: forall t context. SRel8able t context+  => t context -> GColumns t context+stoColumns =+  G.gtoColumns @(TTable context) @TColumns toColumns .+  from .+  Record+++sfromResult :: forall t. SSerialize t+  => GColumns t Result -> t Result+sfromResult =+  unrecord .+  to .+  G.gfromResult+    @TSerialize+    @TColumns+    @(GRep t Expr)+    @(GRep t Result)+    (\(_ :: proxy x) -> deserialize @_ @x)+++stoResult :: forall t. SSerialize t+  => t Result -> GColumns t Result+stoResult =+  G.gtoResult+    @TSerialize+    @TColumns+    @(GRep t Expr)+    @(GRep t Result)+    (\(_ :: proxy x) -> serialize @_ @x) .+  from .+  Record

@@ -1,157 +0,0 @@-{-# language DataKinds #-}-{-# language DeriveAnyClass #-}-{-# language DeriveGeneric #-}-{-# language DerivingVia #-}-{-# language DuplicateRecordFields #-}-{-# language FlexibleInstances #-}-{-# language MultiParamTypeClasses #-}-{-# language StandaloneDeriving #-}-{-# language TypeFamilies #-}-{-# language UndecidableInstances #-}--{-# options_ghc -O0 #-}--module Rel8.Generic.Rel8able.Test-  ( module Rel8.Generic.Rel8able.Test-  )-where---- base-import GHC.Generics ( Generic )-import Prelude---- rel8-import Rel8---- text-import Data.Text ( Text )---data TableTest f = TableTest-  { foo :: Column f Bool-  , bar :: Column f (Maybe Bool)-  }-  deriving stock Generic-  deriving anyclass Rel8able---data TablePair f = TablePair-  { foo :: Column f Bool-  , bars :: (Column f Text, Column f Text)-  }-  deriving stock Generic-  deriving anyclass Rel8able---data TableMaybe f = TableMaybe-  { foo :: Column f [Maybe Bool]-  , bars :: HMaybe f (TablePair f, TablePair f)-  }-  deriving stock Generic-  deriving anyclass Rel8able---data TableEither f = TableEither-  { foo :: Column f Bool-  , bars :: HEither f (HMaybe f (TablePair f, TablePair f)) (Column f Char)-  }-  deriving stock Generic-  deriving anyclass Rel8able---data TableThese f = TableThese-  { foo :: Column f Bool-  , bars :: HThese f (TableMaybe f) (TableEither f)-  }-  deriving stock Generic-  deriving anyclass Rel8able---data TableList f = TableList-  { foo :: Column f Bool-  , bars :: HList f (TableThese f)-  }-  deriving stock Generic-  deriving anyclass Rel8able---data TableNonEmpty f = TableNonEmpty-  { foo :: Column f Bool-  , bars :: HNonEmpty f (TableList f, TableMaybe f)-  }-  deriving stock Generic-  deriving anyclass Rel8able---data TableNest f = TableNest-  { foo :: Column f Bool-  , bars :: HList f (HMaybe f (TablePair f))-  }-  deriving stock Generic-  deriving anyclass Rel8able---data S3Object = S3Object-  { bucketName :: Text-  , objectKey :: Text-  }-  deriving stock Generic---deriving via HKDT S3Object-  instance Table Result S3Object---deriving via HKDT S3Object-  instance x ~ HKD S3Object Expr => ToExprs x S3Object---data HKDSum = HKDSumA Text | HKDSumB Bool Char | HKDSumC-  deriving stock Generic---deriving via HKDT HKDSum-  instance Table Result HKDSum---deriving via HKDT HKDSum-  instance x ~ HKD HKDSum Expr => ToExprs x HKDSum---data HKDTest f = HKDTest-  { s3Object :: Lift f S3Object-  , hkdSum :: Lift f HKDSum-  } -  deriving stock Generic-  deriving anyclass Rel8able---data NonRecord f = NonRecord-  (Column f Bool)-  (Column f Char)-  (Column f Char)-  (Column f Char)-  (Column f Char)-  (Column f Char)-  (Column f Char)-  (Column f Char)-  (Column f Char)-  (Column f Char)-  deriving stock Generic-  deriving anyclass Rel8able---data TableSum f-  = TableSumA (Column f Bool) (Column f Text)-  | TableSumB-  | TableSumC (Column f Text)-  deriving stock Generic---data TableProduct f = TableProduct-  { sum :: HADT f TableSum-  , list :: TableList f-  , foos :: HList f (HADT f TableSum, Lift f HKDSum, HKDTest f)-  }-  deriving stock Generic-  deriving anyclass Rel8able

@@ -12,8 +12,7 @@ {-# language UndecidableInstances #-}  module Rel8.Generic.Table-  ( GGTable, GGColumns, GGContext, ggfromColumns, ggtoColumns, ggtable-  , GGToExprs, ggfromResult, ggtoResult+  ( GGSerialize, GGColumns, ggfromResult, ggtoResult   , GAlgebra   ) where@@ -26,43 +25,19 @@ -- rel8 import Rel8.FCF ( Eval, Exp ) import Rel8.Generic.Table.ADT-  ( GTableADT, GColumnsADT, gfromColumnsADT, gtoColumnsADT, gtableADT-  , GToExprsADT, gtoResultADT, gfromResultADT-  )-import Rel8.Generic.Table.Record-  ( GTable, GColumns, GContext, gfromColumns, gtoColumns, gtable-  , GToExprs, gtoResult, gfromResult+  ( GSerializeADT, GColumnsADT, gtoResultADT, gfromResultADT   )+import Rel8.Generic.Table.Record ( GSerialize, GColumns, gtoResult, gfromResult ) import Rel8.Kind.Algebra   ( Algebra( Product, Sum )   , SAlgebra( SProduct, SSum )   , KnownAlgebra, algebraSing   )-import Rel8.Schema.Context ( Col ) import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Null ( Nullify )-import Rel8.Schema.Spec ( Spec( Spec ), SSpec ) import Rel8.Schema.Result ( Result )  -data GGTable-  :: Algebra-  -> (Type -> Exp Constraint)-  -> (Type -> Exp K.HTable)-  -> K.HContext-  -> (Type -> Type)-  -> Exp Constraint---type instance Eval (GGTable 'Product _Table _Columns context rep) =-  GTable _Table _Columns context rep---type instance Eval (GGTable 'Sum _Table _Columns context rep) =-  GTableADT _Table _Columns context rep---data GGToExprs+data GGSerialize   :: Algebra   -> (Type -> Type -> Exp Constraint)   -> (Type -> Exp K.HTable)@@ -71,12 +46,12 @@   -> Exp Constraint  -type instance Eval (GGToExprs 'Product _ToExprs _Columns exprs rep) =-  GToExprs _ToExprs _Columns exprs rep+type instance Eval (GGSerialize 'Product _Serialize _Columns exprs rep) =+  GSerialize _Serialize _Columns exprs rep  -type instance Eval (GGToExprs 'Sum _ToExprs _Columns exprs rep) =-  GToExprsADT _ToExprs _Columns exprs rep+type instance Eval (GGSerialize 'Sum _Serialize _Columns exprs rep) =+  GSerializeADT _Serialize _Columns exprs rep   data GGColumns@@ -92,19 +67,6 @@ type instance Eval (GGColumns 'Sum _Columns rep) = GColumnsADT _Columns rep  -data GGContext-  :: Algebra-  -> (Type -> Exp K.Context)-  -> (Type -> Type)-  -> Exp K.Context---type instance Eval (GGContext 'Product _Context rep) = GContext _Context rep---type instance Eval (GGContext 'Sum _Context _rep) = Result-- type GAlgebra :: (Type -> Type) -> Algebra type family GAlgebra rep where   GAlgebra (M1 _ _ rep) = GAlgebra rep@@ -115,74 +77,27 @@   GAlgebra (K1 _ _) = 'Product  -ggfromColumns :: forall algebra _Table _Columns rep context x.-  ( KnownAlgebra algebra-  , Eval (GGTable algebra _Table _Columns context rep)-  )-  => (forall spec. algebra ~ 'Sum => context spec -> Col Result spec)-  -> (forall spec. algebra ~ 'Sum => Col Result spec -> context spec)-  -> (forall a. Eval (_Table a) => Eval (_Columns a) context -> a)-  -> Eval (GGColumns algebra _Columns rep) context-  -> rep x-ggfromColumns = case algebraSing @algebra of-  SProduct -> \_ _ -> gfromColumns @_Table @_Columns-  SSum -> gfromColumnsADT @_Table @_Columns---ggtoColumns :: forall algebra _Table _Columns rep context x.-  ( KnownAlgebra algebra-  , Eval (GGTable algebra _Table _Columns context rep)-  )-  => (forall spec. algebra ~ 'Sum => context spec -> Col Result spec)-  -> (forall spec. algebra ~ 'Sum => Col Result spec -> context spec)-  -> (forall a. Eval (_Table a) => a -> Eval (_Columns a) context)-  -> rep x-  -> Eval (GGColumns algebra _Columns rep) context-ggtoColumns = case algebraSing @algebra of-  SProduct -> \_ _ -> gtoColumns @_Table @_Columns-  SSum -> gtoColumnsADT @_Table @_Columns---ggtable :: forall algebra _Table _Columns rep context.-  ( KnownAlgebra algebra-  , Eval (GGTable algebra _Table _Columns context rep)-  )-  => (forall a proxy. Eval (_Table a) => proxy a -> Eval (_Columns a) context)-  -> (forall a labels. ()-      => SSpec ('Spec labels a)-      -> context ('Spec labels a)-      -> context ('Spec labels (Nullify a)))-  -> Eval (GGColumns algebra _Columns rep) context-ggtable = case algebraSing @algebra of-  SProduct -> \table _ -> gtable @_Table @_Columns @_ @rep table-  SSum -> gtableADT @_Table @_Columns @_ @rep---ggfromResult :: forall algebra _ToExprs _Columns exprs rep x.+ggfromResult :: forall algebra _Serialize _Columns exprs rep x.   ( KnownAlgebra algebra-  , Eval (GGToExprs algebra _ToExprs _Columns exprs rep)+  , Eval (GGSerialize algebra _Serialize _Columns exprs rep)   )-  => (forall expr a proxy. Eval (_ToExprs expr a)-      => proxy expr-      -> Eval (_Columns expr) (Col Result)-      -> a)-  -> Eval (GGColumns algebra _Columns exprs) (Col Result)+  => (forall expr a proxy. Eval (_Serialize expr a)+      => proxy expr -> Eval (_Columns expr) Result -> a)+  -> Eval (GGColumns algebra _Columns exprs) Result   -> rep x-ggfromResult = case algebraSing @algebra of-  SProduct -> gfromResult @_ToExprs @_Columns @exprs-  SSum -> gfromResultADT @_ToExprs @_Columns @exprs+ggfromResult f x = case algebraSing @algebra of+  SProduct -> gfromResult @_Serialize @_Columns @exprs @rep f x+  SSum -> gfromResultADT @_Serialize @_Columns @exprs @rep f x  -ggtoResult :: forall algebra _ToExprs _Columns exprs rep x.+ggtoResult :: forall algebra _Serialize _Columns exprs rep x.   ( KnownAlgebra algebra-  , Eval (GGToExprs algebra _ToExprs _Columns exprs rep)+  , Eval (GGSerialize algebra _Serialize _Columns exprs rep)   )-  => (forall expr a proxy. Eval (_ToExprs expr a)-      => proxy expr-      -> a-      -> Eval (_Columns expr) (Col Result))+  => (forall expr a proxy. Eval (_Serialize expr a)+      => proxy expr -> a -> Eval (_Columns expr) Result)   -> rep x-  -> Eval (GGColumns algebra _Columns exprs) (Col Result)-ggtoResult = case algebraSing @algebra of-  SProduct -> gtoResult @_ToExprs @_Columns @exprs-  SSum -> gtoResultADT @_ToExprs @_Columns @exprs+  -> Eval (GGColumns algebra _Columns exprs) Result+ggtoResult f x = case algebraSing @algebra of+  SProduct -> gtoResult @_Serialize @_Columns @exprs @rep f x+  SSum -> gtoResultADT @_Serialize @_Columns @exprs @rep f x

@@ -1,10 +1,8 @@ {-# language AllowAmbiguousTypes #-} {-# language DataKinds #-}-{-# language FlexibleContexts #-} {-# language FlexibleInstances #-} {-# language LambdaCase #-} {-# language MultiParamTypeClasses #-}-{-# language PolyKinds #-} {-# language RankNTypes #-} {-# language ScopedTypeVariables #-} {-# language StandaloneKindSignatures #-}@@ -14,13 +12,13 @@ {-# language UndecidableInstances #-}  module Rel8.Generic.Table.ADT-  ( GTableADT, GColumnsADT, gfromColumnsADT, gtoColumnsADT, gtableADT-  , GTableADT', GColumnsADT'-  , GToExprsADT, gfromResultADT, gtoResultADT+  ( GSerializeADT, GColumnsADT, gfromResultADT, gtoResultADT+  , GSerializeADT', GColumnsADT'   ) where  -- base+import Data.Functor.Identity ( Identity( Identity ) ) import Data.Kind ( Constraint, Type ) import Data.Proxy ( Proxy( Proxy ) ) import GHC.Generics@@ -33,23 +31,14 @@  -- rel8 import Rel8.FCF ( Eval, Exp )-import Rel8.Generic.Table.Record-  ( GTable, GColumns, gtable-  , GToExprs, gfromResult, gtoResult-  )-import Rel8.Schema.Context.Label ( HLabelable, hlabeler, labeler, unlabeler )-import Rel8.Schema.HTable ( HTable, hmap )-import Rel8.Schema.HTable.Identity ( HIdentity( HType ), HType )+import Rel8.Generic.Table.Record ( GSerialize, GColumns, gfromResult, gtoResult )+import Rel8.Schema.HTable ( HTable )+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) ) import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel ) import Rel8.Schema.HTable.Nullify ( HNullify, hnulls, hnullify, hunnullify ) import Rel8.Schema.HTable.Product ( HProduct( HProduct ) ) import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Null ( Nullify )-import Rel8.Schema.Spec ( Spec( Spec ), SSpec )-import Rel8.Schema.Result-  ( Col( R ), Result-  , null, nullifier, unnullifier-  )+import Rel8.Schema.Result ( Result, null, nullifier, unnullifier ) import Rel8.Type.Tag ( Tag( Tag ) )  -- text@@ -61,7 +50,7 @@   -> (Type -> Type) -> K.HTable type family GColumnsADT _Columns rep where   GColumnsADT _Columns (M1 D _ rep) =-    GColumnsADT' _Columns (HLabel "tag" (HType Tag)) rep+    GColumnsADT' _Columns (HLabel "tag" (HIdentity Tag)) rep   type GColumnsADT'@@ -75,246 +64,118 @@     HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))  -type GTableADT-  :: (Type -> Exp Constraint)-  -> (Type -> Exp K.HTable)-  -> K.HContext -> (Type -> Type) -> Constraint-class GTableADT _Table _Columns context rep where-  gfromColumnsADT :: ()-    => (forall spec. context spec -> Col Result spec)-    -> (forall spec. Col Result spec -> context spec)-    -> (forall a. Eval (_Table a) => Eval (_Columns a) context -> a)-    -> GColumnsADT _Columns rep context-    -> rep x--  gtoColumnsADT :: ()-    => (forall spec. context spec -> Col Result spec)-    -> (forall spec. Col Result spec -> context spec)-    -> (forall a. Eval (_Table a) => a -> Eval (_Columns a) context)-    -> rep x-    -> GColumnsADT _Columns rep context--  gtableADT :: ()-    => (forall a proxy. Eval (_Table a) => proxy a -> Eval (_Columns a) context)-    -> (forall a labels. ()-        => SSpec ('Spec labels a)-        -> context ('Spec labels a)-        -> context ('Spec labels (Nullify a)))-    -> GColumnsADT _Columns rep context---instance-  ( htable ~ HLabel "tag" (HType Tag)-  , HTable (GColumnsADT _Columns (M1 D meta rep))-  , Eval (_Table (htable context))-  , Eval (_Columns (htable context)) ~ htable-  , GTableADT' _Table _Columns htable context rep-  , GToExprsADT' (Const _Table) _Columns htable rep rep-  )-  => GTableADT _Table _Columns context (M1 D meta rep)- where-  gfromColumnsADT fromContext toContext fromColumns =-    gfromResultADT @(Const _Table) @_Columns @(M1 D meta rep) @(M1 D meta rep)-      (const (fromColumns . hmap toContext)) .-    hmap fromContext--  gtoColumnsADT fromContext toContext toColumns =-    hmap toContext .-    gtoResultADT @(Const _Table) @_Columns @(M1 D meta rep) @(M1 D meta rep)-      (const (hmap fromContext . toColumns))--  gtableADT table hnullifier =-    gtableADT' @_Table @_Columns @htable @context @rep table hnullifier htable-    where-      htable = table (Proxy @(htable context))---type GTableADT'-  :: (Type -> Exp Constraint)-  -> (Type -> Exp K.HTable)-  -> K.HTable -> K.HContext -> (Type -> Type) -> Constraint-class GTableADT' _Table _Columns htable context rep where-  gtableADT' :: ()-    => (forall a proxy. Eval (_Table a) => proxy a -> Eval (_Columns a) context)-    -> (forall a labels. ()-        => SSpec ('Spec labels a)-        -> context ('Spec labels a)-        -> context ('Spec labels (Nullify a)))-    -> htable context-    -> GColumnsADT' _Columns htable rep context---instance-  ( htable' ~ GColumnsADT' _Columns htable a-  , GTableADT' _Table _Columns htable context a-  , GTableADT' _Table _Columns htable' context b-  )-  => GTableADT' _Table _Columns htable context (a :+: b)- where-  gtableADT' table hnullifier =-    gtableADT' @_Table @_Columns @_ @_ @b table hnullifier .-    gtableADT' @_Table @_Columns @_ @_ @a table hnullifier---instance meta ~ 'MetaCons label _fixity _isRecord =>-  GTableADT' _Table _Columns htable context (M1 C meta U1)- where-  gtableADT' _ _ = id---instance {-# OVERLAPPABLE #-}-  ( HTable (GColumns _Columns rep)-  , GTable _Table _Columns context rep-  , HLabelable context-  , meta ~ 'MetaCons label _fixity _isRecord-  , KnownSymbol label-  , GColumnsADT' _Columns htable (M1 C ('MetaCons label _fixity _isRecord) rep) ~-      HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))-  )-  => GTableADT' _Table _Columns htable context (M1 C meta rep)- where-  gtableADT' table hnullifier htable =-    HProduct htable $-      hlabel hlabeler $-      hnullify hnullifier $-      gtable @_Table @_Columns @_ @rep table---type GToExprsADT+type GSerializeADT   :: (Type -> Type -> Exp Constraint)   -> (Type -> Exp K.HTable)   -> (Type -> Type) -> (Type -> Type) -> Constraint-class GToExprsADT _ToExprs _Columns exprs rep where+class GSerializeADT _Serialize _Columns exprs rep where   gfromResultADT :: ()-    => (forall expr a proxy.-        ( Eval (_ToExprs expr a)-        , HTable (Eval (_Columns expr))-        )-        => proxy expr-        -> Eval (_Columns expr) (Col Result)-        -> a)-    -> GColumnsADT _Columns exprs (Col Result)+    => (forall expr a proxy. Eval (_Serialize expr a)+        => proxy expr -> Eval (_Columns expr) Result -> a)+    -> GColumnsADT _Columns exprs Result     -> rep x    gtoResultADT :: ()-    => (forall expr a proxy.-        ( Eval (_ToExprs expr a)-        , HTable (Eval (_Columns expr))-        )-        => proxy expr-        -> a-        -> Eval (_Columns expr) (Col Result))+    => (forall expr a proxy. Eval (_Serialize expr a)+        => proxy expr -> a -> Eval (_Columns expr) Result)     -> rep x-    -> GColumnsADT _Columns exprs (Col Result)+    -> GColumnsADT _Columns exprs Result   instance-  ( htable ~ HLabel "tag" (HType Tag)-  , GToExprsADT' _ToExprs _Columns htable exprs rep+  ( htable ~ HLabel "tag" (HIdentity Tag)+  , GSerializeADT' _Serialize _Columns htable exprs rep   )-  => GToExprsADT _ToExprs _Columns (M1 D meta exprs) (M1 D meta rep)+  => GSerializeADT _Serialize _Columns (M1 D meta exprs) (M1 D meta rep)  where   gfromResultADT fromResult columns =-    case gfromResultADT' @_ToExprs @_Columns @_ @exprs fromResult tag columns of+    case gfromResultADT' @_Serialize @_Columns @htable @exprs @rep fromResult tag columns of       Just rep -> M1 rep       _ -> error "ADT.fromColumns: mismatch between tag and data"     where-      tag = (\(HType (R a)) -> a) . hunlabel @_ @"tag" unlabeler+      tag = (\(HIdentity (Identity a)) -> a) . hunlabel @"tag"    gtoResultADT toResult (M1 rep) =-    gtoResultADT' @_ToExprs @_Columns @_ @exprs toResult tag (Just rep)+    gtoResultADT' @_Serialize @_Columns @htable @exprs @rep toResult tag (Just rep)     where-      tag = hlabel @_ @"tag" labeler . HType . R+      tag = hlabel @"tag" . HIdentity . Identity  -type GToExprsADT'+type GSerializeADT'   :: (Type -> Type -> Exp Constraint)   -> (Type -> Exp K.HTable)   -> K.HTable -> (Type -> Type) -> (Type -> Type) -> Constraint-class GToExprsADT' _ToExprs _Columns htable exprs rep where-  gfromResultADT' :: ()-    => (forall expr a proxy.-        ( Eval (_ToExprs expr a)-        , HTable (Eval (_Columns expr))-        )-        => proxy expr-        -> Eval (_Columns expr) (Col Result)-        -> a)-    -> (htable (Col Result) -> Tag)-    -> GColumnsADT' _Columns htable exprs (Col Result)+class GSerializeADT' _Serialize _Columns htable exprs rep where+  gfromResultADT' :: context ~ Result+    => (forall expr a proxy. Eval (_Serialize expr a)+        => proxy expr -> Eval (_Columns expr) context -> a)+    -> (htable Result -> Tag)+    -> GColumnsADT' _Columns htable exprs context     -> Maybe (rep x) -  gtoResultADT' :: ()-    => (forall expr a proxy.-        ( Eval (_ToExprs expr a)-        , HTable (Eval (_Columns expr))-        )-        => proxy expr-        -> a-        -> Eval (_Columns expr) (Col Result))-    -> (Tag -> htable (Col Result))+  gtoResultADT' :: context ~ Result+    => (forall expr a proxy. Eval (_Serialize expr a)+        => proxy expr -> a -> Eval (_Columns expr) context)+    -> (Tag -> htable Result)     -> Maybe (rep x)-    -> GColumnsADT' _Columns htable exprs (Col Result)+    -> GColumnsADT' _Columns htable exprs context    extract :: GColumnsADT' _Columns htable exprs context -> htable context   instance-  ( htable' ~ GColumnsADT' _Columns htable a-  , GToExprsADT' _ToExprs _Columns htable a rep1-  , GToExprsADT' _ToExprs _Columns htable' b rep2+  ( htable' ~ GColumnsADT' _Columns htable exprs1+  , GSerializeADT' _Serialize _Columns htable exprs1 a+  , GSerializeADT' _Serialize _Columns htable' exprs2 b   )-  => GToExprsADT' _ToExprs _Columns htable (a :+: b) (rep1 :+: rep2)+  => GSerializeADT' _Serialize _Columns htable (exprs1 :+: exprs2) (a :+: b)  where   gfromResultADT' fromResult f columns =     case ma of       Just a -> Just (L1 a)       Nothing -> R1 <$>-        gfromResultADT' @_ToExprs @_Columns @_ @b @rep2+        gfromResultADT' @_Serialize @_Columns @_ @exprs2 @b           fromResult-          (f . extract @_ToExprs @_Columns @_ @a @rep1)+          (f . extract @_Serialize @_Columns @_ @exprs1 @a)           columns     where       ma =-        gfromResultADT' @_ToExprs @_Columns @_ @a @rep1+        gfromResultADT' @_Serialize @_Columns @_ @exprs1 @a           fromResult           f-          (extract @_ToExprs @_Columns @_ @b @rep2 columns)+          (extract @_Serialize @_Columns @_ @exprs2 @b columns)    gtoResultADT' toResult tag = \case     Just (L1 a) ->-      gtoResultADT' @_ToExprs @_Columns @_ @b @rep2+      gtoResultADT' @_Serialize @_Columns @_ @exprs2 @b         toResult-        (\_ -> gtoResultADT' @_ToExprs @_Columns @_ @a @rep1+        (\_ -> gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a           toResult           tag           (Just a))         Nothing     Just (R1 b) ->-      gtoResultADT' @_ToExprs @_Columns @_ @b @rep2+      gtoResultADT' @_Serialize @_Columns @_ @exprs2 @b         toResult         (\tag' ->-          gtoResultADT' @_ToExprs @_Columns @_ @a @rep1+          gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a             toResult             (\_ -> tag tag')             Nothing)         (Just b)     Nothing ->-      gtoResultADT' @_ToExprs @_Columns @_ @b @rep2+      gtoResultADT' @_Serialize @_Columns @_ @exprs2 @b         toResult-        (\_ -> gtoResultADT' @_ToExprs @_Columns @_ @a @rep1 toResult tag Nothing)+        (\_ -> gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a toResult tag Nothing)         Nothing    extract =-    extract @_ToExprs @_Columns @_ @a @rep1 .-    extract @_ToExprs @_Columns @_ @b @rep2+    extract @_Serialize @_Columns @_ @exprs1 @a .+    extract @_Serialize @_Columns @_ @exprs2 @b  -instance-  ( meta ~ 'MetaCons label _fixity _isRecord-  , KnownSymbol label-  )-  => GToExprsADT' _ToExprs _Columns htable (M1 C meta U1) (M1 C meta U1)+instance (meta ~ 'MetaCons label _fixity _isRecord, KnownSymbol label) =>+  GSerializeADT' _Serialize _Columns _htable (M1 C meta U1) (M1 C meta U1)  where   gfromResultADT' _ tag columns     | tag columns == tag' = Just (M1 U1)@@ -331,33 +192,29 @@  instance {-# OVERLAPPABLE #-}   ( HTable (GColumns _Columns exprs)-  , GToExprs _ToExprs _Columns exprs rep+  , GSerialize _Serialize _Columns exprs rep   , meta ~ 'MetaCons label _fixity _isRecord   , KnownSymbol label-  , GColumnsADT' _Columns htable (M1 C meta exprs) ~+  , GColumnsADT' _Columns htable (M1 C ('MetaCons label _fixity _isRecord) exprs) ~       HProduct htable (HLabel label (HNullify (GColumns _Columns exprs)))   )-  => GToExprsADT' _ToExprs _Columns htable (M1 C meta exprs) (M1 C meta rep)+  => GSerializeADT' _Serialize _Columns htable (M1 C meta exprs) (M1 C meta rep)  where   gfromResultADT' fromResult tag (HProduct a b)     | tag a == tag' =-        M1 . gfromResult @_ToExprs @_Columns @exprs fromResult <$>-          hunnullify unnullifier (hunlabel unlabeler b)+        M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult <$>+          hunnullify unnullifier (hunlabel b)     | otherwise = Nothing     where       tag' = Tag $ pack $ symbolVal (Proxy @label)    gtoResultADT' toResult tag = \case-    Nothing -> HProduct (tag tag') (hlabel labeler (hnulls (const null)))+    Nothing -> HProduct (tag tag') (hlabel (hnulls (const null)))     Just (M1 rep) -> HProduct (tag tag') $-      hlabel labeler $+      hlabel $       hnullify nullifier $-      gtoResult @_ToExprs @_Columns @exprs toResult rep+      gtoResult @_Serialize @_Columns @exprs @rep toResult rep     where       tag' = Tag $ pack $ symbolVal (Proxy @label)    extract (HProduct a _) = a---data Const :: (a -> Exp Constraint) -> a -> a -> Exp Constraint-type instance Eval (Const f x a) = (Eval (f a), x ~ a)

@@ -14,7 +14,7 @@  module Rel8.Generic.Table.Record   ( GTable, GColumns, GContext, gfromColumns, gtoColumns, gtable-  , GToExprs, gfromResult, gtoResult+  , GSerialize, gfromResult, gtoResult   ) where @@ -26,18 +26,13 @@   , C, D, S   , Meta( MetaSel )   )-import GHC.TypeLits ( KnownSymbol ) import Prelude hiding ( null )  -- rel8 import Rel8.FCF ( Eval, Exp )-import Rel8.Schema.Context ( Col )-import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler )-import Rel8.Schema.HTable ( HTable ) import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel ) import Rel8.Schema.HTable.Product ( HProduct(..) ) import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Result ( Result )   type GColumns :: (Type -> Exp K.HTable) -> (Type -> Type) -> K.HTable@@ -60,8 +55,8 @@ type GTable   :: (Type -> Exp Constraint)   -> (Type -> Exp K.HTable)-  -> K.HContext -> (Type -> Type) -> Constraint-class GTable _Table _Columns context rep+  -> (Type -> Type) -> Constraint+class GTable _Table _Columns rep  where   gfromColumns :: ()     => (forall a. Eval (_Table a) => Eval (_Columns a) context -> a)@@ -78,129 +73,109 @@     -> GColumns _Columns rep context  -instance GTable _Table _Columns context rep =>-  GTable _Table _Columns context (M1 D c rep)+type GSerialize+  :: (Type -> Type -> Exp Constraint)+  -> (Type -> Exp K.HTable)+  -> (Type -> Type) -> (Type -> Type) -> Constraint+class GSerialize _Serialize _Columns exprs rep  where-  gfromColumns fromColumns =-    M1 . gfromColumns @_Table @_Columns @context @rep fromColumns-  gtoColumns toColumns (M1 a) =-    gtoColumns @_Table @_Columns @context @rep toColumns a-  gtable = gtable @_Table @_Columns @context @rep+  gfromResult :: ()+    => (forall expr a proxy. Eval (_Serialize expr a)+        => proxy expr -> Eval (_Columns expr) context -> a)+    -> GColumns _Columns exprs context+    -> rep x +  gtoResult :: ()+    => (forall expr a proxy. Eval (_Serialize expr a)+        => proxy expr -> a -> Eval (_Columns expr) context)+    -> rep x+    -> GColumns _Columns exprs context -instance GTable _Table _Columns context rep =>-  GTable _Table _Columns context (M1 C c rep)++instance GTable _Table _Columns rep => GTable _Table _Columns (M1 D c rep)  where   gfromColumns fromColumns =-    M1 . gfromColumns @_Table @_Columns @context @rep fromColumns+    M1 . gfromColumns @_Table @_Columns @rep fromColumns   gtoColumns toColumns (M1 a) =-    gtoColumns @_Table @_Columns @context @rep toColumns a-  gtable = gtable @_Table @_Columns @context @rep+    gtoColumns @_Table @_Columns @rep toColumns a+  gtable = gtable @_Table @_Columns @rep  -instance-  ( GTable _Table _Columns context rep1-  , GTable _Table _Columns context rep2-  )-  => GTable _Table _Columns context (rep1 :*: rep2)+instance GSerialize _Serialize _Columns exprs rep =>+  GSerialize _Serialize _Columns (M1 D c exprs) (M1 D c rep)  where-  gfromColumns fromColumns (HProduct a b) =-    gfromColumns @_Table @_Columns @context @rep1 fromColumns a :*:-    gfromColumns @_Table @_Columns @context @rep2 fromColumns b-  gtoColumns toColumns (a :*: b) = HProduct-    (gtoColumns @_Table @_Columns @context @rep1 toColumns a)-    (gtoColumns @_Table @_Columns @context @rep2 toColumns b)-  gtable table = HProduct-    (gtable @_Table @_Columns @context @rep1 table)-    (gtable @_Table @_Columns @context @rep2 table)+  gfromResult fromResult =+    M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult+  gtoResult toResult (M1 a) =+    gtoResult @_Serialize @_Columns @exprs @rep toResult a  -instance-  ( HTable (Eval (_Columns a))-  , Eval (_Table a)-  , HLabelable context-  , KnownSymbol label-  , meta ~ 'MetaSel ('Just label) _su _ss _ds-  , k1 ~ K1 i a-  )-  => GTable _Table _Columns context (M1 S meta k1)+instance GTable _Table _Columns rep => GTable _Table _Columns (M1 C c rep)  where-  gfromColumns fromColumns = M1 . K1 . fromColumns . hunlabel hunlabeler-  gtoColumns toColumns (M1 (K1 a)) = hlabel hlabeler (toColumns a)-  gtable table = hlabel hlabeler (table (Proxy @a))---type GToExprs-  :: (Type -> Type -> Exp Constraint)-  -> (Type -> Exp K.HTable)-  -> (Type -> Type) -> (Type -> Type) -> Constraint-class GToExprs _ToExprs _Columns exprs rep where-  gfromResult :: ()-    => (forall expr a proxy.-        ( Eval (_ToExprs expr a)-        , HTable (Eval (_Columns expr))-        )-        => proxy expr-        -> Eval (_Columns expr) (Col Result)-        -> a)-    -> GColumns _Columns exprs (Col Result)-    -> rep x-  gtoResult :: ()-    => (forall expr a proxy.-        ( Eval (_ToExprs expr a)-        , HTable (Eval (_Columns expr))-        )-        => proxy expr-        -> a-        -> Eval (_Columns expr) (Col Result))-    -> rep x-    -> GColumns _Columns exprs (Col Result)+  gfromColumns fromColumns =+    M1 . gfromColumns @_Table @_Columns @rep fromColumns+  gtoColumns toColumns (M1 a) =+    gtoColumns @_Table @_Columns @rep toColumns a+  gtable = gtable @_Table @_Columns @rep  -instance GToExprs _ToExprs _Columns exprs rep =>-  GToExprs _ToExprs _Columns (M1 D c exprs) (M1 D c rep)+instance GSerialize _Serialize _Columns exprs rep =>+  GSerialize _Serialize _Columns (M1 C c exprs) (M1 C c rep)  where   gfromResult fromResult =-    M1 . gfromResult @_ToExprs @_Columns @exprs fromResult+    M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult   gtoResult toResult (M1 a) =-    gtoResult @_ToExprs @_Columns @exprs toResult a+    gtoResult @_Serialize @_Columns @exprs @rep toResult a  -instance GToExprs _ToExprs _Columns exprs rep =>-  GToExprs _ToExprs _Columns (M1 C c exprs) (M1 C c rep)+instance (GTable _Table _Columns rep1, GTable _Table _Columns rep2) =>+  GTable _Table _Columns (rep1 :*: rep2)  where-  gfromResult fromResult =-    M1 . gfromResult @_ToExprs @_Columns @exprs fromResult-  gtoResult toResult (M1 a) =-    gtoResult @_ToExprs @_Columns @exprs toResult a+  gfromColumns fromColumns (HProduct a b) =+    gfromColumns @_Table @_Columns @rep1 fromColumns a :*:+    gfromColumns @_Table @_Columns @rep2 fromColumns b+  gtoColumns toColumns (a :*: b) = HProduct+    (gtoColumns @_Table @_Columns @rep1 toColumns a)+    (gtoColumns @_Table @_Columns @rep2 toColumns b)+  gtable table = HProduct+    (gtable @_Table @_Columns @rep1 table)+    (gtable @_Table @_Columns @rep2 table)   instance-  ( GToExprs _ToExprs _Columns exprs1 rep1-  , GToExprs _ToExprs _Columns exprs2 rep2+  ( GSerialize _Serialize _Columns expr1 rep1+  , GSerialize _Serialize _Columns expr2 rep2   )-  => GToExprs _ToExprs _Columns (exprs1 :*: exprs2) (rep1 :*: rep2)+  => GSerialize _Serialize _Columns (expr1 :*: expr2) (rep1 :*: rep2)  where   gfromResult fromResult (HProduct a b) =-    gfromResult @_ToExprs @_Columns @exprs1 fromResult a :*:-    gfromResult @_ToExprs @_Columns @exprs2 fromResult b+    gfromResult @_Serialize @_Columns @expr1 @rep1 fromResult a :*:+    gfromResult @_Serialize @_Columns @expr2 @rep2 fromResult b   gtoResult toResult (a :*: b) =     HProduct-      (gtoResult @_ToExprs @_Columns @exprs1 toResult a)-      (gtoResult @_ToExprs @_Columns @exprs2 toResult b)+      (gtoResult @_Serialize @_Columns @expr1 @rep1 toResult a)+      (gtoResult @_Serialize @_Columns @expr2 @rep2 toResult b)   instance-  ( Eval (_ToExprs exprs a)-  , HTable (Eval (_Columns exprs))-  , KnownSymbol label+  ( Eval (_Table a)   , meta ~ 'MetaSel ('Just label) _su _ss _ds-  , k1 ~ K1 i exprs+  , k1 ~ K1 i a+  )+  => GTable _Table _Columns (M1 S meta k1)+ where+  gfromColumns fromColumns = M1 . K1 . fromColumns . hunlabel+  gtoColumns toColumns (M1 (K1 a)) = hlabel (toColumns a)+  gtable table = hlabel (table (Proxy @a))+++instance+  ( Eval (_Serialize expr a)+  , meta ~ 'MetaSel ('Just label) _su _ss _ds+  , k1 ~ K1 i expr   , k1' ~ K1 i a   )-  => GToExprs _ToExprs _Columns (M1 S meta k1) (M1 S meta k1')+  => GSerialize _Serialize _Columns (M1 S meta k1) (M1 S meta k1')  where-  gfromResult fromResult =-    M1 . K1 . fromResult (Proxy @exprs) . hunlabel hunlabeler-  gtoResult toResult (M1 (K1 a)) =-    hlabel hlabeler (toResult (Proxy @exprs) a)+  gfromResult fromResult = M1 . K1 . fromResult (Proxy @expr) . hunlabel+  gtoResult toResult (M1 (K1 a)) = hlabel (toResult (Proxy @expr) a)

@@ -1,13 +1,11 @@ {-# language DataKinds #-} {-# language GADTs #-}-{-# language LambdaCase #-} {-# language StandaloneKindSignatures #-}+{-# language TypeSynonymInstances #-}  module Rel8.Kind.Context   ( Reifiable( contextSing )   , SContext(..)-  , sReifiable-  , sLabelable   ) where @@ -18,12 +16,9 @@ -- rel8 import Rel8.Aggregate ( Aggregate ) import Rel8.Expr ( Expr )-import Rel8.Schema.Dict ( Dict( Dict ) )-import Rel8.Schema.Context ( Interpretation )-import Rel8.Schema.Context.Label ( Labelable )+import Rel8.Schema.Field ( Field ) import Rel8.Schema.Kind ( Context ) import Rel8.Schema.Name ( Name )-import Rel8.Schema.Reify ( Reify ) import Rel8.Schema.Result ( Result )  @@ -31,13 +26,13 @@ data SContext context where   SAggregate :: SContext Aggregate   SExpr :: SContext Expr+  SField :: SContext (Field table)   SName :: SContext Name   SResult :: SContext Result-  SReify :: SContext context -> SContext (Reify context)   type Reifiable :: Context -> Constraint-class Interpretation context => Reifiable context where+class Reifiable context where   contextSing :: SContext context  @@ -49,33 +44,13 @@   contextSing = SExpr  +instance Reifiable (Field table) where+  contextSing = SField++ instance Reifiable Result where   contextSing = SResult   instance Reifiable Name where   contextSing = SName---instance Reifiable context => Reifiable (Reify context) where-  contextSing = SReify contextSing---sReifiable :: SContext context -> Dict Reifiable context-sReifiable = \case-  SAggregate -> Dict-  SExpr -> Dict-  SName -> Dict-  SResult -> Dict-  SReify context -> case sReifiable context of-    Dict -> Dict---sLabelable :: SContext context -> Dict Labelable context-sLabelable = \case-  SAggregate -> Dict-  SExpr -> Dict-  SName -> Dict-  SResult -> Dict-  SReify context -> case sLabelable context of-    Dict -> Dict

@@ -1,57 +0,0 @@-{-# language DataKinds #-}-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language GADTs #-}-{-# language LambdaCase #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeOperators #-}--module Rel8.Kind.Labels-  ( Labels-  , SLabels( SNil, SCons )-  , KnownLabels( labelsSing )-  , renderLabels-  )-where---- base-import Data.Kind ( Constraint, Type )-import Data.List.NonEmpty ( NonEmpty, nonEmpty )-import Data.Maybe ( fromMaybe )-import Data.Proxy ( Proxy( Proxy ) )-import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )-import Prelude---type Labels :: Type-type Labels = [Symbol]---type SLabels :: Labels -> Type-data SLabels labels where-  SNil :: SLabels '[]-  SCons :: KnownSymbol label => Proxy label -> SLabels labels -> SLabels (label ': labels)---type KnownLabels :: Labels -> Constraint-class KnownLabels labels where-  labelsSing :: SLabels labels---instance KnownLabels '[] where-  labelsSing = SNil---instance (KnownSymbol label, KnownLabels labels) =>-  KnownLabels (label ': labels)- where-  labelsSing = SCons Proxy labelsSing---renderLabels :: SLabels labels -> NonEmpty String-renderLabels = fromMaybe (pure "anon") . nonEmpty . go-  where-    go :: SLabels labels -> [String]-    go = \case-      SNil -> []-      SCons label labels -> symbolVal label : go labels

@@ -26,7 +26,7 @@ -- instances. -- -- A common pattern is to use '<>' to combine multiple orderings in sequence,--- and '>$<' (from 'Contravariant') to select individual columns.+-- and 'Data.Functor.Contravariant.>$<' to select individual columns. type Order :: Type -> Type newtype Order a = Order (Opaleye.Order a)   deriving newtype (Contravariant, Divisible, Decidable, Semigroup, Monoid)

@@ -1,5 +1,3 @@-{-# language DerivingVia #-}-{-# language GeneralizedNewtypeDeriving #-} {-# language StandaloneKindSignatures #-}  module Rel8.Query@@ -8,35 +6,198 @@ where  -- base+import Control.Applicative ( liftA2 )+import Control.Monad ( liftM2 ) import Data.Kind ( Type )+import Data.Monoid ( Any( Any ) ) import Prelude  -- opaleye-import qualified Opaleye.Select as Opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye+import qualified Opaleye.Internal.PackMap as Opaleye+import qualified Opaleye.Internal.PrimQuery as Opaleye+import qualified Opaleye.Internal.QueryArr as Opaleye+import qualified Opaleye.Internal.Tag as Opaleye  -- rel8 import Rel8.Query.Set ( unionAll )+import Rel8.Query.Opaleye ( fromOpaleye ) import Rel8.Query.Values ( values )+import Rel8.Table ( fromColumns, toColumns ) import Rel8.Table.Alternative   ( AltTable, (<|>:)   , AlternativeTable, emptyTable   )+import Rel8.Table.Projection ( Projectable, apply, project )  -- semigroupoids-import Data.Functor.Apply ( Apply, WrappedApplicative(..) )+import Data.Functor.Apply ( Apply, (<.>) ) import Data.Functor.Bind ( Bind, (>>-) )   -- | The @Query@ monad allows you to compose a @SELECT@ query. This monad has -- semantics similar to the list (@[]@) monad. type Query :: Type -> Type-newtype Query a = Query (Opaleye.Select a)-  deriving newtype (Functor, Applicative, Monad)-  deriving Apply via (WrappedApplicative Opaleye.Select)+newtype Query a =+  Query (+    -- This is based on Opaleye's Select monad, but with two addtions. We+    -- maintain a stack of PrimExprs from parent previous subselects. In+    -- practice, these are always the results of dummy calls to random().+    --+    -- We also return a Bool that indicates to the parent subselect whether+    -- or not that stack of PrimExprs were used at any point. If they weren't,+    -- then the call to random() is never added to the query.+    --+    -- This is all needed to implement evaluate. Consider the following code:+    --+    -- do+    --   x <- values [lit 'a', lit 'b', lit 'c']+    --   y <- evaluate $ nextval "user_id_seq"+    --   pure (x, y)+    --+    -- If we just used Opaleye's Select monad directly, the SQL would come out+    -- like this:+    --+    -- SELECT+    --   a, b+    -- FROM+    --   (VALUES ('a'), ('b'), ('c')) Q1(a),+    --   LATERAL (SELECT nextval('user_id_seq')) Q2(b);+    --+    -- From the Haskell code, you would intuitively expect to get back the+    -- results of three different calls to nextval(), but from Postgres' point+    -- of view, because the Q2 subquery doesn't reference anything from the Q1+    -- query, it thinks it only needs to call nextval() once. This is actually+    -- exactly the same problem you get with the deprecated ListT IO monad from+    -- the transformers package — *> behaves differently to >>=, so+    -- using ApplicativeDo can change the results of a program. ApplicativeDo+    -- is exactly the optimisation Postgres does on a "LATERAL" query that+    -- doesn't make any references to previous subselects.+    --+    -- Rel8's solution is generate the following SQL instead:+    --+    -- SELECT+    --   a, b+    -- FROM+    --   (SELECT+    --      random() AS dummy,+    --      *+    --    FROM+    --      (VALUES ('a'), ('b'), ('c')) Q1(a)) Q1,+    --   LATERAL (SELECT+    --     CASE+    --       WHEN dummy IS NOT NULL+    --       THEN nextval('user_id_seq')+    --     END) Q2(b);+    --+    -- We use random() here as the dummy value (and not some constant) because+    -- Postgres will again optimize if it sees that a value is constant+    -- (and thus only call nextval() once), but because random() is marked as+    -- VOLATILE, this inhibits Postgres from doing that optimisation.+    --+    -- Why not just reference the a column from the previous query directly+    -- instead of adding a dummy value? Basically, even if we extract out all+    -- the bindings introduced in a PrimQuery, we can't always be sure which+    -- ones refer to constant values, so if we end up laterally referencing a+    -- constant value, then all of this would be for nothing.+    --+    -- Why not just add the call to the previous subselect directly, like so:+    --+    -- SELECT+    --   a, b+    -- FROM+    --   (SELECT+    --      nextval('user_id_seq') AS eval,+    --      *+    --    FROM+    --      (VALUES ('a'), ('b'), ('c')) Q1(a)) Q1,+    --   LATERAL (SELECT eval) Q2(b);+    --+    -- That would work in this case. But consider the following Rel8 code:+    --+    -- do+    --   x <- values [lit 'a', lit 'b', lit 'c']+    --   y <- values [lit 'd', lit 'e', lit 'f']+    --   z <- evaluate $ nextval "user_id_seq"+    --   pure (x, y, z)+    --+    -- How many calls to nextval should there be? Our Haskell intuition says+    -- nine. But that's not what you would get if you used the above+    -- technique. The problem is, which VALUES query should the nextval be+    -- added to? You can choose one or the other to get three calls to+    -- nextval, but you still need to make a superfluous LATERAL references to+    -- the other if you want nine calls. So for the above Rel8 code we generate+    -- the following SQL:+    --+    -- SELECT+    --   a, b, c+    -- FROM+    --   (SELECT+    --      random() AS dummy,+    --      *+    --    FROM+    --      (VALUES ('a'), ('b'), ('c')) Q1(a)) Q1,+    --   (SELECT+    --      random() AS dummy,+    --      *+    --    FROM+    --      (VALUES ('d'), ('e'), ('f')) Q2(b)) Q2,+    --   LATERAL (SELECT+    --     CASE+    --       WHEN Q1.dummy IS NOT NULL AND Q2.dummy IS NOT NULL+    --       THEN nextval('user_id_seq')+    --     END) Q3(c);+    --+    -- This gives nine calls to nextval() as we would expect.+    [Opaleye.PrimExpr] -> Opaleye.Select (Any, a)+  )  +instance Projectable Query where+  project f = fmap (fromColumns . apply f . toColumns)+++instance Functor Query where+  fmap f (Query a) = Query (fmap (fmap (fmap f)) a)+++instance Apply Query where+  (<.>) = (<*>)+++instance Applicative Query where+  pure = fromOpaleye . pure+  liftA2 = liftM2++ instance Bind Query where   (>>-) = (>>=)+++instance Monad Query where+  Query q >>= f = Query $ \dummies -> Opaleye.QueryArr $ \(_, tag) ->+    let+      Opaleye.QueryArr qa = q dummies+      ((m, a), query, tag') = qa ((), tag)+      Query q' = f a+      (dummies', query', tag'') =+        ( dummy : dummies+        , \lateral -> Opaleye.Rebind True bindings . query lateral+        , Opaleye.next tag'+        )+        where+          (dummy, bindings) = Opaleye.run $ name random+            where+              random = Opaleye.FunExpr "random" []+              name = Opaleye.extractAttr "dummy" tag'+      Opaleye.QueryArr qa' = Opaleye.lateral $ \_ -> q' dummies'+      ((m'@(Any needsDummies), b), query'', tag''') = qa' ((), tag'')+      query'''+        | needsDummies = \lateral -> query'' lateral . query' lateral+        | otherwise = \lateral -> query'' lateral . query lateral+      m'' = m <> m'+    in+      ((m'', b), query''', tag''')   -- | '<|>:' = 'unionAll'.

@@ -7,11 +7,13 @@  -- base import Data.Kind ( Type )+import Data.Monoid ( Any ) import Prelude ()  -- opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye import qualified Opaleye.Select as Opaleye   type Query :: Type -> Type-newtype Query a = Query (Opaleye.Select a)+newtype Query a = Query ([Opaleye.PrimExpr] -> Opaleye.Select (Any, a))

@@ -17,7 +17,7 @@ import Rel8.Query.Opaleye ( fromOpaleye ) import Rel8.Schema.Name ( Selects ) import Rel8.Schema.Table ( TableSchema )-import Rel8.Table ( fromColumns, toColumns )+import Rel8.Table.Cols ( fromCols, toCols ) import Rel8.Table.Opaleye ( table, unpackspec )  @@ -25,8 +25,8 @@ -- table@. each :: Selects names exprs => TableSchema names -> Query exprs each =-  fmap fromColumns .+  fmap fromCols .   fromOpaleye .   Opaleye.selectTableExplicit unpackspec .   table .-  fmap toColumns+  fmap toCols

@@ -10,7 +10,11 @@ -- base import Prelude +-- comonad+import Control.Comonad ( extract )+ -- rel8+import Rel8.Expr ( Expr ) import Rel8.Expr.Eq ( (==.) ) import Rel8.Query ( Query ) import Rel8.Query.Filter ( where_ )@@ -23,17 +27,17 @@   -- | Filter 'EitherTable's, keeping only 'leftTable's.-keepLeftTable :: EitherTable a b -> Query a+keepLeftTable :: EitherTable Expr a b -> Query a keepLeftTable e@(EitherTable _ a _) = do   where_ $ isLeftTable e-  pure a+  pure (extract a)   -- | Filter 'EitherTable's, keeping only 'rightTable's.-keepRightTable :: EitherTable a b -> Query b+keepRightTable :: EitherTable Expr a b -> Query b keepRightTable e@(EitherTable _ _ b) = do   where_ $ isRightTable e-  pure b+  pure (extract b)   -- | @bitraverseEitherTable f g x@ will pass all @leftTable@s through @f@ and@@ -55,8 +59,8 @@ bitraverseEitherTable :: ()   => (a -> Query c)   -> (b -> Query d)-  -> EitherTable a b-  -> Query (EitherTable c d)+  -> EitherTable Expr a b+  -> Query (EitherTable Expr c d) bitraverseEitherTable f g e@(EitherTable tag _ _) = do   mc@(MaybeTable _ c) <- optional (f =<< keepLeftTable e)   md@(MaybeTable _ d) <- optional (g =<< keepRightTable e)

@@ -1,20 +1,18 @@-{-# language DerivingStrategies #-} {-# language FlexibleContexts #-}-{-# language GeneralizedNewtypeDeriving #-}-{-# language NamedFieldPuns #-}-{-# language StandaloneKindSignatures #-}+{-# language TupleSections #-}  module Rel8.Query.Evaluate-  ( Evaluate-  , eval-  , evaluate+  ( evaluate+  , rebind   ) where  -- base-import Data.Kind ( Type )-import Data.Monoid ( Endo ( Endo ), appEndo )-import Prelude+import Control.Monad ( (>=>) )+import Data.Foldable ( foldl' )+import Data.List.NonEmpty ( NonEmpty( (:|) ), nonEmpty )+import Data.Monoid ( Any( Any ) )+import Prelude hiding ( undefined )  -- opaleye import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye@@ -26,57 +24,45 @@  -- rel8 import Rel8.Expr ( Expr )+import Rel8.Expr.Bool ( (&&.) )+import Rel8.Expr.Opaleye ( fromPrimExpr ) import Rel8.Query ( Query( Query ) ) import Rel8.Table ( Table )+import Rel8.Table.Bool ( case_ ) import Rel8.Table.Opaleye ( unpackspec )---- semigroupoids-import Data.Functor.Apply ( Apply )-import Data.Functor.Bind ( Bind, (>>-) )---- transformers-import Control.Monad.Trans.State.Strict ( State, get, put, runState )---type Evaluations :: Type-data Evaluations = Evaluations-  { tag :: !Opaleye.Tag-  , bindings :: !(Endo (Opaleye.Bindings Opaleye.PrimExpr))-  }+import Rel8.Table.Undefined  --- | Some PostgreSQL functions, such as 'Rel8.nextval', have side effects,--- breaking the referential transparency we would otherwise enjoy.------ To try to recover our ability to reason about such expressions, 'Evaluate'--- allows us to control the evaluation order of side-effects by sequencing--- them monadically.-type Evaluate :: Type -> Type-newtype Evaluate a = Evaluate (State Evaluations a)-  deriving newtype (Functor, Apply, Applicative, Monad)+-- | 'evaluate' takes expressions that could potentially have side effects and+-- \"runs\" them in the 'Query' monad. The returned expressions have no side+-- effects and can safely be reused.+evaluate :: Table Expr a => a -> Query a+evaluate = laterally >=> rebind  -instance Bind Evaluate where-  (>>-) = (>>=)+laterally :: Table Expr a => a -> Query a+laterally a = Query $ \bindings -> pure $ (Any True,) $+  case nonEmpty bindings of+    Nothing -> a+    Just bindings' -> case_ [(condition, a)] undefined+      where+        condition = foldl1' (&&.) (fmap go bindings')+          where+            go = fromPrimExpr . Opaleye.UnExpr Opaleye.OpIsNotNull  --- | 'eval' takes expressions that could potentially have side effects and--- \"runs\" them in the 'Evaluate' monad. The returned expressions have no--- side effetcs and can safely be reused.-eval :: Table Expr a => a -> Evaluate a-eval a = Evaluate $ do-  Evaluations {tag, bindings} <- get+-- | 'rebind' takes some expressions, and binds each of them to a new+-- variable in the SQL. The @a@ returned consists only of these+-- variables. It's essentially a @let@ binding for Postgres expressions.+rebind :: Table Expr a => a -> Query a+rebind a = Query $ \_ -> Opaleye.QueryArr $ \(_, tag) ->   let     tag' = Opaleye.next tag-    (a', bindings') = Opaleye.run $-      Opaleye.runUnpackspec unpackspec (Opaleye.extractAttr "eval" tag') a-  put Evaluations {tag = tag', bindings = bindings <> Endo (bindings' ++)}-  pure a'+    (a', bindings) = Opaleye.run $+      Opaleye.runUnpackspec unpackspec (Opaleye.extractAttr "eval" tag) a+  in+    ((mempty, a'), \_ -> Opaleye.Rebind True bindings, tag')  --- | 'evaluate' runs an 'Evaluate' inside the 'Query' monad.-evaluate :: Evaluate a -> Query a-evaluate (Evaluate m) = Query $ Opaleye.QueryArr $ \(_, query, tag) ->-  case runState m (Evaluations tag mempty) of-    (a, Evaluations {tag = tag', bindings}) ->-      (a, Opaleye.Rebind True (appEndo bindings mempty) query, tag')+foldl1' :: (a -> a -> a) -> NonEmpty a -> a+foldl1' f (a :| as) = foldl' f a as

@@ -2,8 +2,8 @@  module Rel8.Query.Exists   ( exists, inQuery-  , whereExists, with, withBy-  , whereNotExists, without, withoutBy+  , present, with, withBy+  , absent, without, withoutBy   ) where @@ -11,46 +11,44 @@ import Prelude hiding ( filter )  -- opaleye-import qualified Opaleye.Operators as Opaleye+import qualified Opaleye.Exists as Opaleye+import qualified Opaleye.Operators as Opaleye hiding ( exists )  -- rel8 import Rel8.Expr ( Expr )+import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr ) import Rel8.Query ( Query ) import Rel8.Query.Filter ( filter )-import Rel8.Query.Maybe ( optional ) import Rel8.Query.Opaleye ( mapOpaleye ) import Rel8.Table.Eq ( EqTable, (==:) )-import Rel8.Table.Maybe ( isJustTable )   -- | Checks if a query returns at least one row. exists :: Query a -> Query (Expr Bool)-exists = fmap isJustTable . optional . whereExists--- FIXME: change this when b7aacc07c6392654cae439fc3b997620c3aa7a87 makes it--- into a release of Opaleye+exists = fmap (fromPrimExpr . fromColumn) . mapOpaleye Opaleye.exists   inQuery :: EqTable a => a -> Query a -> Query (Expr Bool) inQuery a = exists . (>>= filter (a ==:))  --- | Produce the empty query if the given query returns no rows. @whereExists@+-- | Produce the empty query if the given query returns no rows. @present@ -- is equivalent to @WHERE EXISTS@ in SQL.-whereExists :: Query a -> Query ()-whereExists = mapOpaleye Opaleye.restrictExists+present :: Query a -> Query ()+present = mapOpaleye Opaleye.restrictExists  --- | Produce the empty query if the given query returns rows. @whereNotExists@+-- | Produce the empty query if the given query returns rows. @absent@ -- is equivalent to @WHERE NOT EXISTS@ in SQL.-whereNotExists :: Query a -> Query ()-whereNotExists = mapOpaleye Opaleye.restrictNotExists+absent :: Query a -> Query ()+absent = mapOpaleye Opaleye.restrictNotExists   -- | @with@ is similar to 'filter', but allows the predicate to be a full query. ----- @with f a = a <$ whereExists (f a)@, but this form matches 'filter'.+-- @with f a = a <$ present (f a)@, but this form matches 'filter'. with :: (a -> Query b) -> a -> Query a-with f a = a <$ whereExists (f a)+with f a = a <$ present (f a)   -- | Like @with@, but with a custom membership test.@@ -60,7 +58,7 @@  -- | Filter rows where @a -> Query b@ yields no rows. without :: (a -> Query b) -> a -> Query a-without f a = a <$ whereNotExists (f a)+without f a = a <$ absent (f a)   -- | Like @without@, but with a custom membership test.

@@ -0,0 +1,34 @@+module Rel8.Query.Indexed+  ( indexed+  )+where++-- base+import Data.Int ( Int64 )+import Prelude++-- opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye+import qualified Opaleye.Internal.PackMap as Opaleye+import qualified Opaleye.Internal.PrimQuery as Opaleye+import qualified Opaleye.Internal.QueryArr as Opaleye+import qualified Opaleye.Internal.Tag as Opaleye++-- rel8+import Rel8.Expr ( Expr )+import Rel8.Expr.Opaleye ( fromPrimExpr )+import Rel8.Query ( Query )+import Rel8.Query.Opaleye ( mapOpaleye )+++-- | Pair each row of a query with its index within the query.+indexed :: Query a -> Query (Expr Int64, a)+indexed = mapOpaleye $ \(Opaleye.QueryArr f) -> Opaleye.QueryArr $ \(_, tag) ->+  let+    (a, query, tag') = f ((), tag)+    tag'' = Opaleye.next tag'+    window = Opaleye.ConstExpr $ Opaleye.OtherLit "ROW_NUMBER() OVER () - 1"+    (index, bindings) = Opaleye.run $ Opaleye.extractAttr "index" tag' window+    query' lateral = Opaleye.Rebind True bindings . query lateral+  in+    ((fromPrimExpr index, a), query', tag'')

@@ -19,16 +19,18 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye  -- rel8-import Rel8.Expr ( Col( E, unE ), Expr )+import Rel8.Expr ( Expr ) import Rel8.Expr.Aggregate ( listAggExpr, nonEmptyAggExpr ) import Rel8.Expr.Opaleye ( mapPrimExpr ) import Rel8.Query ( Query ) import Rel8.Query.Aggregate ( aggregate )+import Rel8.Query.Evaluate ( rebind ) import Rel8.Query.Maybe ( optional ) import Rel8.Schema.HTable.Vectorize ( hunvectorize ) import Rel8.Schema.Null ( Sql, Unnullify )-import Rel8.Schema.Spec ( SSpec( SSpec, info ) )-import Rel8.Table ( Table, fromColumns, toColumns )+import Rel8.Schema.Spec ( Spec( Spec, info ) )+import Rel8.Table ( Table, fromColumns )+import Rel8.Table.Cols ( toCols ) import Rel8.Table.Aggregate ( listAgg, nonEmptyAgg ) import Rel8.Table.List ( ListTable( ListTable ) ) import Rel8.Table.Maybe ( maybeTable )@@ -45,12 +47,12 @@ -- -- @many@ is analogous to 'Control.Applicative.many' from -- @Control.Applicative@.-many :: Table Expr a => Query a -> Query (ListTable a)+many :: Table Expr a => Query a -> Query (ListTable Expr a) many =   fmap (maybeTable mempty (\(ListTable a) -> ListTable a)) .   optional .   aggregate .-  fmap (listAgg . toColumns)+  fmap (listAgg . toCols)   -- | Aggregate a 'Query' into a 'NonEmptyTable'. If the supplied query returns@@ -61,11 +63,11 @@ -- -- @some@ is analogous to 'Control.Applicative.some' from -- @Control.Applicative@.-some :: Table Expr a => Query a -> Query (NonEmptyTable a)+some :: Table Expr a => Query a -> Query (NonEmptyTable Expr a) some =   fmap (\(NonEmptyTable a) -> NonEmptyTable a) .   aggregate .-  fmap (nonEmptyAgg . toColumns)+  fmap (nonEmptyAgg . toCols)   -- | A version of 'many' specialised to single expressions.@@ -82,18 +84,18 @@ -- element of the given @ListTable@. -- -- @catListTable@ is an inverse to 'many'.-catListTable :: Table Expr a => ListTable a -> Query a-catListTable (ListTable as) = pure $ fromColumns $ runIdentity $-  hunvectorize (\SSpec {info} -> pure . E . sunnest info . unE) as+catListTable :: Table Expr a => ListTable Expr a -> Query a+catListTable (ListTable as) = rebind $ fromColumns $ runIdentity $+  hunvectorize (\Spec {info} -> pure . sunnest info) as   -- | Expand a 'NonEmptyTable' into a 'Query', where each row in the query is an -- element of the given @NonEmptyTable@. -- -- @catNonEmptyTable@ is an inverse to 'some'.-catNonEmptyTable :: Table Expr a => NonEmptyTable a -> Query a-catNonEmptyTable (NonEmptyTable as) = pure $ fromColumns $ runIdentity $-  hunvectorize (\SSpec {info} -> pure . E . sunnest info . unE) as+catNonEmptyTable :: Table Expr a => NonEmptyTable Expr a -> Query a+catNonEmptyTable (NonEmptyTable as) = rebind $ fromColumns $ runIdentity $+  hunvectorize (\Spec {info} -> pure . sunnest info) as   -- | Expand an expression that contains a list into a 'Query', where each row@@ -101,7 +103,7 @@ -- -- @catList@ is an inverse to 'manyExpr'. catList :: Sql DBType a => Expr [a] -> Query (Expr a)-catList = pure . sunnest typeInformation+catList = rebind . sunnest typeInformation   -- | Expand an expression that contains a non-empty list into a 'Query', where@@ -109,7 +111,7 @@ -- -- @catNonEmpty@ is an inverse to 'someExpr'. catNonEmpty :: Sql DBType a => Expr (NonEmpty a) -> Query (Expr a)-catNonEmpty = pure . sunnest typeInformation+catNonEmpty = rebind . sunnest typeInformation   sunnest :: TypeInformation (Unnullify a) -> Expr (list a) -> Expr a

@@ -1,3 +1,7 @@+{-# language GADTs #-}+{-# language LambdaCase #-}+{-# language NamedFieldPuns #-}+ module Rel8.Query.Maybe   ( optional   , catMaybeTable@@ -8,23 +12,20 @@ -- base import Prelude +-- comonad+import Control.Comonad ( extract )+ -- opaleye-import qualified Opaleye.Internal.PackMap as Opaleye-import qualified Opaleye.Internal.PrimQuery as Opaleye-import qualified Opaleye.Internal.QueryArr as Opaleye-import qualified Opaleye.Internal.Tag as Opaleye-import qualified Opaleye.Internal.Unpackspec as Opaleye+import qualified Opaleye.Internal.MaybeFields as Opaleye  -- rel8-import Rel8.Expr.Bool ( true )+import Rel8.Expr ( Expr ) import Rel8.Expr.Eq ( (==.) )-import Rel8.Expr.Opaleye ( toPrimExpr )+import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr ) import Rel8.Query ( Query ) import Rel8.Query.Filter ( where_ ) import Rel8.Query.Opaleye ( mapOpaleye )-import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )-import Rel8.Table.Opaleye ( unpackspec )-import Rel8.Table.Tag ( Tag(..), fromExpr )+import Rel8.Table.Maybe ( MaybeTable(..), isJustTable )   -- | Convert a query that might return zero rows to a query that always returns@@ -32,18 +33,11 @@ -- -- To speak in more concrete terms, 'optional' is most useful to write @LEFT -- JOIN@s.-optional :: Query a -> Query (MaybeTable a)-optional = mapOpaleye $ Opaleye.QueryArr . go-  where-    go query (i, left, tag) =-      (MaybeTable (fromExpr t') a, join, Opaleye.next tag')-      where-        (MaybeTable Tag {expr = t} a, right, tag') =-          Opaleye.runSimpleQueryArr (pure <$> query) (i, tag)-        (t', bindings) = Opaleye.run $-          Opaleye.runUnpackspec unpackspec (Opaleye.extractAttr "maybe" tag') t-        join = Opaleye.Join Opaleye.LeftJoin condition [] bindings left right-        condition = toPrimExpr true+optional :: Query a -> Query (MaybeTable Expr a)+optional = mapOpaleye $ Opaleye.optionalInternal $ \tag a -> MaybeTable+  { tag = fromPrimExpr $ fromColumn tag+  , just = pure a+  }   -- | Filter out 'MaybeTable's, returning only the tables that are not-null.@@ -51,23 +45,24 @@ -- This operation can be used to "undo" the effect of 'optional', which -- operationally is like turning a @LEFT JOIN@ back into a full @JOIN@.  You -- can think of this as analogous to 'Data.Maybe.catMaybes'.-catMaybeTable :: MaybeTable a -> Query a+catMaybeTable :: MaybeTable Expr a -> Query a catMaybeTable ma@(MaybeTable _ a) = do   where_ $ isJustTable ma-  pure a+  pure (extract a)   -- | Extend an optional query with another query.  This is useful if you want -- to step through multiple @LEFT JOINs@. -- -- Note that @traverseMaybeTable@ takes a @a -> Query b@ function, which means--- you also have the ability to "expand" one row into multiple rows.  If the +-- you also have the ability to "expand" one row into multiple rows.  If the -- @a -> Query b@ function returns no rows, then the resulting query will also -- have no rows. However, regardless of the given @a -> Query b@ function, if -- the input is @nothingTable@, you will always get exactly one @nothingTable@ -- back.-traverseMaybeTable :: (a -> Query b) -> MaybeTable a -> Query (MaybeTable b)+traverseMaybeTable :: (a -> Query b) -> MaybeTable Expr  a -> Query (MaybeTable Expr b) traverseMaybeTable query ma@(MaybeTable input _) = do-  MaybeTable output b <- optional (query =<< catMaybeTable ma)-  where_ $ expr output ==. expr input-  pure $ MaybeTable input b+  optional (query =<< catMaybeTable ma) >>= \case+    MaybeTable output b -> do+      where_ $ output ==. input+      pure $ MaybeTable input b

@@ -1,34 +1,70 @@+{-# language TupleSections #-}+ module Rel8.Query.Opaleye   ( fromOpaleye   , toOpaleye   , mapOpaleye   , zipOpaleyeWith+  , unsafePeekQuery   ) where  -- base+import Control.Applicative ( liftA2 ) import Prelude  -- opaleye-import qualified Opaleye.Select as Opaleye+import qualified Opaleye.Internal.QueryArr as Opaleye+import qualified Opaleye.Internal.Tag as Opaleye  -- rel8 import {-# SOURCE #-} Rel8.Query ( Query( Query ) )   fromOpaleye :: Opaleye.Select a -> Query a-fromOpaleye = Query+fromOpaleye = Query . pure . fmap pure   toOpaleye :: Query a -> Opaleye.Select a-toOpaleye (Query a) = a+toOpaleye (Query a) = snd <$> a mempty   mapOpaleye :: (Opaleye.Select a -> Opaleye.Select b) -> Query a -> Query b-mapOpaleye f = fromOpaleye . f . toOpaleye+mapOpaleye f (Query a) = Query (fmap (mapping f) a)   zipOpaleyeWith :: ()   => (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c)   -> Query a -> Query b -> Query c-zipOpaleyeWith f a b = fromOpaleye $ f (toOpaleye a) (toOpaleye b)+zipOpaleyeWith f (Query a) (Query b) = Query $ liftA2 (zipping f) a b+++unsafePeekQuery :: Query a -> a+unsafePeekQuery (Query q) = case q mempty of+  Opaleye.QueryArr f -> case f ((), Opaleye.start) of+    ((_, a), _, _) -> a+++mapping :: ()+  => (Opaleye.Select a -> Opaleye.Select b)+  -> Opaleye.Select (m, a) -> Opaleye.Select (m, b)+mapping f q@(Opaleye.QueryArr qa) = Opaleye.QueryArr $ \(_, tag) ->+  let+    ((m, _), _, _) = qa ((), tag)+    Opaleye.QueryArr qa' = (m,) <$> f (snd <$> q)+  in+    qa' ((), tag)+++zipping :: Semigroup m+  => (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c)+  -> Opaleye.Select (m, a) -> Opaleye.Select (m, b) -> Opaleye.Select (m, c)+zipping f q@(Opaleye.QueryArr qa) q'@(Opaleye.QueryArr qa') =+  Opaleye.QueryArr $ \(_, tag) ->+    let+      ((m, _), _, _) = qa ((), tag)+      ((m', _), _, _) = qa' ((), tag)+      m'' = m <> m'+      Opaleye.QueryArr qa'' = (m'',) <$> f (snd <$> q) (snd <$> q')+    in+      qa'' ((), tag)

@@ -1,74 +1,21 @@ {-# language FlexibleContexts #-}-{-# language TypeFamilies #-}-{-# language ViewPatterns #-}+{-# language MonoLocalBinds #-}  module Rel8.Query.SQL   ( showQuery-  , sqlForQuery, sqlForQueryWithNames   ) where  -- base-import Data.Foldable ( fold )-import Data.Functor.Const ( Const( Const ), getConst )-import Data.Void ( Void ) import Prelude --- opaleye-import qualified Opaleye.Internal.HaskellDB.Sql as Opaleye-import qualified Opaleye.Internal.PrimQuery as Opaleye-import qualified Opaleye.Internal.Print as Opaleye-import qualified Opaleye.Internal.Optimize as Opaleye-import qualified Opaleye.Internal.QueryArr as Opaleye hiding ( Select )-import qualified Opaleye.Internal.Sql as Opaleye- -- rel8-import Rel8.Expr ( Expr, Col( E ) )-import Rel8.Expr.Opaleye ( toPrimExpr )+import Rel8.Expr ( Expr ) import Rel8.Query ( Query )-import Rel8.Query.Opaleye ( toOpaleye )-import Rel8.Schema.Name ( Name( Name ), Selects, Col( N ) )-import Rel8.Schema.HTable ( htabulateA, hfield )-import Rel8.Table ( Table, toColumns )-import Rel8.Table.Name ( namesFromLabels )-import Rel8.Table.Opaleye ( castTable )+import Rel8.Statement.Select ( ppSelect )+import Rel8.Table ( Table )  --- | Convert a query to a 'String' containing the query as a @SELECT@--- statement.+-- | Convert a 'Query' to a 'String' containing a @SELECT@ statement. showQuery :: Table Expr a => Query a -> String-showQuery = fold . sqlForQuery---sqlForQuery :: Table Expr a-  => Query a -> Maybe String-sqlForQuery = sqlForQueryWithNames namesFromLabels . fmap toColumns---sqlForQueryWithNames :: Selects names exprs-  => names -> Query exprs -> Maybe String-sqlForQueryWithNames names query =-  show . Opaleye.ppSql . selectFrom names exprs <$> optimize primQuery-  where-    (exprs, primQuery, _) =-      Opaleye.runSimpleQueryArrStart (toOpaleye query) ()---optimize :: Opaleye.PrimQuery' a -> Maybe (Opaleye.PrimQuery' Void)-optimize = Opaleye.removeEmpty . Opaleye.optimize---selectFrom :: Selects names exprs-  => names -> exprs -> Opaleye.PrimQuery' Void -> Opaleye.Select-selectFrom (toColumns -> names) (toColumns . castTable -> exprs) query =-  Opaleye.SelectFrom $ Opaleye.newSelect-    { Opaleye.attrs = Opaleye.SelectAttrs attributes-    , Opaleye.tables = Opaleye.oneTable select-    }-  where-    select = Opaleye.foldPrimQuery Opaleye.sqlQueryGenerator query-    attributes = getConst $ htabulateA $ \field -> case hfield names field of-      N (Name name) -> case hfield exprs field of-        E (toPrimExpr -> expr) -> Const (pure (makeAttr name expr))-    makeAttr label expr =-      (Opaleye.sqlExpr expr, Just (Opaleye.SqlColumn label))+showQuery = show . ppSelect

@@ -1,4 +1,5 @@ {-# language FlexibleContexts #-}+{-# language GADTs #-}  module Rel8.Query.These   ( alignBy@@ -14,27 +15,29 @@ -- base import Prelude +-- comonad+import Control.Comonad ( extract )+ -- opaleye-import qualified Opaleye.Internal.Join as Opaleye+import qualified Opaleye.Internal.PackMap as Opaleye import qualified Opaleye.Internal.PrimQuery as Opaleye+import qualified Opaleye.Internal.QueryArr as Opaleye+import qualified Opaleye.Internal.Tag as Opaleye  -- rel8 import Rel8.Expr ( Expr ) import Rel8.Expr.Bool ( boolExpr, not_ ) import Rel8.Expr.Eq ( (==.) )-import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )+import Rel8.Expr.Opaleye ( toPrimExpr, traversePrimExpr ) import Rel8.Expr.Serialize ( litExpr ) import Rel8.Query ( Query ) import Rel8.Query.Filter ( where_ ) import Rel8.Query.Maybe ( optional ) import Rel8.Query.Opaleye ( zipOpaleyeWith )-import Rel8.Table ( Table ) import Rel8.Table.Either ( EitherTable( EitherTable ) ) import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )-import Rel8.Table.Opaleye ( unpackspec )-import Rel8.Table.Tag ( Tag(..) ) import Rel8.Table.These-  ( TheseTable( TheseTable )+  ( TheseTable( TheseTable, here, there )   , hasHereTable, hasThereTable   , isThisTable, isThatTable, isThoseTable   )@@ -42,81 +45,91 @@   -- | Corresponds to a @FULL OUTER JOIN@ between two queries.-alignBy :: (Table Expr a, Table Expr b)+alignBy :: ()   => (a -> b -> Expr Bool)-  -> Query a -> Query b -> Query (TheseTable a b)-alignBy condition as bs =-  uncurry TheseTable <$> zipOpaleyeWith fullOuterJoin as bs-  where-    fullOuterJoin a b =-      Opaleye.joinExplicit unpackspec unpackspec pure pure full a b on-      where-        full = Opaleye.FullJoin-        on = toColumn . toPrimExpr . uncurry condition+  -> Query a -> Query b -> Query (TheseTable Expr a b)+alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.QueryArr $ \i -> case i of+  (_, tag) -> (tab, join', tag''')+    where+      (ma, left', tag') = Opaleye.runSimpleQueryArr (pure <$> left) ((), tag)+      (mb, right', tag'') = Opaleye.runSimpleQueryArr (pure <$> right) ((), tag')+      MaybeTable hasHere a = ma+      MaybeTable hasThere b = mb+      (hasHere', lbindings) = Opaleye.run $ do+        traversePrimExpr (Opaleye.extractAttr "hasHere" tag'') hasHere+      (hasThere', rbindings) = Opaleye.run $ do+        traversePrimExpr (Opaleye.extractAttr "hasThere" tag'') hasThere+      tag''' = Opaleye.next tag''+      join lateral = Opaleye.Join Opaleye.FullJoin on left'' right''+        where+          on = toPrimExpr $ condition (extract a) (extract b)+          left'' = (lateral, Opaleye.Rebind True lbindings left')+          right'' = (lateral, Opaleye.Rebind True rbindings right')+      ma' = MaybeTable hasHere' a+      mb' = MaybeTable hasThere' b+      tab = TheseTable {here = ma', there = mb'}+      join' lateral input = Opaleye.times lateral input (join lateral)  --- | Filter 'TheseTable's, keeping only 'thisTable's and 'thoseTable's.-keepHereTable :: TheseTable a b -> Query (a, MaybeTable b)+keepHereTable :: TheseTable Expr a b -> Query (a, MaybeTable Expr b) keepHereTable = loseThatTable  --- | Filter 'TheseTable's, keeping on-loseHereTable :: TheseTable a b -> Query b+loseHereTable :: TheseTable Expr a b -> Query b loseHereTable = keepThatTable  -keepThereTable :: TheseTable a b -> Query (MaybeTable a, b)+keepThereTable :: TheseTable Expr a b -> Query (MaybeTable Expr a, b) keepThereTable = loseThisTable  -loseThereTable :: TheseTable a b -> Query a+loseThereTable :: TheseTable Expr a b -> Query a loseThereTable = keepThisTable  -keepThisTable :: TheseTable a b -> Query a+keepThisTable :: TheseTable Expr a b -> Query a keepThisTable t@(TheseTable (MaybeTable _ a) _) = do   where_ $ isThisTable t-  pure a+  pure (extract a)  -loseThisTable :: TheseTable a b -> Query (MaybeTable a, b)+loseThisTable :: TheseTable Expr a b -> Query (MaybeTable Expr a, b) loseThisTable t@(TheseTable ma (MaybeTable _ b)) = do   where_ $ not_ $ isThisTable t-  pure (ma, b)+  pure (ma, extract b)  -keepThatTable :: TheseTable a b -> Query b+keepThatTable :: TheseTable Expr a b -> Query b keepThatTable t@(TheseTable _ (MaybeTable _ b)) = do   where_ $ isThatTable t-  pure b+  pure (extract b)  -loseThatTable :: TheseTable a b -> Query (a, MaybeTable b)+loseThatTable :: TheseTable Expr a b -> Query (a, MaybeTable Expr b) loseThatTable t@(TheseTable (MaybeTable _ a) mb) = do   where_ $ not_ $ isThatTable t-  pure (a, mb)+  pure (extract a, mb)  -keepThoseTable :: TheseTable a b -> Query (a, b)+keepThoseTable :: TheseTable Expr a b -> Query (a, b) keepThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do   where_ $ isThoseTable t-  pure (a, b)+  pure (extract a, extract b)  -loseThoseTable :: TheseTable a b -> Query (EitherTable a b)+loseThoseTable :: TheseTable Expr a b -> Query (EitherTable Expr a b) loseThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do   where_ $ not_ $ isThoseTable t-  pure $ EitherTable result a b+  pure $ EitherTable tag a b   where     tag = boolExpr (litExpr IsLeft) (litExpr IsRight) (isThatTable t)-    result = (mempty `asTypeOf` result) {expr = tag}   bitraverseTheseTable :: ()   => (a -> Query c)   -> (b -> Query d)-  -> TheseTable a b-  -> Query (TheseTable c d)+  -> TheseTable Expr a b+  -> Query (TheseTable Expr c d) bitraverseTheseTable f g t = do   mc <- optional (f . fst =<< keepHereTable t)   md <- optional (g . snd =<< keepThereTable t)

@@ -1,20 +0,0 @@-{-# language DataKinds #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeFamilies #-}--module Rel8.Schema.Context-  ( Interpretation( Col )-  )-where---- base-import Data.Kind ( Constraint )-import Prelude ()---- rel8-import Rel8.Schema.Kind ( Context, HContext )---type Interpretation :: Context -> Constraint-class Interpretation context where-  data Col context :: HContext

@@ -1,62 +0,0 @@-{-# language DataKinds #-}-{-# language FlexibleInstances #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeFamilies #-}-{-# language TypeOperators #-}--module Rel8.Schema.Context.Label-  ( Labelable( labeler, unlabeler )-  , HLabelable( hlabeler, hunlabeler )-  )-where---- base-import Data.Kind ( Constraint )-import Prelude hiding ( null )---- rel8-import Rel8.Schema.Context ( Interpretation )-import Rel8.Schema.Dict ( Dict( Dict ) )-import Rel8.Schema.Kind ( Context, HContext )-import Rel8.Schema.Spec ( Spec( Spec ) )-import Rel8.Schema.Result ( Col( R ), Result )-import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )----- | The @Labelable@ class is an internal implementation detail of Rel8, and--- indicates that we can successfully "name" all columns in a type.-type Labelable :: Context -> Constraint-class Interpretation context => Labelable context where-  labeler :: ()-    => Col context ('Spec labels a)-    -> Col context ('Spec (label ': labels) a)--  unlabeler :: ()-    => Col context ('Spec (label ': labels) a)-    -> Col context ('Spec labels a)---instance Labelable Result where-  labeler (R a) = R a-  unlabeler (R a) = R a---type HLabelable :: HContext -> Constraint-class HLabelable context where-  hlabeler :: ()-    => context ('Spec labels a)-    -> context ('Spec (label ': labels) a)--  hunlabeler :: ()-    => context ('Spec (label ': labels) a)-    -> context ('Spec labels a)---instance Labelable context => HLabelable (Col context) where-  hlabeler = labeler-  hunlabeler = unlabeler---instance HLabelable (Dict (ConstrainDBType constraint)) where-  hlabeler Dict = Dict-  hunlabeler Dict = Dict

@@ -1,188 +1,152 @@ {-# language DataKinds #-}+{-# language EmptyCase #-} {-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language InstanceSigs #-}-{-# language MultiParamTypeClasses #-}+{-# language GADTs #-}+{-# language LambdaCase #-} {-# language NamedFieldPuns #-}-{-# language ScopedTypeVariables #-} {-# language StandaloneKindSignatures #-}-{-# language TypeFamilies #-}  module Rel8.Schema.Context.Nullify-  ( Nullifiable( ConstrainTag, encodeTag, decodeTag, nullifier, unnullifier )-  , HNullifiable( HConstrainTag, hencodeTag, hdecodeTag, hnullifier, hunnullifier )-  , runTag, unnull+  ( Nullifiability(..), NonNullifiability(..), nullifiableOrNot, absurd+  , Nullifiable, nullifiability+  , guarder, nullifier, unnullifier+  , sguard, snullify   ) where  -- base+import Data.Bool ( bool )+import Data.Functor.Identity ( Identity( Identity ) ) import Data.Kind ( Constraint, Type )-import GHC.TypeLits ( KnownSymbol )+import Data.Monoid ( getFirst ) import Prelude hiding ( null )  -- opaleye import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye  -- rel8-import Rel8.Aggregate-  ( Aggregate( Aggregate ), Col( A )-  , mapInputs-  , unsafeMakeAggregate-  )-import Rel8.Expr ( Expr, Col( E ) )+import Rel8.Aggregate ( Aggregate( Aggregate ), foldInputs, mapInputs )+import Rel8.Expr ( Expr ) import Rel8.Expr.Bool ( boolExpr ) import Rel8.Expr.Null ( nullify, unsafeUnnullify ) import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )-import Rel8.Schema.Context ( Interpretation )+import Rel8.Kind.Context ( SContext(..) )+import Rel8.Schema.Field ( Field ) import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Name ( Name( Name ), Col( N ) )-import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql )-import Rel8.Schema.Dict ( Dict( Dict ) )-import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )-import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )-import qualified Rel8.Schema.Spec.ConstrainDBType as ConstrainDBType-import Rel8.Table.Tag ( Tag(..), Taggable, fromAggregate, fromExpr, fromName )+import Rel8.Schema.Name ( Name( Name ) )+import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )+import Rel8.Schema.Result ( Result )+import Rel8.Schema.Spec ( Spec(..) )  -type Nullifiable :: K.Context -> Constraint-class Interpretation context => Nullifiable context where-  type ConstrainTag context :: Type -> Constraint-  type ConstrainTag _context = DefaultConstrainTag+type Nullifiability :: K.Context -> Type+data Nullifiability context where+  NAggregate :: Nullifiability Aggregate+  NExpr :: Nullifiability Expr+  NName :: Nullifiability Name -  encodeTag ::-    ( Sql (ConstrainTag context) a-    , KnownSymbol label-    , Taggable a-    )-    => Tag label a-    -> Col context ('Spec labels a) -  decodeTag ::-    ( Sql (ConstrainTag context) a-    , KnownSymbol label-    , Taggable a-    )-    => Col context ('Spec labels a)-    -> Tag label a--  nullifier :: ()-    => Tag label a-    -> (Expr a -> Expr Bool)-    -> SSpec ('Spec labels x)-    -> Col context ('Spec labels x)-    -> Col context ('Spec labels (Nullify x))--  unnullifier :: ()-    => SSpec ('Spec labels x)-    -> Col context ('Spec labels (Nullify x))-    -> Col context ('Spec labels x)+type Nullifiable :: K.Context -> Constraint+class Nullifiable context where+  nullifiability :: Nullifiability context   instance Nullifiable Aggregate where-  encodeTag Tag {aggregator, expr} =-    A $ unsafeMakeAggregate toPrimExpr fromPrimExpr aggregator expr--  decodeTag (A aggregate) = fromAggregate aggregate--  nullifier Tag {expr} test SSpec {nullity} (A (Aggregate a)) =-    A $-    mapInputs (toPrimExpr . runTag nullity condition . fromPrimExpr) $-    Aggregate $-    runTag nullity condition <$> a-    where-      condition = test expr--  unnullifier SSpec {nullity} (A (Aggregate a)) =-    A (Aggregate (unnull nullity <$> a))--  {-# INLINABLE encodeTag #-}-  {-# INLINABLE decodeTag #-}-  {-# INLINABLE nullifier #-}-  {-# INLINABLE unnullifier #-}+  nullifiability = NAggregate   instance Nullifiable Expr where-  encodeTag Tag {expr} = E expr-  decodeTag (E a) = fromExpr a-  nullifier Tag {expr} test SSpec {nullity} (E a) =-    E $ runTag nullity (test expr) a-  unnullifier SSpec {nullity} (E a) = E $ unnull nullity a--  {-# INLINABLE encodeTag #-}-  {-# INLINABLE decodeTag #-}-  {-# INLINABLE nullifier #-}-  {-# INLINABLE unnullifier #-}+  nullifiability = NExpr   instance Nullifiable Name where-  encodeTag Tag {name} = N name-  decodeTag (N name) = fromName name-  nullifier _ _ _ (N (Name name)) = N (Name name)-  unnullifier _ (N (Name name)) = N (Name name)+  nullifiability = NName -  {-# INLINABLE encodeTag #-}-  {-# INLINABLE decodeTag #-}-  {-# INLINABLE nullifier #-}-  {-# INLINABLE unnullifier #-} +type NonNullifiability :: K.Context -> Type+data NonNullifiability context where+  NField :: NonNullifiability (Field table)+  NResult :: NonNullifiability Result -runTag :: Nullity a -> Expr Bool -> Expr a -> Expr (Nullify a)-runTag nullity tag a = case nullity of-  Null -> boolExpr null a tag-  NotNull -> boolExpr null (nullify a) tag-  where-    null = fromPrimExpr $ Opaleye.ConstExpr Opaleye.NullLit +nullifiableOrNot :: ()+  => SContext context+  -> Either (NonNullifiability context) (Nullifiability context)+nullifiableOrNot = \case+  SAggregate -> Right NAggregate+  SExpr -> Right NExpr+  SField -> Left NField+  SName -> Right NName+  SResult -> Left NResult -unnull :: Nullity a -> Expr (Nullify a) -> Expr a-unnull nullity a = case nullity of-  Null -> a-  NotNull -> unsafeUnnullify a +absurd :: Nullifiability context -> NonNullifiability context -> a+absurd = \case+  NAggregate -> \case+  NExpr -> \case+  NName -> \case -type HNullifiable :: K.HContext -> Constraint-class HNullifiable context where-  type HConstrainTag context :: Type -> Constraint-  type HConstrainTag _context = DefaultConstrainTag -  hencodeTag :: (Sql (HConstrainTag context) a, KnownSymbol label, Taggable a)-    => Tag label a-    -> context ('Spec labels a)+guarder :: ()+  => SContext context+  -> context tag+  -> (tag -> Bool)+  -> (Expr tag -> Expr Bool)+  -> context (Maybe a)+  -> context (Maybe a)+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)) -  hdecodeTag :: (Sql (HConstrainTag context) a, KnownSymbol label, Taggable a)-    => context ('Spec labels a)-    -> Tag label a -  hnullifier :: ()-    => Tag label a-    -> (Expr a -> Expr Bool)-    -> SSpec ('Spec labels x)-    -> context ('Spec labels x)-    -> context ('Spec labels (Nullify x))+nullifier :: ()+  => Nullifiability context+  -> Spec a+  -> context a+  -> context (Nullify a)+nullifier = \case+  NAggregate -> \Spec {nullity} (Aggregate a) ->+    Aggregate $ snullify nullity <$> a+  NExpr -> \Spec {nullity} a -> snullify nullity a+  NName -> \_ (Name a) -> Name a -  hunnullifier :: ()-    => SSpec ('Spec labels x)-    -> context ('Spec labels (Nullify x))-    -> context ('Spec labels x) +unnullifier :: ()+  => Nullifiability context+  -> Spec a+  -> context (Nullify a)+  -> context a+unnullifier = \case+  NAggregate -> \Spec {nullity} (Aggregate a) ->+    Aggregate $ sunnullify nullity <$> a+  NExpr -> \Spec {nullity} a -> sunnullify nullity a+  NName -> \_ (Name a) -> Name a -instance Nullifiable context => HNullifiable (Col context) where-  type HConstrainTag (Col context) = ConstrainTag context-  hencodeTag = encodeTag-  hdecodeTag = decodeTag-  hnullifier = nullifier-  hunnullifier = unnullifier +sguard :: Expr Bool -> Expr (Maybe a) -> Expr (Maybe a)+sguard condition a = boolExpr null a condition+  where+    null = fromPrimExpr $ Opaleye.ConstExpr Opaleye.NullLit -instance HNullifiable (Dict (ConstrainDBType constraint)) where-  type HConstrainTag (Dict (ConstrainDBType constraint)) = constraint -  hencodeTag _ = Dict-  hdecodeTag = mempty-  hnullifier _ _ = ConstrainDBType.nullifier-  hunnullifier = ConstrainDBType.unnullifier+snullify :: Nullity a -> Expr a -> Expr (Nullify a)+snullify nullity a = case nullity of+  Null -> a+  NotNull -> nullify a  -type DefaultConstrainTag :: Type -> Constraint-class DefaultConstrainTag a-instance DefaultConstrainTag a+sunnullify :: Nullity a -> Expr (Nullify a) -> Expr a+sunnullify nullity a = case nullity of+  Null -> a+  NotNull -> unsafeUnnullify a

@@ -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

@@ -34,7 +34,7 @@  -- rel8 import Rel8.Schema.Dict ( Dict )-import Rel8.Schema.Spec ( Spec, SSpec )+import Rel8.Schema.Spec ( Spec ) import Rel8.Schema.HTable.Product ( HProduct( HProduct ) ) import qualified Rel8.Schema.Kind as K @@ -50,14 +50,14 @@ -- instances yourself or specify this constraint. type HTable :: K.HTable -> Constraint class HTable t where-  type HField t = (field :: Spec -> Type) | field -> t-  type HConstrainTable t (c :: Spec -> Constraint) :: Constraint+  type HField t = (field :: Type -> Type) | field -> t+  type HConstrainTable t (c :: Type -> Constraint) :: Constraint -  hfield :: t context -> HField t spec -> context spec-  htabulate :: (forall spec. HField t spec -> context spec) -> t context-  htraverse :: Apply m => (forall spec. f spec -> m (g spec)) -> t f -> m (t g)+  hfield :: t context -> HField t a -> context a+  htabulate :: (forall a. HField t a -> context a) -> t context+  htraverse :: Apply m => (forall a. f a -> m (g a)) -> t f -> m (t g)   hdicts :: HConstrainTable t c => t (Dict c)-  hspecs :: t SSpec+  hspecs :: t Spec    type HField t = GHField t   type HConstrainTable t c = HConstrainTable (GHColumns (Rep (t Proxy))) c@@ -68,7 +68,7 @@     , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))     , GHTable context (Rep (t context))     )-    => t context -> HField t spec -> context spec+    => t context -> HField t a -> context a   hfield table (GHField field) = hfield (toGHColumns (from table)) field    default htabulate ::@@ -77,7 +77,7 @@     , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))     , GHTable context (Rep (t context))     )-    => (forall spec. HField t spec -> context spec) -> t context+    => (forall a. HField t a -> context a) -> t context   htabulate f = to $ fromGHColumns $ htabulate (f . GHField)    default htraverse@@ -87,7 +87,7 @@        , Generic (t g), GHTable g (Rep (t g))        , GHColumns (Rep (t f)) ~ GHColumns (Rep (t g))        )-    => (forall spec. f spec -> m (g spec)) -> t f -> m (t g)+    => (forall a. f a -> m (g a)) -> t f -> m (t g)   htraverse f = fmap (to . fromGHColumns) . htraverse f . toGHColumns . from    default hdicts@@ -101,10 +101,10 @@   hdicts = to $ fromGHColumns (hdicts @(GHColumns (Rep (t Proxy))) @c)    default hspecs ::-    ( Generic (t SSpec)-    , GHTable SSpec (Rep (t SSpec))+    ( Generic (t Spec)+    , GHTable Spec (Rep (t Spec))     )-    => t SSpec+    => t Spec   hspecs = to $ fromGHColumns hspecs    {-# INLINABLE hfield #-}@@ -115,21 +115,21 @@   hmap :: HTable t-  => (forall spec. context spec -> context' spec) -> t context -> t context'+  => (forall a. context a -> context' a) -> t context -> t context' hmap f a = htabulate $ \field -> f (hfield a field)   htabulateA :: (HTable t, Apply m)-  => (forall spec. HField t spec -> m (context spec)) -> m (t context)+  => (forall a. HField t a -> m (context a)) -> m (t context) htabulateA f = htraverse getCompose $ htabulate $ Compose . f {-# INLINABLE htabulateA #-}  -type GHField :: K.HTable -> Spec -> Type-newtype GHField t spec = GHField (HField (GHColumns (Rep (t Proxy))) spec)+type GHField :: K.HTable -> Type -> Type+newtype GHField t a = GHField (HField (GHColumns (Rep (t Proxy))) a)  -type GHTable :: K.HContext -> (Type -> Type) -> Constraint+type GHTable :: K.Context -> (Type -> Type) -> Constraint class HTable (GHColumns rep) => GHTable context rep | rep -> context where   type GHColumns rep :: K.HTable   toGHColumns :: rep x -> GHColumns rep context@@ -155,10 +155,10 @@   -- | A HField type for indexing into HProduct.-type HProductField :: K.HTable -> K.HTable -> Spec -> Type-data HProductField x y spec-  = HFst (HField x spec)-  | HSnd (HField y spec)+type HProductField :: K.HTable -> K.HTable -> Type -> Type+data HProductField x y a+  = HFst (HField x a)+  | HSnd (HField y a)   instance (HTable x, HTable y) => HTable (HProduct x y) where

@@ -15,17 +15,16 @@  -- rel8 import Rel8.Schema.HTable ( HTable )-import Rel8.Schema.HTable.Identity ( HIdentity(..) )+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 ( EitherTag )   type HEitherTable :: K.HTable -> K.HTable -> K.HTable data HEitherTable left right context = HEitherTable-  { htag :: HIdentity ('Spec '["isRight"] EitherTag) context+  { htag :: HLabel "isRight" (HIdentity EitherTag) context   , hleft :: HLabel "Left" (HNullify left) context   , hright :: HLabel "Right" (HNullify right) context   }

@@ -1,17 +1,17 @@ {-# language DataKinds #-}-{-# language GADTs #-}-{-# language PatternSynonyms #-}+{-# language FlexibleContexts #-} {-# language StandaloneKindSignatures #-} {-# language TypeFamilies #-}+{-# language UndecidableInstances #-}  module Rel8.Schema.HTable.Identity-  ( HIdentity( HIdentity, HType, unHIdentity )-  , HType+  ( HIdentity( HIdentity, unHIdentity )   ) where  -- base import Data.Kind ( Type )+import Data.Type.Equality ( (:~:)( Refl ) ) import Prelude  -- rel8@@ -21,35 +21,23 @@   , hfield, htabulate, htraverse, hdicts, hspecs   ) import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Spec ( Spec( Spec ), KnownSpec, specSing )---type HType :: Type -> K.HTable-type HType a = HIdentity ('Spec '[] a)---pattern HType :: context ('Spec '[] a) -> HType a context-pattern HType a = HIdentity a-{-# COMPLETE HType #-}+import Rel8.Schema.Null ( Sql )+import Rel8.Schema.Spec ( specification )+import Rel8.Type ( DBType )  -type HIdentity :: Spec -> K.HTable-newtype HIdentity spec context = HIdentity-  { unHIdentity :: context spec+type HIdentity :: Type -> K.HTable+newtype HIdentity a context = HIdentity+  { unHIdentity :: context a   }  -type HIdentityField :: Spec -> Spec -> Type-data HIdentityField _spec spec where-  HIdentityField :: HIdentityField spec spec---instance KnownSpec spec => HTable (HIdentity spec) where-  type HConstrainTable (HIdentity spec) c = c spec-  type HField (HIdentity spec) = HIdentityField spec+instance Sql DBType a => HTable (HIdentity a) where+  type HConstrainTable (HIdentity a) constraint = constraint a+  type HField (HIdentity a) = (:~:) a -  hfield (HIdentity a) HIdentityField = a-  htabulate f = HIdentity $ f HIdentityField+  hfield (HIdentity a) Refl = a+  htabulate f = HIdentity $ f Refl   htraverse f (HIdentity a) = HIdentity <$> f a   hdicts = HIdentity Dict-  hspecs = HIdentity specSing+  hspecs = HIdentity specification

@@ -1,83 +1,70 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE LambdaCase #-}-{-# language ConstraintKinds #-} {-# language DataKinds #-}-{-# language FlexibleInstances #-}-{-# language GADTs #-}-{-# language MultiParamTypeClasses #-}-{-# language QuantifiedConstraints #-} {-# language RankNTypes #-} {-# language RecordWildCards #-} {-# language ScopedTypeVariables #-} {-# language StandaloneKindSignatures #-}+{-# language TypeApplications #-} {-# language TypeFamilies #-}-{-# language TypeOperators #-}-{-# language UndecidableInstances #-}  module Rel8.Schema.HTable.Label-  ( HLabel, Label-  , hlabel, hunlabel+  ( HLabel, hlabel, hrelabel, hunlabel+  , hproject   ) where  -- base+import Data.Kind ( Type ) import Data.Proxy ( Proxy( Proxy ) )-import GHC.TypeLits ( KnownSymbol, Symbol )+import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal ) import Prelude  -- rel8-import Rel8.Kind.Labels ( SLabels( SCons ) ) import Rel8.Schema.HTable-  ( HTable-  , hfield, htabulate, hspecs+  ( HTable, HConstrainTable, HField+  , htabulate, hfield, htraverse, hdicts, hspecs   ) import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )-import Rel8.FCF-import Rel8.Schema.HTable.MapTable-import GHC.Generics (Generic)+import Rel8.Schema.Spec ( Spec(..) )   type HLabel :: Symbol -> K.HTable -> K.HTable-newtype HLabel label table context = HLabel (HMapTable (Label label) table context)-  deriving stock Generic-  deriving anyclass HTable+newtype HLabel label table context = HLabel (table context)  -data Label :: Symbol -> Spec -> Exp Spec+type HLabelField :: Symbol -> K.HTable -> Type -> Type+newtype HLabelField label table a = HLabelField (HField table a)  -type instance Eval (Label label ('Spec labels a)) = 'Spec (label : labels) a-+instance (HTable table, KnownSymbol label) => HTable (HLabel label table) where+  type HField (HLabel label table) = HLabelField label table+  type HConstrainTable (HLabel label table) constraint =+    HConstrainTable table constraint -instance KnownSymbol l => MapSpec (Label l) where-  mapInfo = \case-    SSpec {..} -> SSpec {labels = SCons Proxy labels, ..}+  hfield (HLabel a) (HLabelField field) = hfield a field+  htabulate f = HLabel (htabulate (f . HLabelField))+  htraverse f (HLabel a) = HLabel <$> htraverse f a+  hdicts = HLabel (hdicts @table)+  hspecs = HLabel $ htabulate $ \field -> case hfield (hspecs @table) field of+    Spec {..} -> Spec {labels = symbolVal (Proxy @label) : labels, ..}+  {-# INLINABLE hspecs #-}  -hlabel :: (HTable t, KnownSymbol label)-  => (forall labels a. ()-    => context ('Spec labels a)-    -> context ('Spec (label ': labels) a))-  -> t context-  -> HLabel label t context-hlabel labeler a = HLabel $ htabulate $ \(HMapTableField field) ->-  case hfield hspecs field of-    SSpec {} -> labeler (hfield a field)+hlabel :: forall label t context. t context -> HLabel label t context+hlabel = HLabel {-# INLINABLE hlabel #-}  -hunlabel :: (HTable t, KnownSymbol label)-  => (forall labels a. ()-    => context ('Spec (label ': labels) a)-    -> context ('Spec labels a))-  -> HLabel label t context-  -> t context-hunlabel unlabler (HLabel as) =-  htabulate $ \field -> -    case hfield hspecs field of-      SSpec {} -> case hfield as (HMapTableField field) of-        a -> unlabler a+hrelabel :: forall label' label t context. HLabel label t context -> HLabel label' t context+hrelabel = hlabel . hunlabel+{-# INLINABLE hrelabel #-}+++hunlabel :: forall label t context. HLabel label t context -> t context+hunlabel (HLabel a) = a {-# INLINABLE hunlabel #-}+++hproject :: ()+  => (forall ctx. t ctx -> t' ctx)+  -> HLabel label t context -> HLabel label t' context+hproject f (HLabel a) = HLabel (f a)

@@ -6,7 +6,7 @@ {-# language GADTs #-} {-# language InstanceSigs #-} {-# language MultiParamTypeClasses #-}-{-# language PolyKinds #-}+{-# language RankNTypes #-} {-# language ScopedTypeVariables #-} {-# language StandaloneKindSignatures #-} {-# language TypeApplications #-}@@ -19,34 +19,38 @@   , MapSpec(..)   , Precompose(..)   , HMapTableField(..)+  , hproject   ) where  -- base import Data.Kind ( Constraint, Type )-import Prelude ( ($), (.), (<$>), fmap )+import Prelude  -- rel8-import Rel8.FCF+import Rel8.FCF ( Exp, Eval ) import Rel8.Schema.HTable-import Rel8.Schema.Spec ( Spec, SSpec )+  ( HTable, HConstrainTable, HField+  , hfield, htabulate, htraverse, hdicts, hspecs+  )+import Rel8.Schema.Spec ( Spec ) import qualified Rel8.Schema.Kind as K import Rel8.Schema.Dict ( Dict( Dict ) )  -type HMapTable :: (a -> Exp b) -> ((a -> Type) -> Type) -> (b -> Type) -> Type-newtype HMapTable f t g = HMapTable-  { unHMapTable :: t (Precompose f g)+type HMapTable :: (Type -> Exp Type) -> K.HTable -> K.HTable+newtype HMapTable f t context = HMapTable+  { unHMapTable :: t (Precompose f context)   }  -type Precompose :: (a -> Exp b) -> (b -> Type) -> a -> Type+type Precompose :: (Type -> Exp Type) -> K.Context -> K.Context newtype Precompose f g x = Precompose   { precomposed :: g (Eval (f x))   }  -type HMapTableField :: (Spec -> Exp a) -> K.HTable -> a -> Type+type HMapTableField :: (Type -> Exp Type) -> K.HTable -> K.Context data HMapTableField f t x where   HMapTableField :: HField t a -> HMapTableField f t (Eval (f a)) @@ -79,11 +83,17 @@   {-# INLINABLE hspecs #-}  -type MapSpec :: (Spec -> Exp Spec) -> Constraint+type MapSpec :: (Type -> Exp Type) -> Constraint class MapSpec f where-  mapInfo :: SSpec x -> SSpec (Eval (f x))+  mapInfo :: Spec x -> Spec (Eval (f x))  -type ComposeConstraint :: (a -> Exp b) -> (b -> Constraint) -> a -> Constraint+type ComposeConstraint :: (Type -> Exp Type) -> (Type -> Constraint) -> Type -> Constraint class c (Eval (f a)) => ComposeConstraint f c a instance c (Eval (f a)) => ComposeConstraint f c a+++hproject :: ()+  => (forall ctx. t ctx -> t' ctx)+  -> HMapTable f t context -> HMapTable f t' context+hproject f (HMapTable a) = HMapTable (f a)

@@ -15,17 +15,16 @@  -- rel8 import Rel8.Schema.HTable ( HTable )-import Rel8.Schema.HTable.Identity ( HIdentity(..) )+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 )   type HMaybeTable :: K.HTable -> K.HTable data HMaybeTable table context = HMaybeTable-  { htag :: HIdentity ('Spec '["isJust"] (Maybe MaybeTag)) context+  { htag :: HLabel "isJust" (HIdentity (Maybe MaybeTag)) context   , hjust :: HLabel "Just" (HNullify table) context   }   deriving stock Generic

@@ -10,6 +10,7 @@ {-# language NamedFieldPuns #-} {-# language QuantifiedConstraints #-} {-# language RankNTypes #-}+{-# language RecordWildCards #-} {-# language ScopedTypeVariables #-} {-# language StandaloneKindSignatures #-} {-# language TypeFamilies #-}@@ -18,25 +19,34 @@ module Rel8.Schema.HTable.Nullify   ( HNullify( HNullify )   , Nullify-  , hnulls, hnullify, hunnullify+  , hguard+  , hnulls+  , hnullify+  , hunnullify+  , hproject   ) where  -- base+import Data.Kind ( Type )+import GHC.Generics ( Generic ) import Prelude hiding ( null )  -- rel8+import Rel8.FCF ( Eval, Exp ) import Rel8.Schema.HTable ( HTable, hfield, htabulate, htabulateA, hspecs )+import Rel8.Schema.HTable.MapTable+  ( HMapTable, HMapTableField( HMapTableField )+  , MapSpec, mapInfo+  )+import qualified Rel8.Schema.HTable.MapTable as HMapTable ( hproject ) import qualified Rel8.Schema.Kind as K import Rel8.Schema.Null ( Nullity( Null, NotNull ) ) import qualified Rel8.Schema.Null as Type ( Nullify )-import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )+import Rel8.Schema.Spec ( Spec(..) )  -- semigroupoids import Data.Functor.Apply ( Apply )-import Rel8.Schema.HTable.MapTable-import Rel8.FCF-import GHC.Generics (Generic)   type HNullify :: K.HTable -> K.HTable@@ -45,58 +55,63 @@   deriving anyclass HTable  ---- | Transform a 'Spec' by allowing it to be @null@.-data Nullify :: Spec -> Exp Spec---type instance Eval (Nullify ('Spec labels a)) =-  'Spec labels (Type.Nullify a)+-- | Transform a 'Type' by allowing it to be @null@.+data Nullify :: Type -> Exp Type+type instance Eval (Nullify a) = Type.Nullify a   instance MapSpec Nullify where   mapInfo = \case-    SSpec{labels, info, nullity} -> SSpec-      { labels-      , info-      , nullity = case nullity of+    Spec {nullity, ..} -> Spec+      { nullity = case nullity of           Null    -> Null           NotNull -> Null-      } +      , ..+      }  +hguard :: HTable t+  => (forall a. context (Maybe a) -> context (Maybe a))+  -> HNullify t context -> HNullify t context+hguard guarder (HNullify as) = HNullify $ htabulate $ \(HMapTableField field) ->+  case hfield hspecs field of+    Spec {nullity} -> case hfield as (HMapTableField field) of+      a -> case nullity of+        Null -> guarder a+        NotNull -> guarder a++ hnulls :: HTable t-  => (forall labels a. ()-    => SSpec ('Spec labels a)-    -> context ('Spec labels (Type.Nullify a)))+  => (forall a. Spec a -> context (Type.Nullify a))   -> HNullify t context-hnulls null = HNullify $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of-  spec@SSpec {} -> null spec+hnulls null = HNullify $ htabulate $ \(HMapTableField field) ->+  case hfield hspecs field of+    spec@Spec {} -> null spec {-# INLINABLE hnulls #-}   hnullify :: HTable t-  => (forall labels a. ()-    => SSpec ('Spec labels a)-    -> context ('Spec labels a)-    -> context ('Spec labels (Type.Nullify a)))+  => (forall a. Spec a -> context a -> context (Type.Nullify a))   -> t context   -> HNullify t context hnullify nullifier a = HNullify $ htabulate $ \(HMapTableField field) ->   case hfield hspecs field of-    spec@SSpec {} -> nullifier spec (hfield a field)+    spec@Spec {} -> nullifier spec (hfield a field) {-# INLINABLE hnullify #-}   hunnullify :: (HTable t, Apply m)-  => (forall labels a. ()-    => SSpec ('Spec labels a)-    -> context ('Spec labels (Type.Nullify a))-    -> m (context ('Spec labels a)))+  => (forall a. Spec a -> context (Type.Nullify a) -> m (context a))   -> HNullify t context   -> m (t context) hunnullify unnullifier (HNullify as) =   htabulateA $ \field -> case hfield hspecs field of-    spec@SSpec {} -> case hfield as (HMapTableField field) of+    spec@Spec {} -> case hfield as (HMapTableField field) of       a -> unnullifier spec a {-# INLINABLE hunnullify #-}+++hproject :: ()+  => (forall ctx. t ctx -> t' ctx)+  -> HNullify t context -> HNullify t' context+hproject f (HNullify a) = HNullify (HMapTable.hproject f a)

@@ -19,15 +19,14 @@ 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 )   type HTheseTable :: K.HTable -> K.HTable -> K.HTable data HTheseTable here there context = HTheseTable-  { hhereTag :: HIdentity ('Spec '["hasHere"] (Maybe MaybeTag)) context+  { hhereTag :: HLabel "hereTag" (HIdentity (Maybe MaybeTag)) context   , hhere :: HLabel "Here" (HNullify here) context-  , hthereTag :: HIdentity ('Spec '["hasThere"] (Maybe MaybeTag)) context+  , hthereTag :: HLabel "thereTag" (HIdentity (Maybe MaybeTag)) context   , hthere :: HLabel "There" (HNullify there) context   }   deriving stock Generic

@@ -9,8 +9,6 @@ {-# language GADTs #-} {-# language LambdaCase #-} {-# language MultiParamTypeClasses #-}-{-# language NamedFieldPuns #-}-{-# language QuantifiedConstraints #-} {-# language RankNTypes #-} {-# language RecordWildCards #-} {-# language ScopedTypeVariables #-}@@ -23,32 +21,33 @@   ( HVectorize   , hvectorize, hunvectorize   , happend, hempty+  , hproject   ) where  -- base import Data.Kind ( Type ) import Data.List.NonEmpty ( NonEmpty )+import GHC.Generics (Generic) import Prelude  -- rel8-import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler )+import Rel8.FCF ( Eval, Exp ) import Rel8.Schema.Dict ( Dict( Dict ) ) import qualified Rel8.Schema.Kind as K-import Rel8.Schema.HTable-  ( HTable-  , hfield, htabulate, htabulateA, hspecs+import Rel8.Schema.HTable ( HTable, hfield, htabulate, htabulateA, hspecs )+import Rel8.Schema.HTable.MapTable+  ( HMapTable, HMapTableField( HMapTableField )+  , MapSpec, mapInfo   )+import qualified Rel8.Schema.HTable.MapTable as HMapTable ( hproject ) import Rel8.Schema.Null ( Unnullify, NotNull, Nullity( NotNull ) )-import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )+import Rel8.Schema.Spec ( Spec(..) ) import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation ) import Rel8.Type.Information ( TypeInformation )  -- semialign import Data.Zip ( Unzip, Zip, Zippy(..) )-import Rel8.FCF-import Rel8.Schema.HTable.MapTable-import GHC.Generics (Generic)   class Vector list where@@ -75,16 +74,16 @@   deriving anyclass HTable  -data Vectorize :: (Type -> Type) -> Spec -> Exp Spec+data Vectorize :: (Type -> Type) -> Type -> Exp Type  -type instance Eval (Vectorize list ('Spec labels a)) = 'Spec labels (list a)+type instance Eval (Vectorize list a) = list a   instance Vector list => MapSpec (Vectorize list) where   mapInfo = \case-    SSpec {..} -> case listNotNull @list nullity of-      Dict -> SSpec+    Spec {..} -> case listNotNull @list nullity of+      Dict -> Spec         { nullity = NotNull         , info = vectorTypeInformation nullity info         , ..@@ -92,60 +91,45 @@   hvectorize :: (HTable t, Unzip f, Vector list)-  => (forall labels a. ()-    => SSpec ('Spec labels a)-    -> f (context ('Spec labels a))-    -> context' ('Spec labels (list a)))+  => (forall a. Spec a -> f (context a) -> context' (list a))   -> f (t context)   -> HVectorize list t context' hvectorize vectorizer as = HVectorize $ htabulate $ \(HMapTableField field) ->   case hfield hspecs field of-    spec@SSpec {} -> vectorizer spec (fmap (`hfield` field) as)+    spec -> vectorizer spec (fmap (`hfield` field) as) {-# INLINABLE hvectorize #-}   hunvectorize :: (HTable t, Zip f, Vector list)-  => (forall labels a. ()-    => SSpec ('Spec labels a)-    -> context ('Spec labels (list a))-    -> f (context' ('Spec labels a)))+  => (forall a. Spec a -> context (list a) -> f (context' a))   -> HVectorize list t context   -> f (t context') hunvectorize unvectorizer (HVectorize table) =   getZippy $ htabulateA $ \field -> case hfield hspecs field of-    spec@SSpec{} -> case hfield table (HMapTableField field) of+    spec -> case hfield table (HMapTableField field) of       a -> Zippy (unvectorizer spec a) {-# INLINABLE hunvectorize #-}  -happend :: (HTable t, Vector list) =>-  ( forall labels a. ()-    => Nullity a-    -> TypeInformation (Unnullify a)-    -> context ('Spec labels (list a))-    -> context ('Spec labels (list a))-    -> context ('Spec labels (list a))-  )+happend :: (HTable t, Vector list)+  => (forall a. Spec a -> context (list a) -> context (list a) -> context (list a))   -> HVectorize list t context   -> HVectorize list t context   -> HVectorize list t context happend append (HVectorize as) (HVectorize bs) = HVectorize $   htabulate $ \field@(HMapTableField j) -> case (hfield as field, hfield bs field) of     (a, b) -> case hfield hspecs j of-      SSpec {nullity, info} -> append nullity info a b+      spec -> append spec a b  -hempty :: HTable t =>-  ( forall labels a. ()-    => Nullity a-    -> TypeInformation (Unnullify a)-    -> context ('Spec labels [a])-  )+hempty :: HTable t+  => (forall a. Spec a -> context [a])   -> HVectorize [] t context-hempty empty = HVectorize $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of-  SSpec {nullity, info} -> empty nullity info+hempty empty = HVectorize $ htabulate $ \(HMapTableField field) ->+  empty (hfield hspecs field)  -instance HLabelable g => HLabelable (Precompose (Vectorize list) g) where-  hlabeler = Precompose . hlabeler . precomposed-  hunlabeler = Precompose . hunlabeler . precomposed+hproject :: ()+  => (forall ctx. t ctx -> t' ctx)+  -> HVectorize list t context -> HVectorize list t' context+hproject f (HVectorize a) = HVectorize (HMapTable.hproject f a)

@@ -1,8 +1,9 @@ {-# language StandaloneKindSignatures #-}  module Rel8.Schema.Kind-  ( Context, Rel8able-  , HContext, HTable+  ( Rel8able+  , Context+  , HTable   ) where @@ -10,23 +11,13 @@ import Data.Kind ( Type ) import Prelude () --- rel8-import Rel8.Schema.Spec ( Spec ) --type HContext :: Type-type HContext = Spec -> Type+type Context :: Type+type Context = Type -> Type   type HTable :: Type-type HTable = HContext -> Type---data X---type Context :: Type-type Context = X -> Type+type HTable = Context -> Type   type Rel8able :: Type

@@ -3,41 +3,44 @@ {-# language FlexibleContexts #-} {-# language FlexibleInstances #-} {-# language GADTs #-}+{-# language GeneralizedNewtypeDeriving #-} {-# language MultiParamTypeClasses #-}-{-# language PolyKinds #-} {-# language RankNTypes #-}-{-# language StandaloneDeriving #-} {-# language StandaloneKindSignatures #-} {-# language TypeFamilies #-} {-# language UndecidableInstances #-}-{-# language UndecidableSuperClasses #-}  module Rel8.Schema.Name   ( Name(..)-  , Col( N, unN )   , Selects+  , ppColumn   ) where  -- base-import Data.Functor.Identity ( Identity )+import Data.Functor.Identity ( Identity( Identity ) ) import Data.Kind ( Constraint, Type )-import Data.String ( IsString, fromString )+import Data.String ( IsString ) import Prelude +-- opaleye+import qualified Opaleye.Internal.HaskellDB.Sql as Opaleye+import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye++-- pretty+import Text.PrettyPrint ( Doc )+ -- rel8 import Rel8.Expr ( Expr )-import Rel8.Schema.Context ( Interpretation, Col )-import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )-import Rel8.Schema.HTable.Identity ( HIdentity( HType ), HType )+import qualified Rel8.Schema.Kind as K+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) ) import Rel8.Schema.Null ( Sql )-import Rel8.Schema.Reify ( notReify )-import Rel8.Schema.Result ( Result )-import Rel8.Schema.Spec ( Spec( Spec ) ) import Rel8.Table-  ( Table, Columns, Context, fromColumns, toColumns, reify, unreify+  ( Table, Columns, Context, fromColumns, toColumns+  , FromExprs, fromResult, toResult+  , Transpose   )-import Rel8.Table.Recontextualize ( Recontextualize )+import Rel8.Table.Transpose ( Transposes ) import Rel8.Type ( DBType )  @@ -45,55 +48,30 @@ -- schema definition. You can construct names by using the @OverloadedStrings@ -- extension and writing string literals. This is typically done when providing -- a 'TableSchema' value.-type Name :: k -> Type-data Name a where-  Name :: k ~ Type => !String -> Name (a :: k)---deriving stock instance Show (Name a)---instance k ~ Type => IsString (Name (a :: k)) where-  fromString = Name+type Name :: K.Context+newtype Name a = Name String+  deriving stock Show+  deriving newtype IsString   instance Sql DBType a => Table Name (Name a) where-  type Columns (Name a) = HType a+  type Columns (Name a) = HIdentity a   type Context (Name a) = Name--  toColumns a = HType (N a)-  fromColumns (HType (N a)) = a-  reify = notReify-  unreify = notReify---instance Sql DBType a => Recontextualize Expr Name (Expr a) (Name a)---instance Sql DBType a => Recontextualize Result Name (Identity a) (Name a)---instance Sql DBType a => Recontextualize Name Expr (Name a) (Expr a)---instance Sql DBType a => Recontextualize Name Result (Name a) (Identity a)---instance Sql DBType a => Recontextualize Name Name (Name a) (Name a)---instance Interpretation Name where-  data Col Name _spec where-    N :: {unN :: !(Name a)} -> Col Name ('Spec labels a)-+  type FromExprs (Name a) = a+  type Transpose to (Name a) = to a -instance Labelable Name where-  labeler (N a) = N a-  unlabeler (N a) = N a+  toColumns a = HIdentity a+  fromColumns (HIdentity a) = a+  toResult a = HIdentity (Identity a)+  fromResult (HIdentity (Identity a)) = a   -- | @Selects a b@ means that @a@ is a schema (i.e., a 'Table' of 'Name's) for -- the 'Expr' columns in @b@. type Selects :: Type -> Type -> Constraint-class Recontextualize Name Expr names exprs => Selects names exprs-instance Recontextualize Name Expr names exprs => Selects names exprs+class Transposes Name Expr names exprs => Selects names exprs+instance Transposes Name Expr names exprs => Selects names exprs+++ppColumn :: String -> Doc+ppColumn = Opaleye.ppSqlExpr . Opaleye.ColumnSqlExpr . Opaleye.SqlColumn

@@ -0,0 +1,11 @@+{-# language PolyKinds #-}+{-# language RoleAnnotations #-}+{-# language StandaloneKindSignatures #-}++module Rel8.Schema.Name where++import Data.Kind ( Type )++type Name :: k -> Type+type role Name nominal+data Name a

@@ -1,74 +0,0 @@-{-# language AllowAmbiguousTypes #-}-{-# language EmptyCase #-}-{-# language DataKinds #-}-{-# language FlexibleInstances #-}-{-# language ScopedTypeVariables #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeApplications #-}-{-# language TypeFamilies #-}-{-# language TypeOperators #-}-{-# language UndecidableInstances #-}--module Rel8.Schema.Reify-  ( Reify, Col( Reify ), hreify, hunreify-  , UnwrapReify-  , NotReify, notReify-  )-where---- base-import Data.Kind ( Constraint )-import Data.Type.Equality ( (:~:)( Refl ) )-import Prelude---- rel8-import Rel8.Schema.Context ( Interpretation, Col )-import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )-import Rel8.Schema.HTable ( HTable, hmap )-import Rel8.Schema.Kind ( Context )---type Reify :: Context -> 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)---hreify :: HTable t => t (Col context) -> t (Col (Reify context))-hreify = hmap Reify---hunreify :: HTable t => t (Col (Reify context)) -> t (Col context)-hunreify = hmap (\(Reify a) -> a)---type UnwrapReify :: Context -> Context-type family UnwrapReify context where-  UnwrapReify (Reify context) = context---type IsReify :: Context -> Bool-type family IsReify context where-  IsReify (Reify _) = 'True-  IsReify _ = 'False---type NotReify :: Context -> Constraint-class IsReify context ~ 'False => NotReify context-instance IsReify context ~ 'False => NotReify context---notReify :: forall context ctx a. NotReify context => context :~: Reify ctx -> a-notReify refl = case lemma @context of-  Refl -> case refl of---lemma :: NotReify context => IsReify context :~: 'False-lemma = Refl

@@ -5,22 +5,20 @@ {-# language TypeFamilies #-}  module Rel8.Schema.Result-  ( Col( R, unR ), Result-  , relabel+  ( Result   , null, nullifier, unnullifier   , vectorizer, unvectorizer   ) where  -- base+import Data.Functor.Identity ( Identity( Identity), runIdentity ) import Prelude hiding ( null )  -- rel8-import Rel8.Schema.Context ( Interpretation( Col ) )-import Rel8.Schema.HTable.Identity ( HIdentity(..) ) import Rel8.Schema.Kind ( Context ) import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )-import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )+import Rel8.Schema.Spec ( Spec(..) )   -- | The @Result@ context is the context used for decoded query results.@@ -28,52 +26,29 @@ -- When a query is executed against a PostgreSQL database, Rel8 parses the -- returned rows, decoding each row into the @Result@ context. type Result :: Context-data Result a---instance Interpretation Result where-  data Col Result _spec where-    R :: {unR :: !a} -> Col Result ('Spec labels a)---relabel :: ()-  => HIdentity ('Spec labels a) (Col Result)-  -> HIdentity ('Spec relabels a) (Col Result)-relabel (HIdentity (R a)) = HIdentity (R a)+type Result = Identity  -null :: Col Result ('Spec labels (Maybe a))-null = R Nothing+null :: Result (Maybe a)+null = Identity Nothing  -nullifier :: ()-  => SSpec ('Spec labels a)-  -> Col Result ('Spec labels a)-  -> Col Result ('Spec labels (Nullify a))-nullifier SSpec {nullity} (R a) = R $ case nullity of+nullifier :: Spec a -> Result a -> Result (Nullify a)+nullifier Spec {nullity} (Identity a) = Identity $ case nullity of   Null -> a   NotNull -> Just a  -unnullifier :: ()-  => SSpec ('Spec labels a)-  -> Col Result ('Spec labels (Nullify a))-  -> Maybe (Col Result ('Spec labels a))-unnullifier SSpec {nullity} (R a) =+unnullifier :: Spec a -> Result (Nullify a) -> Maybe (Result a)+unnullifier Spec {nullity} (Identity a) =   case nullity of-    Null -> pure $ R a-    NotNull -> R <$> a+    Null -> pure $ Identity a+    NotNull -> Identity <$> a  -vectorizer :: Functor f-  => SSpec ('Spec labels a)-  -> f (Col Result ('Spec labels a))-  -> Col Result ('Spec labels (f a))-vectorizer _ = R . fmap unR+vectorizer :: Functor f => Spec a -> f (Result a) -> Result (f a)+vectorizer _ = Identity . fmap runIdentity  -unvectorizer :: Functor f-  => SSpec ('Spec labels a)-  -> Col Result ('Spec labels (f a))-  -> f (Col Result ('Spec labels a))-unvectorizer _ (R results) = R <$> results+unvectorizer :: Functor f => Spec a -> Result (f a) -> f (Result a)+unvectorizer _ (Identity results) = Identity <$> results

@@ -1,54 +1,34 @@-{-# language DataKinds #-} {-# language FlexibleContexts #-}-{-# language GADTs #-}+{-# language MonoLocalBinds #-} {-# language StandaloneKindSignatures #-}-{-# language UndecidableInstances #-}  module Rel8.Schema.Spec-  ( Spec( Spec )-  , SSpec( SSpec, labels, info, nullity )-  , KnownSpec( specSing )+  ( Spec( Spec, labels, info, nullity )+  , specification   ) where  -- base-import Data.Kind ( Constraint, Type )-import Prelude ()+import Data.Kind ( Type )+import Prelude  -- rel8-import Rel8.Kind.Labels ( Labels, SLabels, KnownLabels, labelsSing ) import Rel8.Schema.Null ( Nullity, Sql, Unnullify, nullable ) import Rel8.Type ( DBType, typeInformation ) import Rel8.Type.Information ( TypeInformation )  -type Spec :: Type-data Spec = Spec Labels Type---type SSpec :: Spec -> Type-data SSpec spec where-  SSpec ::-    { labels :: SLabels labels-    , info :: TypeInformation (Unnullify a)-    , nullity :: Nullity a-    }-    -> SSpec ('Spec labels a)---type KnownSpec :: Spec -> Constraint-class KnownSpec spec where-  specSing :: SSpec spec+type Spec :: Type -> Type+data Spec a = Spec+  { labels :: [String]+  , info :: TypeInformation (Unnullify a)+  , nullity :: Nullity a+  }  -instance-  ( KnownLabels labels-  , Sql DBType a-  )-  => KnownSpec ('Spec labels a)- where-  specSing = SSpec-    { labels = labelsSing-    , info = typeInformation-    , nullity = nullable-    }+specification :: Sql DBType a => Spec a+specification = Spec+  { labels = []+  , info = typeInformation+  , nullity = nullable+  }

@@ -1,89 +0,0 @@-{-# language ConstraintKinds #-}-{-# language DataKinds #-}-{-# language FlexibleInstances #-}-{-# language MultiParamTypeClasses #-}-{-# language NamedFieldPuns #-}-{-# language QuantifiedConstraints #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeFamilies #-}-{-# language UndecidableInstances #-}--module Rel8.Schema.Spec.ConstrainDBType-  ( ConstrainDBType-  , dbTypeNullity, dbTypeDict-  , nullifier, unnullifier-  )-where---- base-import Data.Kind ( Constraint, Type )-import Prelude---- rel8-import Rel8.Schema.Dict ( Dict( Dict ) )-import Rel8.Schema.Null-  ( Nullify, Unnullify-  , Nullity( Null, NotNull )-  , Sql, nullable-  )-import Rel8.Schema.Spec ( Spec( Spec ), SSpec( SSpec, nullity ) )---type ConstrainDBType :: (Type -> Constraint) -> Spec -> Constraint-class-  ( forall c labels a. ()-     => (spec ~ 'Spec labels a)-     => (forall x. (constraint x => c x)) => Sql c a-  )-  => ConstrainDBType constraint spec-instance-  ( spec ~ 'Spec labels a-  , Sql constraint a-  )-  => ConstrainDBType constraint spec---dbTypeNullity :: Dict (ConstrainDBType c) ('Spec l a) -> Nullity a-dbTypeNullity = step2 . step1-  where-    step1 :: Dict (ConstrainDBType c) ('Spec l a) -> Dict (Sql c) a-    step1 Dict = Dict--    step2 :: Dict (Sql c) a -> Nullity a-    step2 Dict = nullable---dbTypeDict :: Dict (ConstrainDBType c) ('Spec l a) -> Dict c (Unnullify a)-dbTypeDict = step2 . step1-  where-    step1 :: Dict (ConstrainDBType c) ('Spec l a) -> Dict (Sql c) a-    step1 Dict = Dict--    step2 :: Dict (Sql c) a -> Dict c (Unnullify a)-    step2 Dict = Dict---fromNullityDict :: Nullity a -> Dict c (Unnullify a) -> Dict (ConstrainDBType c) ('Spec l a)-fromNullityDict Null Dict = Dict-fromNullityDict NotNull Dict = Dict---nullifier :: ()-  => SSpec ('Spec labels a)-  -> Dict (ConstrainDBType c) ('Spec labels a)-  -> Dict (ConstrainDBType c) ('Spec labels (Nullify a))-nullifier SSpec {} dict = case dbTypeDict dict of-  Dict -> case dbTypeNullity dict of-    Null -> Dict-    NotNull -> Dict---unnullifier :: ()-  => SSpec ('Spec labels a)-  -> Dict (ConstrainDBType c) ('Spec labels (Nullify a))-  -> Dict (ConstrainDBType c) ('Spec labels a)-unnullifier SSpec {nullity} dict = case dbTypeDict dict of-  Dict -> case nullity of-    Null -> Dict-    NotNull -> case dbTypeNullity dict of-      Null -> fromNullityDict nullity Dict

@@ -1,15 +1,25 @@ {-# language DeriveFunctor #-} {-# language DerivingStrategies #-}+{-# language DisambiguateRecordFields #-}+{-# language NamedFieldPuns #-}  module Rel8.Schema.Table   ( TableSchema(..)+  , ppTable   ) where  -- base import Prelude +-- opaleye+import qualified Opaleye.Internal.HaskellDB.Sql as Opaleye+import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye +-- pretty+import Text.PrettyPrint ( Doc )++ -- | The schema for a table. This is used to specify the name and schema that a -- table belongs to (the @FROM@ part of a SQL query), along with the schema of -- the columns within this table.@@ -27,3 +37,10 @@     -- data type here, parameterized by the 'Rel8.ColumnSchema.ColumnSchema' functor.   }   deriving stock Functor+++ppTable :: TableSchema a -> Doc+ppTable TableSchema {name, schema} = Opaleye.ppTable Opaleye.SqlTable+  { sqlTableSchemaName = schema+  , sqlTableName = name+  }

@@ -1,40 +1,37 @@ {-# language DuplicateRecordFields #-} {-# language GADTs #-} {-# language NamedFieldPuns #-}-{-# language ScopedTypeVariables #-}+{-# language RankNTypes #-}+{-# language RecordWildCards #-} {-# language StandaloneKindSignatures #-}-{-# language TypeApplications #-}+{-# language StrictData #-}  module Rel8.Statement.Delete   ( Delete(..)   , delete+  , ppDelete   ) where  -- base-import Control.Exception ( throwIO ) import Data.Kind ( Type ) import Prelude  -- hasql-import Hasql.Connection ( Connection )-import qualified Hasql.Decoders as Hasql import qualified Hasql.Encoders as Hasql-import qualified Hasql.Session as Hasql import qualified Hasql.Statement as Hasql --- opaleye-import qualified Opaleye.Internal.Manipulation as Opaleye+-- pretty+import Text.PrettyPrint ( Doc, (<+>), ($$), text )  -- rel8 import Rel8.Expr ( Expr )-import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )+import Rel8.Query ( Query ) import Rel8.Schema.Name ( Selects )-import Rel8.Schema.Table ( TableSchema )-import Rel8.Statement.Returning ( Returning( NumberOfRowsAffected, Projection ) )-import Rel8.Table ( fromColumns, toColumns )-import Rel8.Table.Opaleye ( castTable, table, unpackspec )-import Rel8.Table.Serialize ( Serializable, parse )+import Rel8.Schema.Table ( TableSchema, ppTable )+import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning )+import Rel8.Statement.Using ( ppUsing )+import Rel8.Statement.Where ( ppWhere )  -- text import qualified Data.Text as Text@@ -47,7 +44,10 @@   Delete :: Selects names exprs =>     { from :: TableSchema names       -- ^ Which table to delete from.-    , deleteWhere :: exprs -> Expr Bool+    , using :: Query using+      -- ^ @USING@ clause — this can be used to join against other tables,+      -- and its results can be referenced in the @WHERE@ clause+    , deleteWhere :: using -> exprs -> Expr Bool       -- ^ Which rows should be selected for deletion.     , returning :: Returning names a       -- ^ What to return from the @DELETE@ statement.@@ -55,38 +55,25 @@     -> Delete a  --- | Run a @DELETE@ statement.-delete :: Connection -> Delete a -> IO a-delete c Delete {from, deleteWhere, returning} =-  case returning of-    NumberOfRowsAffected -> Hasql.run session c >>= either throwIO pure-      where-        session = Hasql.statement () statement-        statement = Hasql.Statement bytes params decode prepare-        bytes = encodeUtf8 $ Text.pack sql-        params = Hasql.noParams-        decode = Hasql.rowsAffected-        prepare = False-        sql = Opaleye.arrangeDeleteSql from' where'-          where-            from' = table $ toColumns <$> from-            where' = toColumn . toPrimExpr . deleteWhere . fromColumns+ppDelete :: Delete a -> Doc+ppDelete Delete {..} = case ppUsing using of+  Nothing ->+    text "DELETE FROM" <+> ppTable from $$+    text "WHERE false"+  Just (usingDoc, i) ->+    text "DELETE FROM" <+> ppTable from $$+    usingDoc $$+    ppWhere from (deleteWhere i) $$+    ppReturning from returning -    Projection project -> Hasql.run session c >>= either throwIO pure-      where-        session = Hasql.statement () statement-        statement = Hasql.Statement bytes params decode prepare-        bytes = encodeUtf8 $ Text.pack sql-        params = Hasql.noParams-        decode = decoder project-        prepare = False-        sql =-          Opaleye.arrangeDeleteReturningSql unpackspec from' where' project'-          where-            from' = table $ toColumns <$> from-            where' = toColumn . toPrimExpr . deleteWhere . fromColumns-            project' = castTable . toColumns . project . fromColumns++-- | Run a 'Delete' statement.+delete :: Delete a -> Hasql.Statement () a+delete d@Delete {returning} = Hasql.Statement bytes params decode prepare   where-    decoder :: forall exprs projection a. Serializable projection a-      => (exprs -> projection) -> Hasql.Result [a]-    decoder _ = Hasql.rowList (parse @projection @a)+    bytes = encodeUtf8 $ Text.pack sql+    params = Hasql.noParams+    decode = decodeReturning returning+    prepare = False+    sql = show doc+    doc = ppDelete d

@@ -1,64 +1,59 @@ {-# language DuplicateRecordFields #-}+{-# language FlexibleContexts #-} {-# language GADTs #-} {-# language NamedFieldPuns #-}-{-# language ScopedTypeVariables #-}+{-# language RecordWildCards #-} {-# language StandaloneKindSignatures #-}-{-# language TypeApplications #-}+{-# language StrictData #-}  module Rel8.Statement.Insert   ( Insert(..)-  , OnConflict(..)   , insert+  , ppInsert+  , ppInto   ) where  -- base-import Control.Exception ( throwIO )-import Data.List.NonEmpty ( NonEmpty( (:|) ) )+import Data.Foldable ( toList ) import Data.Kind ( Type ) import Prelude  -- hasql-import Hasql.Connection ( Connection )-import qualified Hasql.Decoders as Hasql import qualified Hasql.Encoders as Hasql-import qualified Hasql.Session as Hasql import qualified Hasql.Statement as Hasql  -- opaleye-import qualified Opaleye.Internal.Manipulation as Opaleye-import qualified Opaleye.Manipulation as Opaleye+import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye +-- pretty+import Text.PrettyPrint ( Doc, (<+>), ($$), parens, text )+ -- rel8-import Rel8.Schema.Name ( Selects )-import Rel8.Schema.Table ( TableSchema )-import Rel8.Statement.Returning ( Returning( Projection, NumberOfRowsAffected ) )-import Rel8.Table ( fromColumns, toColumns )-import Rel8.Table.Opaleye ( castTable, table, unpackspec )-import Rel8.Table.Serialize ( Serializable, parse )+import Rel8.Query ( Query )+import Rel8.Schema.Name ( Name, Selects, ppColumn )+import Rel8.Schema.Table ( TableSchema(..), ppTable )+import Rel8.Statement.OnConflict ( OnConflict, ppOnConflict )+import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning )+import Rel8.Statement.Select ( ppRows )+import Rel8.Table ( Table )+import Rel8.Table.Name ( showNames )  -- text import qualified Data.Text as Text ( pack ) import Data.Text.Encoding ( encodeUtf8 )  --- | @OnConflict@ allows you to add an @ON CONFLICT@ clause to an @INSERT@--- statement.-type OnConflict :: Type-data OnConflict-  = Abort     -- ^ @ON CONFLICT ABORT@-  | DoNothing -- ^ @ON CONFLICT DO NOTHING@-- -- | The constituent parts of a SQL @INSERT@ statement. type Insert :: Type -> Type data Insert a where   Insert :: Selects names exprs =>     { into :: TableSchema names       -- ^ Which table to insert into.-    , rows :: [exprs]-      -- ^ The rows to insert.-    , onConflict :: OnConflict+    , rows :: Query exprs+      -- ^ The rows to insert. This can be an arbitrary query — use+      -- 'Rel8.values' insert a static list of rows.+    , onConflict :: OnConflict names       -- ^ What to do if the inserted rows conflict with data already in the       -- table.     , returning :: Returning names a@@ -67,52 +62,28 @@     -> Insert a  --- | Run an @INSERT@ statement-insert :: Connection -> Insert a -> IO a-insert c Insert {into, rows, onConflict, returning} =-  case (rows, returning) of-    ([], NumberOfRowsAffected) -> pure 0-    ([], Projection _) -> pure []+ppInsert :: Insert a -> Doc+ppInsert Insert {..} =+  text "INSERT INTO" <+>+  ppInto into $$+  ppRows rows $$+  ppOnConflict into onConflict $$+  ppReturning into returning -    (x:xs, NumberOfRowsAffected) -> Hasql.run session c >>= either throwIO pure-      where-        session = Hasql.statement () statement-        statement = Hasql.Statement bytes params decode prepare-        bytes = encodeUtf8 $ Text.pack sql-        params = Hasql.noParams-        decode = Hasql.rowsAffected-        prepare = False-        sql = Opaleye.arrangeInsertManySql into' rows' onConflict'-          where-            into' = table $ toColumns <$> into-            rows' = toColumns <$> x :| xs -    (x:xs, Projection project) -> Hasql.run session c >>= either throwIO pure-      where-        session = Hasql.statement () statement-        statement = Hasql.Statement bytes params decode prepare-        bytes = encodeUtf8 $ Text.pack sql-        params = Hasql.noParams-        decode = decoder project-        prepare = False-        sql =-          Opaleye.arrangeInsertManyReturningSql-            unpackspec-            into'-            rows'-            project'-            onConflict'-          where-            into' = table $ toColumns <$> into-            rows' = toColumns <$> x :| xs-            project' = castTable . toColumns . project . fromColumns+ppInto :: Table Name a => TableSchema a -> Doc+ppInto table@TableSchema {columns} =+  ppTable table <+>+  parens (Opaleye.commaV ppColumn (toList (showNames columns))) -  where-    onConflict' =-      case onConflict of-        DoNothing -> Just Opaleye.DoNothing-        Abort     -> Nothing -    decoder :: forall exprs projection a. Serializable projection a-      => (exprs -> projection) -> Hasql.Result [a]-    decoder _ = Hasql.rowList (parse @projection @a)+-- | Run an 'Insert' statement.+insert :: Insert a -> Hasql.Statement () a+insert i@Insert {returning} = Hasql.Statement bytes params decode prepare+  where+    bytes = encodeUtf8 $ Text.pack sql+    params = Hasql.noParams+    decode = decodeReturning returning+    prepare = False+    sql = show doc+    doc = ppInsert i