packages feed

rel8 (empty) → 1.0.0.0

raw patch · 134 files changed

+14834/−0 lines, 134 filesdep +aesondep +basedep +bytestring

Dependencies added: aeson, base, bytestring, case-insensitive, containers, contravariant, hasql, hedgehog, lifted-base, monad-control, opaleye, profunctors, rel8, scientific, semialign, semigroupoids, tasty, tasty-hedgehog, text, these, time, tmp-postgres, transformers, uuid

Files

+ Changelog.md view
@@ -0,0 +1,3 @@+# 1.0.0.0 (2021-06-18)++* Initial release.
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright 2021 Oliver Charles++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,13 @@+# Welcome!++Welcome to Rel8! Rel8 is a Haskell library for interacting with PostgreSQL databases, built on top of the fantastic Opaleye library.++The main objectives of Rel8 are:++* *Conciseness*: Users using Rel8 should not need to write boiler-plate code. By using expressive types, we can provide sufficient information for the compiler to infer code whenever possible.++* *Inferrable*: Despite using a lot of type level magic, Rel8 aims to have excellent and predictable type inference.++* *Familiar*: writing Rel8 queries should feel like normal Haskell programming.++For more details, check out the [official documentation](https://rel8.readthedocs.io/en/latest/).
+ rel8.cabal view
@@ -0,0 +1,210 @@+cabal-version:       2.0+name:                rel8+version:             1.0.0.0+synopsis:            Hey! Hey! Can u rel8?+license:             BSD3+license-file:        LICENSE+author:              Oliver Charles+maintainer:          ollie@ocharles.org.uk+build-type:          Simple+extra-doc-files:+    README.md+    Changelog.md++library+  build-depends:+      aeson+    , base ^>= 4.14 || ^>=4.15+    , bytestring+    , case-insensitive+    , contravariant+    , hasql ^>= 1.4.5.1+    , opaleye ^>= 0.7.1.0+    , profunctors+    , scientific+    , semialign+    , semigroupoids+    , text+    , these+    , time+    , transformers+    , uuid+  default-language:+    Haskell2010+  ghc-options:+    -Weverything -Wno-unsafe -Wno-safe -Wno-missing-safe-haskell-mode+    -Wno-missing-import-lists -Wno-prepositive-qualified-module+    -Wno-monomorphism-restriction+    -Wno-missing-local-signatures+  hs-source-dirs:+    src+  exposed-modules:+    Rel8+    Rel8.Expr.Num+    Rel8.Expr.Text+    Rel8.Expr.Time++  other-modules:+    Rel8.Aggregate++    Rel8.Column+    Rel8.Column.ADT+    Rel8.Column.Either+    Rel8.Column.Lift+    Rel8.Column.List+    Rel8.Column.Maybe+    Rel8.Column.NonEmpty+    Rel8.Column.These++    Rel8.Expr+    Rel8.Expr.Aggregate+    Rel8.Expr.Array+    Rel8.Expr.Bool+    Rel8.Expr.Eq+    Rel8.Expr.Function+    Rel8.Expr.Null+    Rel8.Expr.Opaleye+    Rel8.Expr.Ord+    Rel8.Expr.Order+    Rel8.Expr.Sequence+    Rel8.Expr.Serialize++    Rel8.FCF++    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++    Rel8.Order++    Rel8.Query+    Rel8.Query.Aggregate+    Rel8.Query.Distinct+    Rel8.Query.Each+    Rel8.Query.Either+    Rel8.Query.Evaluate+    Rel8.Query.Exists+    Rel8.Query.Filter+    Rel8.Query.Limit+    Rel8.Query.List+    Rel8.Query.Maybe+    Rel8.Query.Null+    Rel8.Query.Opaleye+    Rel8.Query.Order+    Rel8.Query.Set+    Rel8.Query.SQL+    Rel8.Query.These+    Rel8.Query.Values++    Rel8.Schema.Context+    Rel8.Schema.Context.Label+    Rel8.Schema.Context.Nullify+    Rel8.Schema.Dict+    Rel8.Schema.HTable+    Rel8.Schema.HTable.Either+    Rel8.Schema.HTable.Identity+    Rel8.Schema.HTable.Label+    Rel8.Schema.HTable.List+    Rel8.Schema.HTable.MapTable+    Rel8.Schema.HTable.Maybe+    Rel8.Schema.HTable.NonEmpty+    Rel8.Schema.HTable.Nullify+    Rel8.Schema.HTable.Product+    Rel8.Schema.HTable.These+    Rel8.Schema.HTable.Vectorize+    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.Returning+    Rel8.Statement.Select+    Rel8.Statement.Update+    Rel8.Statement.View++    Rel8.Table+    Rel8.Table.ADT+    Rel8.Table.Aggregate+    Rel8.Table.Alternative+    Rel8.Table.Bool+    Rel8.Table.Either+    Rel8.Table.Eq+    Rel8.Table.HKD+    Rel8.Table.List+    Rel8.Table.Maybe+    Rel8.Table.Name+    Rel8.Table.NonEmpty+    Rel8.Table.Opaleye+    Rel8.Table.Ord+    Rel8.Table.Order+    Rel8.Table.Recontextualize+    Rel8.Table.Rel8able+    Rel8.Table.Serialize+    Rel8.Table.Tag+    Rel8.Table.These+    Rel8.Table.Undefined+    Rel8.Table.Unreify++    Rel8.Type+    Rel8.Type.Array+    Rel8.Type.Composite+    Rel8.Type.Eq+    Rel8.Type.Enum+    Rel8.Type.Information+    Rel8.Type.JSONEncoded+    Rel8.Type.JSONBEncoded+    Rel8.Type.Monoid+    Rel8.Type.Num+    Rel8.Type.Ord+    Rel8.Type.ReadShow+    Rel8.Type.Semigroup+    Rel8.Type.String+    Rel8.Type.Sum+    Rel8.Type.Tag++test-suite tests+  type:             exitcode-stdio-1.0+  build-depends:+      base+    , bytestring+    , case-insensitive+    , containers+    , hasql+    , hedgehog          ^>=1.0.2+    , lifted-base       ^>=0.2.3.12+    , monad-control     ^>=1.0.2.3+    , rel8+    , scientific+    , tasty+    , tasty-hedgehog+    , text+    , time+    , tmp-postgres      ^>=1.34.1.0+    , uuid++  main-is:          Main.hs+  hs-source-dirs:   tests+  default-language: Haskell2010+  ghc-options:+    -Weverything -Wno-unsafe -Wno-safe -Wno-missing-safe-haskell-mode+    -Wno-missing-import-lists -Wno-prepositive-qualified-module+    -Wno-deprecations -Wno-monomorphism-restriction+    -Wno-missing-local-signatures -Wno-implicit-prelude
+ src/Rel8.hs view
@@ -0,0 +1,364 @@+{-# language DuplicateRecordFields #-}++module Rel8+  ( -- * Database types+    -- ** @DBType@+    DBType(..)++    -- *** Deriving-via helpers+    -- **** @JSONEncoded@+  , JSONEncoded(..)+  , JSONBEncoded(..)++    -- **** @ReadShow@+  , ReadShow(..)++    -- **** Generic+  , Composite(..), DBComposite(..), compose, decompose+  , Enum(..), DBEnum(..), Enumable++    -- *** @TypeInformation@+  , TypeInformation(..)+  , mapTypeInformation+  , parseTypeInformation++    -- ** The @DBType@ hierarchy+  , DBSemigroup(..)+  , DBMonoid(..)+  , DBNum+  , DBIntegral+  , DBFractional+  , DBFloating++    -- * Tables and higher-kinded tables+  , Rel8able, KRel8able+  , Column+  , HADT+  , HEither+  , HMaybe+  , HList+  , HNonEmpty+  , HThese+  , Lift++  , Table(..)+  , HTable+  , Recontextualize+  , AltTable((<|>:))+  , AlternativeTable( emptyTable )+  , EqTable, (==:), (/=:)+  , OrdTable, ascTable, descTable+  , lit+  , bool+  , case_++    -- ** @MaybeTable@+  , MaybeTable+  , maybeTable, ($?), nothingTable, justTable+  , isNothingTable, isJustTable+  , optional+  , catMaybeTable+  , traverseMaybeTable+  , nameMaybeTable++    -- ** @EitherTable@+  , EitherTable+  , eitherTable, leftTable, rightTable+  , isLeftTable, isRightTable+  , keepLeftTable+  , keepRightTable+  , bitraverseEitherTable+  , nameEitherTable++    -- ** @TheseTable@+  , TheseTable+  , theseTable, thisTable, thatTable, thoseTable+  , isThisTable, isThatTable, isThoseTable+  , hasHereTable, hasThereTable+  , justHereTable, justThereTable+  , alignBy+  , keepHereTable, loseHereTable+  , keepThereTable, loseThereTable+  , keepThisTable, loseThisTable+  , keepThatTable, loseThatTable+  , keepThoseTable, loseThoseTable+  , bitraverseTheseTable+  , nameTheseTable++    -- ** @ListTable@+  , ListTable+  , listTable+  , nameListTable+  , many+  , manyExpr+  , catListTable+  , catList++    -- ** @NonEmptyTable@+  , NonEmptyTable+  , nonEmptyTable+  , nameNonEmptyTable+  , some+  , someExpr+  , catNonEmptyTable+  , catNonEmpty++    -- ** @ADT@+  , ADT, ADTable+  , BuildADT, buildADT+  , ConstructADT, constructADT+  , DeconstructADT, deconstructADT+  , NameADT, nameADT+  , AggregateADT, aggregateADT++    -- ** @HKD@+  , HKD, HKDable+  , BuildHKD, buildHKD+  , ConstructHKD, constructHKD+  , DeconstructHKD, deconstructHKD+  , NameHKD, nameHKD+  , AggregateHKD, aggregateHKD++    -- ** Table schemas+  , TableSchema(..)+  , Name+  , namesFromLabels+  , namesFromLabelsWith++    -- * Expressions+  , Expr+  , Sql+  , litExpr+  , unsafeCastExpr+  , unsafeLiteral++    -- ** @null@+  , NotNull+  , Nullable+  , null+  , nullify+  , nullable+  , isNull+  , isNonNull+  , mapNull+  , liftOpNull+  , catNull+  , coalesce++    -- ** Boolean operations+  , DBEq+  , true, false, not_+  , (&&.), and_+  , (||.), or_+  , (==.), (/=.), (==?), (/=?)+  , in_+  , boolExpr, caseExpr++    -- ** Ordering+  , DBOrd+  , (<.), (<=.), (>.), (>=.)+  , (<?), (<=?), (>?), (>=?)+  , leastExpr, greatestExpr++    -- ** Functions+  , Function+  , function+  , nullaryFunction+  , binaryOperator++    -- * Queries+  , Query+  , showQuery++    -- ** Selecting rows+  , Selects+  , each+  , values++    -- ** Filtering+  , filter+  , where_+  , whereExists+  , whereNotExists+  , distinct+  , distinctOn+  , distinctOnBy++    -- ** @LIMIT@/@OFFSET@+  , limit+  , offset++    -- ** @UNION@+  , union+  , unionAll++    -- ** @INTERSECT@+  , intersect+  , intersectAll++    -- ** @EXCEPT@+  , except+  , exceptAll++    -- ** @EXISTS@+  , exists+  , with+  , withBy+  , without+  , withoutBy++    -- ** Aggregation+  , Aggregate+  , Aggregates+  , aggregate+  , countRows+  , groupBy+  , listAgg, listAggExpr+  , nonEmptyAgg, nonEmptyAggExpr+  , DBMax, max+  , DBMin, min+  , DBSum, sum, sumWhere+  , DBString, stringAgg+  , count+  , countStar+  , countDistinct+  , countWhere+  , and+  , or++    -- ** Ordering+  , orderBy+  , Order+  , asc+  , desc+  , nullsFirst+  , nullsLast++    -- * IO+  , Serializable+  , ToExprs(..)+  , FromExprs+  , Result++    -- * Running statements+    -- ** @SELECT@+  , select++    -- ** @INSERT@+  , Insert(..)+  , OnConflict(..)+  , insert++    -- ** @DELETE@+  , Delete(..)+  , delete++    -- ** @UPDATE@+  , update+  , Update(..)++    -- ** @.. RETURNING@+  , Returning(..)++    -- ** @CREATE VIEW@+  , createView++    -- ** Sequences+  , nextval++  , Evaluate+  , eval+  , evaluate++    -- * Implementation details+  , Labelable+  , HKDT(..)+  ) where++-- base+import Prelude ()++-- rel8+import Rel8.Aggregate+import Rel8.Column+import Rel8.Column.ADT+import Rel8.Column.Either+import Rel8.Column.Lift+import Rel8.Column.List+import Rel8.Column.Maybe+import Rel8.Column.NonEmpty+import Rel8.Column.These+import Rel8.Expr+import Rel8.Expr.Aggregate+import Rel8.Expr.Bool+import Rel8.Expr.Eq+import Rel8.Expr.Function+import Rel8.Expr.Null+import Rel8.Expr.Opaleye (unsafeCastExpr, unsafeLiteral)+import Rel8.Expr.Ord+import Rel8.Expr.Order+import Rel8.Expr.Serialize+import Rel8.Expr.Sequence+import Rel8.Generic.Rel8able ( KRel8able, Rel8able )+import Rel8.Order+import Rel8.Query+import Rel8.Query.Aggregate+import Rel8.Query.Distinct+import Rel8.Query.Each+import Rel8.Query.Either+import Rel8.Query.Evaluate+import Rel8.Query.Exists+import Rel8.Query.Filter+import Rel8.Query.Limit+import Rel8.Query.List+import Rel8.Query.Maybe+import Rel8.Query.Null+import Rel8.Query.Order+import Rel8.Query.SQL (showQuery)+import Rel8.Query.Set+import Rel8.Query.These+import Rel8.Query.Values+import Rel8.Schema.Context.Label+import Rel8.Schema.HTable+import Rel8.Schema.Name+import Rel8.Schema.Null hiding ( nullable )+import Rel8.Schema.Result ( Result )+import Rel8.Schema.Table+import Rel8.Statement.Delete+import Rel8.Statement.Insert+import Rel8.Statement.Returning+import Rel8.Statement.Select+import Rel8.Statement.Update+import Rel8.Statement.View+import Rel8.Table+import Rel8.Table.ADT+import Rel8.Table.Aggregate+import Rel8.Table.Alternative+import Rel8.Table.Bool+import Rel8.Table.Either+import Rel8.Table.Eq+import Rel8.Table.HKD+import Rel8.Table.List+import Rel8.Table.Maybe+import Rel8.Table.Name+import Rel8.Table.NonEmpty+import Rel8.Table.Ord+import Rel8.Table.Order+import Rel8.Table.Recontextualize+import Rel8.Table.Rel8able ()+import Rel8.Table.Serialize+import Rel8.Table.These+import Rel8.Type+import Rel8.Type.Composite+import Rel8.Type.Eq+import Rel8.Type.Enum+import Rel8.Type.Information+import Rel8.Type.JSONBEncoded+import Rel8.Type.JSONEncoded+import Rel8.Type.Monoid+import Rel8.Type.Num+import Rel8.Type.Ord+import Rel8.Type.ReadShow+import Rel8.Type.Semigroup+import Rel8.Type.String+import Rel8.Type.Sum
+ src/Rel8/Aggregate.hs view
@@ -0,0 +1,155 @@+{-# language DataKinds #-}+{-# language DerivingVia #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language GADTs #-}+{-# language MultiParamTypeClasses #-}+{-# language NamedFieldPuns #-}+{-# language PolyKinds #-}+{-# 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.Kind ( Constraint, Type )+import Prelude++-- opaleye+import qualified Opaleye.Internal.Aggregate as Opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye+import qualified Opaleye.Internal.PackMap as Opaleye++-- 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.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+  )+import Rel8.Table.Recontextualize ( Recontextualize )+import Rel8.Type ( DBType )+++-- | An @Aggregate a@ describes how to aggregate @Table@s of type @a@. You can+-- unpack an @Aggregate@ back to @a@ by running it with 'Rel8.aggregate'. As+-- @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)+++instance Sql DBType a => Table Aggregate (Aggregate a) where+  type Columns (Aggregate a) = HType 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)+++instance Labelable Aggregate where+  labeler (A aggregate) = A aggregate+  unlabeler (A aggregate) = A aggregate+++-- | @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+++foldInputs :: Monoid b+  => (Maybe Aggregator -> Opaleye.PrimExpr -> b) -> Aggregate a -> b+foldInputs f (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =+  getConst $ flip agg () $ \(aggregator, a) ->+    Const $ f (detuplize <$> aggregator) a+  where+    detuplize (operation, ordering, distinction) =+      Aggregator {operation, ordering, distinction}+++mapInputs :: ()+  => (Opaleye.PrimExpr -> Opaleye.PrimExpr) -> Aggregate a -> Aggregate a+mapInputs transform (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =+  Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ agg . \f input ->+    f (fmap transform input)+++type Aggregator :: Type+data Aggregator = Aggregator+  { operation :: Opaleye.AggrOp+  , ordering :: [Opaleye.OrderExpr]+  , distinction :: Opaleye.AggrDistinct+  }+++unsafeMakeAggregate :: ()+  => (Expr input -> Opaleye.PrimExpr)+  -> (Opaleye.PrimExpr -> Expr output)+  -> Maybe Aggregator+  -> Expr input+  -> Aggregate output+unsafeMakeAggregate input output aggregator expr =+  Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ \f _ ->+    output <$> f (tuplize <$> aggregator, input expr)+  where+    tuplize Aggregator {operation, ordering, distinction} =+      (operation, ordering, distinction)
+ src/Rel8/Column.hs view
@@ -0,0 +1,103 @@+{-# language DataKinds #-}+{-# language FlexibleContexts #-}+{-# language LambdaCase #-}+{-# language MultiParamTypeClasses #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeFamilies #-}++module Rel8.Column+  ( Column, AColumn(..)+  , TColumn+  )+where++-- base+import Data.Kind ( Type )+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 )+++-- | This type family is used to specify columns in 'Rel8able's. In @Column f+-- a@, @f@ is the context of the column (which should be left polymorphic in+-- '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)+++data TColumn :: K.Context -> Type -> Exp Type+type instance Eval (TColumn f a) = Column f a
+ src/Rel8/Column/ADT.hs view
@@ -0,0 +1,88 @@+{-# language DataKinds #-}+{-# language LambdaCase #-}+{-# language MultiParamTypeClasses #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeFamilies #-}+{-# language UndecidableInstances #-}++module Rel8.Column.ADT+  ( HADT, AHADT(..)+  )+where++-- base+import Data.Kind ( Type )+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 )+++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)
+ src/Rel8/Column/Either.hs view
@@ -0,0 +1,162 @@+{-# language DataKinds #-}+{-# language FlexibleContexts #-}+{-# language LambdaCase #-}+{-# language MultiParamTypeClasses #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeFamilies #-}+{-# language UndecidableInstances #-}++module Rel8.Column.Either+  ( HEither, AHEither(..)+  )+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+  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)
+ src/Rel8/Column/Lift.hs view
@@ -0,0 +1,87 @@+{-# language DataKinds #-}+{-# language LambdaCase #-}+{-# language MultiParamTypeClasses #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeFamilies #-}++module Rel8.Column.Lift+  ( Lift, ALift(..)+  )+where++-- base+import Data.Kind ( Type )+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 )+++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
+ src/Rel8/Column/List.hs view
@@ -0,0 +1,145 @@+{-# language DataKinds #-}+{-# language FlexibleContexts #-}+{-# language LambdaCase #-}+{-# language MultiParamTypeClasses #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeFamilies #-}+{-# language UndecidableInstances #-}++module Rel8.Column.List+  ( HList, AHList(..)+  )+where++-- base+import Data.Kind ( Type )+import Data.Type.Equality ( (:~:)( Refl ) )+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 )+++-- | 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+  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
+ src/Rel8/Column/Maybe.hs view
@@ -0,0 +1,127 @@+{-# language DataKinds #-}+{-# language FlexibleContexts #-}+{-# language GADTs #-}+{-# language LambdaCase #-}+{-# language MultiParamTypeClasses #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeFamilies #-}+{-# language UndecidableInstances #-}++module Rel8.Column.Maybe+  ( HMaybe, AHMaybe(..)+  )+where++-- base+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.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+  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)
+ src/Rel8/Column/NonEmpty.hs view
@@ -0,0 +1,148 @@+{-# language DataKinds #-}+{-# language FlexibleContexts #-}+{-# language LambdaCase #-}+{-# language MultiParamTypeClasses #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeFamilies #-}+{-# language UndecidableInstances #-}++module Rel8.Column.NonEmpty+  ( HNonEmpty, AHNonEmpty(..)+  )+where++-- base+import Data.Kind ( Type )+import Data.List.NonEmpty ( NonEmpty )+import Data.Type.Equality ( (:~:)( Refl ) )+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 )+++-- | 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+  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
+ src/Rel8/Column/These.hs view
@@ -0,0 +1,166 @@+{-# language DataKinds #-}+{-# language FlexibleContexts #-}+{-# language GADTs #-}+{-# language LambdaCase #-}+{-# language MultiParamTypeClasses #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeFamilies #-}+{-# language UndecidableInstances #-}++module Rel8.Column.These+  ( HThese, AHThese(..)+  )+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.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+import Data.These ( These )+++-- | Nest an 'These' value within a 'Rel8able'. @HThese f a b@ will produce a+-- '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+  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)
+ src/Rel8/Expr.hs view
@@ -0,0 +1,155 @@+{-# 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.String ( IsString, fromString )+import Prelude hiding ( null )++-- opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye++-- rel8+import Rel8.Expr.Function ( function, nullaryFunction )+import Rel8.Expr.Null ( liftOpNull, nullify )+import Rel8.Expr.Opaleye+  ( castExpr+  , fromPrimExpr+  , mapPrimExpr+  , 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.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+  )+import Rel8.Table.Recontextualize ( Recontextualize )+import Rel8.Type ( DBType )+import Rel8.Type.Monoid ( DBMonoid, memptyExpr )+import Rel8.Type.Num ( DBFloating, DBFractional, DBNum )+import Rel8.Type.Semigroup ( DBSemigroup, (<>.) )+++-- | 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)+++instance Sql DBSemigroup a => Semigroup (Expr a) where+  (<>) = case nullable @a of+    Null -> liftOpNull (<>.)+    NotNull -> (<>.)+  {-# INLINABLE (<>) #-}+++instance Sql DBMonoid a => Monoid (Expr a) where+  mempty = case nullable @a of+    Null -> nullify memptyExpr+    NotNull -> memptyExpr+  {-# INLINABLE mempty #-}+++instance (Sql IsString a, Sql DBType a) => IsString (Expr a) where+  fromString = litExpr . case nullable @a of+    Null -> Just . fromString+    NotNull -> fromString+++instance Sql DBNum a => Num (Expr a) where+  (+) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:+))+  (*) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:*))+  (-) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:-))++  abs = mapPrimExpr (Opaleye.UnExpr Opaleye.OpAbs)+  negate = mapPrimExpr (Opaleye.UnExpr Opaleye.OpNegate)++  signum = castExpr . mapPrimExpr (Opaleye.UnExpr (Opaleye.UnOpOther "SIGN"))++  fromInteger = castExpr . fromPrimExpr . Opaleye.ConstExpr . Opaleye.IntegerLit+++instance Sql DBFractional a => Fractional (Expr a) where+  (/) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:/))++  fromRational =+    castExpr . Expr . Opaleye.ConstExpr . Opaleye.NumericLit . realToFrac+++instance Sql DBFloating a => Floating (Expr a) where+  pi = nullaryFunction "PI"+  exp = function "exp"+  log = function "ln"+  sqrt = function "sqrt"+  (**) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:^))+  logBase = function "log"+  sin = function "sin"+  cos = function "cos"+  tan = function "tan"+  asin = function "asin"+  acos = function "acos"+  atan = function "atan"+  sinh = function "sinh"+  cosh = function "cosh"+  tanh = function "tanh"+  asinh = function "asinh"+  acosh = function "acosh"+  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 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)+++instance Labelable Expr where+  labeler (E a) = E a+  unlabeler (E a) = E a
+ src/Rel8/Expr.hs-boot view
@@ -0,0 +1,22 @@+{-# language GADTs #-}+{-# language PolyKinds #-}+{-# language RoleAnnotations #-}+{-# language StandaloneKindSignatures #-}++module Rel8.Expr+  ( Expr(..)+  )+where++-- base+import Data.Kind ( Type )+import Prelude ()++-- opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye+++type role Expr representational+type Expr :: k -> Type+data Expr a where+  Expr :: k ~ Type => !Opaleye.PrimExpr -> Expr (a :: k)
+ src/Rel8/Expr/Aggregate.hs view
@@ -0,0 +1,189 @@+{-# language DataKinds #-}+{-# language FlexibleContexts #-}+{-# language ScopedTypeVariables #-}+{-# language TypeFamilies #-}++{-# options_ghc -fno-warn-redundant-constraints #-}++module Rel8.Expr.Aggregate+  ( count, countDistinct, countStar, countWhere+  , and, or+  , min, max+  , sum, sumWhere+  , stringAgg+  , groupByExpr+  , listAggExpr, nonEmptyAggExpr+  , slistAggExpr, snonEmptyAggExpr+  )+where++-- base+import Data.Int ( Int64 )+import Data.List.NonEmpty ( NonEmpty )+import Prelude hiding ( and, max, min, null, or, sum )++-- opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye++-- rel8+import Rel8.Aggregate ( Aggregate, Aggregator(..), unsafeMakeAggregate )+import Rel8.Expr ( Expr )+import Rel8.Expr.Bool ( caseExpr )+import Rel8.Expr.Opaleye+  ( castExpr+  , fromPrimExpr+  , fromPrimExpr+  , toPrimExpr+  )+import Rel8.Expr.Null ( null )+import Rel8.Expr.Serialize ( litExpr )+import Rel8.Schema.Null ( Sql, Unnullify )+import Rel8.Type ( DBType, typeInformation )+import Rel8.Type.Array ( encodeArrayElement )+import Rel8.Type.Eq ( DBEq )+import Rel8.Type.Information ( TypeInformation )+import Rel8.Type.Num ( DBNum )+import Rel8.Type.Ord ( DBMax, DBMin )+import Rel8.Type.String ( DBString )+import Rel8.Type.Sum ( DBSum )+++-- | Count the occurances of a single column. Corresponds to @COUNT(a)@+count :: Expr a -> Aggregate Int64+count = unsafeMakeAggregate toPrimExpr fromPrimExpr $+  Just Aggregator+    { operation = Opaleye.AggrCount+    , ordering = []+    , distinction = Opaleye.AggrAll+    }+++-- | Count the number of distinct occurances of a single column. Corresponds to+-- @COUNT(DISTINCT a)@+countDistinct :: Sql DBEq a => Expr a -> Aggregate Int64+countDistinct = unsafeMakeAggregate toPrimExpr fromPrimExpr $+  Just Aggregator+    { operation = Opaleye.AggrCount+    , ordering = []+    , distinction = Opaleye.AggrDistinct+    }+++-- | Corresponds to @COUNT(*)@.+countStar :: Aggregate Int64+countStar = count (litExpr True)+++-- | A count of the number of times a given expression is @true@.+countWhere :: Expr Bool -> Aggregate Int64+countWhere condition = count (caseExpr [(condition, litExpr (Just True))] null)+++-- | Corresponds to @bool_and@.+and :: Expr Bool -> Aggregate Bool+and = unsafeMakeAggregate toPrimExpr fromPrimExpr $+  Just Aggregator+    { operation = Opaleye.AggrBoolAnd+    , ordering = []+    , distinction = Opaleye.AggrAll+    }+++-- | Corresponds to @bool_or@.+or :: Expr Bool -> Aggregate Bool+or = unsafeMakeAggregate toPrimExpr fromPrimExpr $+  Just Aggregator+    { operation = Opaleye.AggrBoolOr+    , ordering = []+    , distinction = Opaleye.AggrAll+    }+++-- | Produce an aggregation for @Expr a@ using the @max@ function.+max :: Sql DBMax a => Expr a -> Aggregate a+max = unsafeMakeAggregate toPrimExpr fromPrimExpr $+  Just Aggregator+    { operation = Opaleye.AggrMax+    , ordering = []+    , distinction = Opaleye.AggrAll+    }+++-- | Produce an aggregation for @Expr a@ using the @max@ function.+min :: Sql DBMin a => Expr a -> Aggregate a+min = unsafeMakeAggregate toPrimExpr fromPrimExpr $+  Just Aggregator+    { operation = Opaleye.AggrMin+    , ordering = []+    , distinction = Opaleye.AggrAll+    }++-- | Corresponds to @sum@. Note that in SQL, @sum@ is type changing - for+-- example the @sum@ of @integer@ returns a @bigint@. Rel8 doesn't support+-- this, and will add explicit cast back to the original input type. This can+-- lead to overflows, and if you anticipate very large sums, you should upcast+-- your input.+sum :: Sql DBSum a => Expr a -> Aggregate a+sum = unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) $+  Just Aggregator+    { operation = Opaleye.AggrSum+    , ordering = []+    , distinction = Opaleye.AggrAll+    }+++-- | Take the sum of all expressions that satisfy a predicate.+sumWhere :: (Sql DBNum a, Sql DBSum a)+  => Expr Bool -> Expr a -> Aggregate a+sumWhere condition a = sum (caseExpr [(condition, a)] 0)+++-- | Corresponds to @string_agg()@.+stringAgg :: Sql DBString a+  => Expr db -> Expr a -> Aggregate a+stringAgg delimiter =+  unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) $+    Just Aggregator+      { operation = Opaleye.AggrStringAggr (toPrimExpr delimiter)+      , ordering = []+      , distinction = Opaleye.AggrAll+      }+++-- | Aggregate a value by grouping by it.+groupByExpr :: Sql DBEq a => Expr a -> Aggregate a+groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Nothing+++-- | Collect expressions values as a list.+listAggExpr :: Sql DBType a => Expr a -> Aggregate [a]+listAggExpr = slistAggExpr typeInformation+++-- | Collect expressions values as a non-empty list.+nonEmptyAggExpr :: Sql DBType a => Expr a -> Aggregate (NonEmpty a)+nonEmptyAggExpr = snonEmptyAggExpr typeInformation+++slistAggExpr :: ()+  => TypeInformation (Unnullify a) -> Expr a -> Aggregate [a]+slistAggExpr info = unsafeMakeAggregate to fromPrimExpr $ Just+  Aggregator+    { operation = Opaleye.AggrArr+    , ordering = []+    , distinction = Opaleye.AggrAll+    }+  where+    to = encodeArrayElement info . toPrimExpr+++snonEmptyAggExpr :: ()+  => TypeInformation (Unnullify a) -> Expr a -> Aggregate (NonEmpty a)+snonEmptyAggExpr info = unsafeMakeAggregate to fromPrimExpr $ Just+  Aggregator+    { operation = Opaleye.AggrArr+    , ordering = []+    , distinction = Opaleye.AggrAll+    }+  where+    to = encodeArrayElement info . toPrimExpr
+ src/Rel8/Expr/Array.hs view
@@ -0,0 +1,58 @@+{-# language DataKinds #-}+{-# language FlexibleContexts #-}+{-# language TypeFamilies #-}++{-# options_ghc -fno-warn-redundant-constraints #-}++module Rel8.Expr.Array+  ( listOf, nonEmptyOf+  , slistOf, snonEmptyOf+  , sappend, sappend1, sempty+  )+where++-- base+import Data.List.NonEmpty ( NonEmpty )+import Prelude++-- opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye++-- rel8+import {-# SOURCE #-} Rel8.Expr ( Expr )+import Rel8.Expr.Opaleye+  ( fromPrimExpr, toPrimExpr+  , zipPrimExprsWith+  )+import Rel8.Type ( DBType, typeInformation )+import Rel8.Type.Array ( array )+import Rel8.Type.Information ( TypeInformation(..) )+import Rel8.Schema.Null ( Unnullify, Sql )+++sappend :: Expr [a] -> Expr [a] -> Expr [a]+sappend = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))+++sappend1 :: Expr (NonEmpty a) -> Expr (NonEmpty a) -> Expr (NonEmpty a)+sappend1 = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))+++sempty :: TypeInformation (Unnullify a) -> Expr [a]+sempty info = fromPrimExpr $ array info []+++slistOf :: TypeInformation (Unnullify a) -> [Expr a] -> Expr [a]+slistOf info = fromPrimExpr . array info . fmap toPrimExpr+++snonEmptyOf :: TypeInformation (Unnullify a) -> NonEmpty (Expr a) -> Expr (NonEmpty a)+snonEmptyOf info = fromPrimExpr . array info . fmap toPrimExpr+++listOf :: Sql DBType a => [Expr a] -> Expr [a]+listOf = slistOf typeInformation+++nonEmptyOf :: Sql DBType a => NonEmpty (Expr a) -> Expr (NonEmpty a)+nonEmptyOf = snonEmptyOf typeInformation
+ src/Rel8/Expr/Bool.hs view
@@ -0,0 +1,90 @@+{-# language GADTs #-}++module Rel8.Expr.Bool+  ( false, true+  , (&&.), (||.), not_+  , and_, or_+  , boolExpr+  , caseExpr+  , coalesce+  )+where++-- base+import Data.Foldable ( foldl' )+import Prelude hiding ( null )++-- opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye++-- rel8+import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )+import Rel8.Expr.Opaleye ( mapPrimExpr, toPrimExpr, zipPrimExprsWith )+import Rel8.Expr.Serialize ( litExpr )+++-- | The SQL @false@ literal.+false :: Expr Bool+false = litExpr False+++-- | The SQL @true@ literal.+true :: Expr Bool+true = litExpr True+++-- | The SQL @AND@ operator.+(&&.) :: Expr Bool -> Expr Bool -> Expr Bool+(&&.) = zipPrimExprsWith (Opaleye.BinExpr Opaleye.OpAnd)+infixr 3 &&.+++-- | The SQL @OR@ operator.+(||.) :: Expr Bool -> Expr Bool -> Expr Bool+(||.) = zipPrimExprsWith (Opaleye.BinExpr Opaleye.OpOr)+infixr 2 ||.+++-- | The SQL @NOT@ operator.+not_ :: Expr Bool -> Expr Bool+not_ = mapPrimExpr (Opaleye.UnExpr Opaleye.OpNot)+++-- | Fold @AND@ over a collection of expressions.+and_ :: Foldable f => f (Expr Bool) -> Expr Bool+and_ = foldl' (&&.) true+++-- | Fold @OR@ over a collection of expressions.+or_ :: Foldable f => f (Expr Bool) -> Expr Bool+or_ = foldl' (||.) false+++-- | Eliminate a boolean-valued expression.+--+-- Corresponds to 'Data.Bool.bool'.+boolExpr :: Expr a -> Expr a -> Expr Bool -> Expr a+boolExpr ifFalse ifTrue condition = caseExpr [(condition, ifTrue)] ifFalse+++-- | A multi-way if/then/else statement. The first argument to @caseExpr@ is a+-- list of alternatives. The first alternative that is of the form @(true, x)@+-- will be returned. If no such alternative is found, a fallback expression is+-- returned.+--+-- Corresponds to a @CASE@ expression in SQL.+caseExpr :: [(Expr Bool, Expr a)] -> Expr a -> Expr a+caseExpr branches (Expr fallback) =+  Expr $ Opaleye.CaseExpr (map go branches) fallback+  where+    go (condition, value) = (toPrimExpr condition, toPrimExpr value)+++-- | Convert a @Expr (Maybe Bool)@ to a @Expr Bool@ by treating @Nothing@ as+-- @False@. This can be useful when combined with 'Rel8.where_', which expects+-- a @Bool@, and produces expressions that optimize better than general case+-- analysis.+coalesce :: Expr (Maybe Bool) -> Expr Bool+coalesce (Expr a) = Expr a &&. Expr (Opaleye.FunExpr "COALESCE" [a, untrue])+  where+    untrue = Opaleye.ConstExpr (Opaleye.BoolLit False)
+ src/Rel8/Expr/Eq.hs view
@@ -0,0 +1,101 @@+{-# language FlexibleContexts #-}+{-# language GADTs #-}+{-# language ScopedTypeVariables #-}+{-# language TypeApplications #-}+{-# language ViewPatterns #-}++{-# options_ghc -fno-warn-redundant-constraints #-}++module Rel8.Expr.Eq+  ( (==.), (/=.)+  , (==?), (/=?)+  , in_+  )+where++-- base+import Data.Foldable ( toList )+import Data.List.NonEmpty ( nonEmpty )+import Prelude++-- opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye++-- rel8+import {-# SOURCE #-} Rel8.Expr ( Expr )+import Rel8.Expr.Bool ( (&&.), (||.), false, or_, coalesce )+import Rel8.Expr.Null ( isNull, unsafeLiftOpNull )+import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr, zipPrimExprsWith )+import Rel8.Schema.Null ( Nullity( NotNull, Null ), Sql, nullable )+import Rel8.Type.Eq ( DBEq )+++eq :: DBEq a => Expr a -> Expr a -> Expr Bool+eq = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:==))+++ne :: DBEq a => Expr a -> Expr a -> Expr Bool+ne = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:<>))+++-- | Compare two expressions for equality. +--+-- This corresponds to the SQL @IS NOT DISTINCT FROM@ operator, and will equate+-- @null@ values as @true@. This differs from @=@ which would return @null@.+-- This operator matches Haskell's '==' operator. For an operator identical to+-- SQL @=@, see '==?'.+(==.) :: forall a. Sql DBEq a => Expr a -> Expr a -> Expr Bool+(==.) = case nullable @a of+  Null -> \ma mb -> isNull ma &&. isNull mb ||. ma ==? mb+  NotNull -> eq+infix 4 ==.+{-# INLINABLE (==.) #-}+++-- | Test if two expressions are different (not equal).+--+-- This corresponds to the SQL @IS DISTINCT FROM@ operator, and will return+-- @false@ when comparing two @null@ values. This differs from ordinary @=@+-- which would return @null@. This operator is closer to Haskell's '=='+-- operator. For an operator identical to SQL @=@, see '/=?'.+(/=.) :: forall a. Sql DBEq a => Expr a -> Expr a -> Expr Bool+(/=.) = case nullable @a of+  Null -> \ma mb -> isNull ma `ne` isNull mb ||. ma /=? mb+  NotNull -> ne+infix 4 /=.+{-# INLINABLE (/=.) #-}+++-- | Test if two expressions are equal. This operator is usually the best+-- choice when forming join conditions, as PostgreSQL has a much harder time+-- optimizing a join that has multiple 'True' conditions.+--+-- This corresponds to the SQL @=@ operator, though it will always return a+-- 'Bool'.+(==?) :: DBEq a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool+a ==? b = coalesce $ unsafeLiftOpNull eq a b+infix 4 ==?+++-- | Test if two expressions are different. +--+-- This corresponds to the SQL @<>@ operator, though it will always return a+-- 'Bool'.+(/=?) :: DBEq a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool+a /=? b = coalesce $ unsafeLiftOpNull ne a b+infix 4 /=?+++-- | Like the SQL @IN@ operator, but implemented by folding over a list with+-- '==.' and '||.'.+in_ :: forall a f. (Sql DBEq a, Foldable f)+  => Expr a -> f (Expr a) -> Expr Bool+in_ a (toList -> as) = case nullable @a of+  Null -> or_ $ map (a ==.) as+  NotNull -> case nonEmpty as of+     Nothing -> false+     Just xs ->+       fromPrimExpr $+         Opaleye.BinExpr Opaleye.OpIn+           (toPrimExpr a)+           (Opaleye.ListExpr (toPrimExpr <$> xs))
+ src/Rel8/Expr/Function.hs view
@@ -0,0 +1,63 @@+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language MultiParamTypeClasses #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeFamilies #-}+{-# language UndecidableInstances #-}++module Rel8.Expr.Function+  ( Function, function+  , nullaryFunction+  , binaryOperator+  )+where++-- base+import Data.Kind ( Constraint, Type )+import Prelude++-- opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye++-- rel8+import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )+import Rel8.Expr.Opaleye+  ( castExpr+  , fromPrimExpr, toPrimExpr, zipPrimExprsWith+  )+import Rel8.Schema.Null ( Sql )+import Rel8.Type ( DBType )+++-- | This type class exists to allow 'function' to have arbitrary arity. It's+-- mostly an implementation detail, and typical uses of 'Function' shouldn't+-- need this to be specified.+type Function :: Type -> Type -> Constraint+class Function arg res where+  applyArgument :: ([Opaleye.PrimExpr] -> Opaleye.PrimExpr) -> arg -> res+++instance (arg ~ Expr a, Sql DBType b) => Function arg (Expr b) where+  applyArgument f a = castExpr $ fromPrimExpr $ f [toPrimExpr a]+++instance (arg ~ Expr a, Function args res) => Function arg (args -> res) where+  applyArgument f a = applyArgument (f . (toPrimExpr a :))+++-- | Construct an n-ary function that produces an 'Expr' that when called runs+-- a SQL function.+function :: Function args result => String -> args -> result+function = applyArgument . Opaleye.FunExpr+++-- | Construct a function call for functions with no arguments.+nullaryFunction :: Sql DBType a => String -> Expr a+nullaryFunction name = castExpr $ Expr (Opaleye.FunExpr name [])+++-- | Construct an expression by applying an infix binary operator to two+-- operands.+binaryOperator :: Sql DBType c => String -> Expr a -> Expr b -> Expr c+binaryOperator operator a b =+  castExpr $ zipPrimExprsWith (Opaleye.BinExpr (Opaleye.OpOther operator)) a b
+ src/Rel8/Expr/Null.hs view
@@ -0,0 +1,102 @@+{-# language DataKinds #-}+{-# language FlexibleContexts #-}+{-# language TypeFamilies #-}++{-# options -fno-warn-redundant-constraints #-}++module Rel8.Expr.Null+  ( null, snull, nullableExpr, nullableOf+  , isNull, isNonNull+  , nullify, unsafeUnnullify+  , mapNull, liftOpNull+  , unsafeMapNull, unsafeLiftOpNull+  )+where++-- base+import Prelude hiding ( null )++-- opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye++-- rel8+import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )+import Rel8.Expr.Bool ( (||.), boolExpr )+import Rel8.Expr.Opaleye ( scastExpr, mapPrimExpr )+import Rel8.Schema.Null ( NotNull )+import Rel8.Type ( DBType, typeInformation )+import Rel8.Type.Information ( TypeInformation )+++-- | Lift an expression that can't be @null@ to a type that might be @null@.+-- This is an identity operation in terms of any generated query, and just+-- modifies the query's type.+nullify :: NotNull a => Expr a -> Expr (Maybe a)+nullify (Expr a) = Expr a+++unsafeUnnullify :: Expr (Maybe a) -> Expr a+unsafeUnnullify (Expr a) = Expr a+++-- | Like 'maybe', but to eliminate @null@.+nullableExpr :: Expr b -> (Expr a -> Expr b) -> Expr (Maybe a) -> Expr b+nullableExpr b f ma = boolExpr (f (unsafeUnnullify ma)) b (isNull ma)+++nullableOf :: DBType a => Maybe (Expr a) -> Expr (Maybe a)+nullableOf = maybe null nullify+++-- | Like 'Data.Maybe.isNothing', but for @null@.+isNull :: Expr (Maybe a) -> Expr Bool+isNull = mapPrimExpr (Opaleye.UnExpr Opaleye.OpIsNull)+++-- | Like 'Data.Maybe.isJust', but for @null@.+isNonNull :: Expr (Maybe a) -> Expr Bool+isNonNull = mapPrimExpr (Opaleye.UnExpr Opaleye.OpIsNotNull)+++-- | Lift an operation on non-@null@ values to an operation on possibly @null@+-- values. When given @null@, @mapNull f@ returns @null@.+-- +-- This is like 'fmap' for 'Maybe'.+mapNull :: DBType b+  => (Expr a -> Expr b) -> Expr (Maybe a) -> Expr (Maybe b)+mapNull f ma = boolExpr (unsafeMapNull f ma) null (isNull ma)+++-- | Lift a binary operation on non-@null@ expressions to an equivalent binary+-- operator on possibly @null@ expressions. If either of the final arguments+-- are @null@, @liftOpNull@ returns @null@.+--+-- This is like 'liftA2' for 'Maybe'.+liftOpNull :: DBType c+  => (Expr a -> Expr b -> Expr c)+  -> Expr (Maybe a) -> Expr (Maybe b) -> Expr (Maybe c)+liftOpNull f ma mb =+  boolExpr (unsafeLiftOpNull f ma mb) null+    (isNull ma ||. isNull mb)+{-# INLINABLE liftOpNull #-}+++snull :: TypeInformation a -> Expr (Maybe a)+snull info = scastExpr info $ Expr $ Opaleye.ConstExpr Opaleye.NullLit+++-- | Corresponds to SQL @null@.+null :: DBType a => Expr (Maybe a)+null = snull typeInformation+++unsafeMapNull :: NotNull b+  => (Expr a -> Expr b) -> Expr (Maybe a) -> Expr (Maybe b)+unsafeMapNull f ma = nullify (f (unsafeUnnullify ma))+++unsafeLiftOpNull :: NotNull c+  => (Expr a -> Expr b -> Expr c)+  -> Expr (Maybe a) -> Expr (Maybe b) -> Expr (Maybe c)+unsafeLiftOpNull f ma mb =+  nullify (f (unsafeUnnullify ma) (unsafeUnnullify mb))
+ src/Rel8/Expr/Num.hs view
@@ -0,0 +1,77 @@+{-# language FlexibleContexts #-}+{-# language TypeFamilies #-}++{-# options_ghc -fno-warn-redundant-constraints #-}++module Rel8.Expr.Num+  ( fromIntegral, realToFrac, div, mod, ceiling, floor, round, truncate+  )+where++-- base+import Prelude ()++-- rel+import Rel8.Expr ( Expr( Expr ) )+import Rel8.Expr.Function ( function )+import Rel8.Expr.Opaleye ( castExpr )+import Rel8.Schema.Null ( Homonullable, Sql )+import Rel8.Type.Num ( DBFractional, DBIntegral, DBNum )+++-- | Cast 'DBIntegral' types to 'DBNum' types. For example, this can be useful+-- if you need to turn an @Expr Int32@ into an @Expr Double@.+fromIntegral :: (Sql DBIntegral a, Sql DBNum b, Homonullable a b)+  => Expr a -> Expr b+fromIntegral (Expr a) = castExpr (Expr a)+++-- | Cast 'DBNum' types to 'DBFractional' types. For example, his can be useful+-- to convert @Expr Float@ to @Expr Double@.+realToFrac :: (Sql DBNum a, Sql DBFractional b, Homonullable a b)+  => Expr a -> Expr b+realToFrac (Expr a) = castExpr (Expr a)+++-- | Round a 'DBFractional' to a 'DBIntegral' by rounding to the nearest larger+-- integer.+--+-- Corresponds to the @ceiling()@ function.+ceiling :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b)+  => Expr a -> Expr b+ceiling = function "ceiling"+++-- | Perform integral division. Corresponds to the @div()@ function.+div :: Sql DBIntegral a => Expr a -> Expr a -> Expr a+div = function "div"+++-- | Corresponds to the @mod()@ function.+mod :: Sql DBIntegral a => Expr a -> Expr a -> Expr a+mod = function "mod"+++-- | Round a 'DFractional' to a 'DBIntegral' by rounding to the nearest smaller+-- integer. +--+-- Corresponds to the @floor()@ function.+floor :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b)+  => Expr a -> Expr b+floor = function "floor"+++-- | Round a 'DBFractional' to a 'DBIntegral' by rounding to the nearest+-- integer.+--+-- Corresponds to the @round()@ function.+round :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b)+  => Expr a -> Expr b+round = function "round"+++-- | Round a 'DBFractional' to a 'DBIntegral' by rounding to the nearest+-- integer towards zero.+truncate :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b)+  => Expr a -> Expr b+truncate = function "trunc"
+ src/Rel8/Expr/Opaleye.hs view
@@ -0,0 +1,88 @@+{-# language FlexibleContexts #-}+{-# language NamedFieldPuns #-}+{-# language ScopedTypeVariables #-}+{-# language TypeFamilies #-}++{-# options_ghc -fno-warn-redundant-constraints #-}++module Rel8.Expr.Opaleye+  ( castExpr, unsafeCastExpr+  , scastExpr, sunsafeCastExpr+  , unsafeLiteral+  , fromPrimExpr, toPrimExpr, mapPrimExpr, zipPrimExprsWith, traversePrimExpr+  , toColumn, fromColumn+  )+where++-- base+import Prelude++-- opaleye+import qualified Opaleye.Internal.Column as Opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye++-- rel8+import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )+import Rel8.Schema.Null ( Unnullify, Sql )+import Rel8.Type ( DBType, typeInformation )+import Rel8.Type.Information ( TypeInformation(..) )+++castExpr :: Sql DBType a => Expr a -> Expr a+castExpr = scastExpr typeInformation+++-- | Cast an expression to a different type. Corresponds to a @CAST()@ function+-- call.+unsafeCastExpr :: Sql DBType b => Expr a -> Expr b+unsafeCastExpr = sunsafeCastExpr typeInformation+++scastExpr :: TypeInformation (Unnullify a) -> Expr a -> Expr a+scastExpr = sunsafeCastExpr+++sunsafeCastExpr :: ()+  => TypeInformation (Unnullify b) -> Expr a -> Expr b+sunsafeCastExpr TypeInformation {typeName} =+  fromPrimExpr . Opaleye.CastExpr typeName . toPrimExpr+++-- | Unsafely construct an expression from literal SQL.+--+-- This is an escape hatch, and can be used if Rel8 can not adequately express+-- the query you need. If you find yourself using this function, please let us+-- know, as it may indicate that something is missing from Rel8!+unsafeLiteral :: String -> Expr a+unsafeLiteral = Expr . Opaleye.ConstExpr . Opaleye.OtherLit+++fromPrimExpr :: Opaleye.PrimExpr -> Expr a+fromPrimExpr = Expr+++toPrimExpr :: Expr a -> Opaleye.PrimExpr+toPrimExpr (Expr a) = a+++mapPrimExpr :: (Opaleye.PrimExpr -> Opaleye.PrimExpr) -> Expr a -> Expr b+mapPrimExpr f = fromPrimExpr . f . toPrimExpr+++zipPrimExprsWith :: ()+  => (Opaleye.PrimExpr -> Opaleye.PrimExpr -> Opaleye.PrimExpr)+  -> Expr a -> Expr b -> Expr c+zipPrimExprsWith f a b = fromPrimExpr (f (toPrimExpr a) (toPrimExpr b))+++traversePrimExpr :: Functor f+  => (Opaleye.PrimExpr -> f Opaleye.PrimExpr) -> Expr a -> f (Expr b)+traversePrimExpr f = fmap fromPrimExpr . f . toPrimExpr+++toColumn :: Opaleye.PrimExpr -> Opaleye.Column b+toColumn = Opaleye.Column+++fromColumn :: Opaleye.Column b -> Opaleye.PrimExpr+fromColumn (Opaleye.Column a) = a
+ src/Rel8/Expr/Ord.hs view
@@ -0,0 +1,137 @@+{-# language DataKinds #-}+{-# language FlexibleContexts #-}+{-# language GADTs #-}+{-# language ScopedTypeVariables #-}+{-# language TypeApplications #-}++{-# options_ghc -fno-warn-redundant-constraints #-}++module Rel8.Expr.Ord+  ( (<.), (<=.), (>.), (>=.)+  , (<?), (<=?), (>?), (>=?)+  , leastExpr, greatestExpr+  )+where++-- base+import Prelude++-- opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye++-- rel8+import Rel8.Expr ( Expr( Expr ) )+import Rel8.Expr.Bool ( (&&.), (||.), coalesce )+import Rel8.Expr.Null ( isNull, isNonNull, nullableExpr, unsafeLiftOpNull )+import Rel8.Expr.Opaleye ( toPrimExpr, zipPrimExprsWith )+import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )+import Rel8.Type.Ord ( DBOrd )+++lt :: DBOrd a => Expr a -> Expr a -> Expr Bool+lt = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:<))+++le :: DBOrd a => Expr a -> Expr a -> Expr Bool+le = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:<=))+++gt :: DBOrd a => Expr a -> Expr a -> Expr Bool+gt = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:>))+++ge :: DBOrd a => Expr a -> Expr a -> Expr Bool+ge = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:>=))+++-- | Corresponds to the SQL @<@ operator. Note that this differs from SQL @<@+-- as @null@ will sort below any other value. For a version of @<@ that exactly+-- matches SQL, see '(<?)'.+(<.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool+(<.) = case nullable @a of+  Null -> \ma mb -> isNull ma &&. isNonNull mb ||. ma <? mb+  NotNull -> lt+infix 4 <.+++-- | Corresponds to the SQL @<=@ operator. Note that this differs from SQL @<=@+-- as @null@ will sort below any other value. For a version of @<=@ that exactly+-- matches SQL, see '(<=?)'.+(<=.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool+(<=.) = case nullable @a of+  Null -> \ma mb -> isNull ma ||. ma <=? mb+  NotNull -> le+infix 4 <=.+++-- | Corresponds to the SQL @>@ operator. Note that this differs from SQL @>@+-- as @null@ will sort below any other value. For a version of @>@ that exactly+-- matches SQL, see '(>?)'.+(>.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool+(>.) = case nullable @a of+  Null -> \ma mb -> isNonNull ma &&. isNull mb ||. ma >? mb+  NotNull -> gt+infix 4 >.+++-- | Corresponds to the SQL @>=@ operator. Note that this differs from SQL @>@+-- as @null@ will sort below any other value. For a version of @>=@ that+-- exactly matches SQL, see '(>=?)'.+(>=.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool+(>=.) = case nullable @a of+  Null -> \ma mb -> isNull mb ||. ma >=? mb+  NotNull -> ge+infix 4 >=.+++-- | Corresponds to the SQL @<@ operator. Returns @null@ if either arguments+-- are @null@.+(<?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool+a <? b = coalesce $ unsafeLiftOpNull lt a b+infix 4 <?+++-- | Corresponds to the SQL @<=@ operator. Returns @null@ if either arguments+-- are @null@.+(<=?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool+a <=? b = coalesce $ unsafeLiftOpNull le a b+infix 4 <=?+++-- | Corresponds to the SQL @>@ operator. Returns @null@ if either arguments+-- are @null@.+(>?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool+a >? b = coalesce $ unsafeLiftOpNull gt a b+infix 4 >?+++-- | Corresponds to the SQL @>=@ operator. Returns @null@ if either arguments+-- are @null@.+(>=?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool+a >=? b = coalesce $ unsafeLiftOpNull ge a b+infix 4 >=?+++-- | Given two expressions, return the expression that sorts less than the+-- other.+-- +-- Corresponds to the SQL @least()@ function.+leastExpr :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr a+leastExpr ma mb = case nullable @a of+  Null -> nullableExpr ma (\a -> nullableExpr mb (least_ a) mb) ma+  NotNull -> least_ ma mb+  where+    least_ a b = Expr (Opaleye.FunExpr "LEAST" [toPrimExpr a, toPrimExpr b])+++-- | Given two expressions, return the expression that sorts greater than the+-- other.+-- +-- Corresponds to the SQL @greatest()@ function.+greatestExpr :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr a+greatestExpr ma mb = case nullable @a of+  Null -> nullableExpr mb (\a -> nullableExpr ma (greatest_ a) mb) ma+  NotNull -> greatest_ ma mb+  where+    greatest_ a b =+      Expr (Opaleye.FunExpr "GREATEST" [toPrimExpr a, toPrimExpr b])
+ src/Rel8/Expr/Order.hs view
@@ -0,0 +1,69 @@+{-# language DataKinds #-}++{-# options_ghc -fno-warn-redundant-constraints #-}++module Rel8.Expr.Order+  ( asc+  , desc+  , nullsFirst+  , nullsLast+  )+where++-- base+import Data.Bifunctor ( first )+import Prelude++-- opaleye+import Opaleye.Internal.HaskellDB.PrimQuery ( OrderOp( orderDirection, orderNulls ) )+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye+import qualified Opaleye.Internal.Order as Opaleye++-- rel8+import Rel8.Expr ( Expr )+import Rel8.Expr.Null ( unsafeUnnullify )+import Rel8.Expr.Opaleye ( toPrimExpr )+import Rel8.Order ( Order( Order ) )+import Rel8.Type.Ord ( DBOrd )+++-- | Sort a column in ascending order.+asc :: DBOrd a => Order (Expr a)+asc = Order $ Opaleye.Order (\expr -> [(orderOp, toPrimExpr expr)])+  where+    orderOp :: Opaleye.OrderOp+    orderOp = Opaleye.OrderOp+      { orderDirection = Opaleye.OpAsc+      , orderNulls = Opaleye.NullsLast+      }+++-- | Sort a column in descending order.+desc :: DBOrd a => Order (Expr a)+desc = Order $ Opaleye.Order (\expr -> [(orderOp, toPrimExpr expr)])+  where+    orderOp :: Opaleye.OrderOp+    orderOp = Opaleye.OrderOp+      { orderDirection = Opaleye.OpDesc+      , orderNulls = Opaleye.NullsFirst+      }+++-- | Transform an ordering so that @null@ values appear first. This corresponds+-- to @NULLS FIRST@ in SQL.+nullsFirst :: Order (Expr a) -> Order (Expr (Maybe a))+nullsFirst (Order (Opaleye.Order f)) =+  Order $ Opaleye.Order $ fmap (first g) . f . unsafeUnnullify+  where+    g :: Opaleye.OrderOp -> Opaleye.OrderOp+    g orderOp = orderOp { Opaleye.orderNulls = Opaleye.NullsFirst }+++-- | Transform an ordering so that @null@ values appear first. This corresponds+-- to @NULLS LAST@ in SQL.+nullsLast :: Order (Expr a) -> Order (Expr (Maybe a))+nullsLast (Order (Opaleye.Order f)) =+  Order $ Opaleye.Order $ fmap (first g) . f . unsafeUnnullify+  where+    g :: Opaleye.OrderOp -> Opaleye.OrderOp+    g orderOp = orderOp { Opaleye.orderNulls = Opaleye.NullsLast }
+ src/Rel8/Expr/Sequence.hs view
@@ -0,0 +1,21 @@+module Rel8.Expr.Sequence+  ( nextval+  )+where++-- base+import Data.Int ( Int64 )+import Prelude++-- rel8+import Rel8.Expr ( Expr )+import Rel8.Expr.Function ( function )+import Rel8.Expr.Serialize ( litExpr )++-- text+import Data.Text ( pack )+++-- | See https://www.postgresql.org/docs/current/functions-sequence.html+nextval :: String -> Expr Int64+nextval = function "nextval" . litExpr . pack
+ src/Rel8/Expr/Serialize.hs view
@@ -0,0 +1,49 @@+{-# language FlexibleContexts #-}+{-# language NamedFieldPuns #-}+{-# language TypeFamilies #-}++module Rel8.Expr.Serialize+  ( litExpr+  , slitExpr+  , sparseValue+  )+where++-- base+import Prelude++-- hasql+import qualified Hasql.Decoders as Hasql++-- opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye++-- rel8+import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )+import Rel8.Expr.Opaleye ( scastExpr )+import Rel8.Schema.Null ( Unnullify, Nullity( Null, NotNull ), Sql, nullable )+import Rel8.Type ( DBType, typeInformation )+import Rel8.Type.Information ( TypeInformation(..) )+++-- | Produce an expression from a literal.+--+-- Note that you can usually use 'Rel8.lit', but @litExpr@ can solve problems+-- of inference in polymorphic code.+litExpr :: Sql DBType a => a -> Expr a+litExpr = slitExpr nullable typeInformation+++slitExpr :: Nullity a -> TypeInformation (Unnullify a) -> a -> Expr a+slitExpr nullity info@TypeInformation {encode} =+  scastExpr info . Expr . encoder+  where+    encoder = case nullity of+      Null -> maybe (Opaleye.ConstExpr Opaleye.NullLit) encode+      NotNull -> encode+++sparseValue :: Nullity a -> TypeInformation (Unnullify a) -> Hasql.Row a+sparseValue nullity TypeInformation {decode} = case nullity of+  Null -> Hasql.column $ Hasql.nullable decode+  NotNull -> Hasql.column $ Hasql.nonNullable decode
+ src/Rel8/Expr/Text.hs view
@@ -0,0 +1,275 @@+{-# language DataKinds #-}++module Rel8.Expr.Text+  (+    -- * String concatenation+    (++.)++    -- * Regular expression operators+  , (~.), (~*), (!~), (!~*)++    -- * Standard SQL functions+  , bitLength, charLength, lower, octetLength, upper++    -- * PostgreSQL functions+  , ascii, btrim, chr, convert, convertFrom, convertTo, decode, encode+  , initcap, left, length, lengthEncoding, lpad, ltrim, md5+  , pgClientEncoding, quoteIdent, quoteLiteral, quoteNullable, regexpReplace+  , regexpSplitToArray, repeat, replace, reverse, right, rpad, rtrim+  , splitPart, strpos, substr, translate+  )+where++-- base+import Data.Bool ( Bool )+import Data.Int ( Int32 )+import Data.Maybe ( Maybe( Nothing, Just ) )+import Prelude ()++-- bytestring+import Data.ByteString ( ByteString )++-- rel8+import Rel8.Expr ( Expr )+import Rel8.Expr.Function ( binaryOperator, function, nullaryFunction )++-- text+import Data.Text (Text)+++-- | The PostgreSQL string concatenation operator.+(++.) :: Expr Text -> Expr Text -> Expr Text+(++.) = binaryOperator "||"+infixr 6 ++.+++-- * Regular expression operators++-- See https://www.postgresql.org/docs/9.5/static/functions-matching.html#FUNCTIONS-POSIX-REGEXP+++-- | Matches regular expression, case sensitive+-- +-- Corresponds to the @~.@ operator.+(~.) :: Expr Text -> Expr Text -> Expr Bool+(~.) = binaryOperator "~."+infix 2 ~.+++-- | Matches regular expression, case insensitive+--+-- Corresponds to the @~*@ operator.+(~*) :: Expr Text -> Expr Text -> Expr Bool+(~*) = binaryOperator "~*"+infix 2 ~*+++-- | Does not match regular expression, case sensitive+--+-- Corresponds to the @!~@ operator.+(!~) :: Expr Text -> Expr Text -> Expr Bool+(!~) = binaryOperator "!~"+infix 2 !~+++-- | Does not match regular expression, case insensitive+--+-- Corresponds to the @!~*@ operator.+(!~*) :: Expr Text -> Expr Text -> Expr Bool+(!~*) = binaryOperator "!~*"+infix 2 !~*+++-- See https://www.postgresql.org/docs/9.5/static/functions-Expr.'PGHtml++-- * Standard SQL functions+++-- | Corresponds to the @bit_length@ function.+bitLength :: Expr Text -> Expr Int32+bitLength = function "bit_length"+++-- | Corresponds to the @char_length@ function.+charLength :: Expr Text -> Expr Int32+charLength = function "char_length"+++-- | Corresponds to the @lower@ function.+lower :: Expr Text -> Expr Text+lower = function "lower"+++-- | Corresponds to the @octet_length@ function.+octetLength :: Expr Text -> Expr Int32+octetLength = function "octet_length"+++-- | Corresponds to the @upper@ function.+upper :: Expr Text -> Expr Text+upper = function "upper"+++-- | Corresponds to the @ascii@ function.+ascii :: Expr Text -> Expr Int32+ascii = function "ascii"+++-- | Corresponds to the @btrim@ function.+btrim :: Expr Text -> Maybe (Expr Text) -> Expr Text+btrim a (Just b) = function "btrim" a b+btrim a Nothing = function "btrim" a+++-- | Corresponds to the @chr@ function.+chr :: Expr Int32 -> Expr Text+chr = function "chr"+++-- | Corresponds to the @convert@ function.+convert :: Expr ByteString -> Expr Text -> Expr Text -> Expr ByteString+convert = function "convert"+++-- | Corresponds to the @convert_from@ function.+convertFrom :: Expr ByteString -> Expr Text -> Expr Text+convertFrom = function "convert_from"+++-- | Corresponds to the @convert_to@ function.+convertTo :: Expr Text -> Expr Text -> Expr ByteString+convertTo = function "convert_to"+++-- | Corresponds to the @decode@ function.+decode :: Expr Text -> Expr Text -> Expr ByteString+decode = function "decode"+++-- | Corresponds to the @encode@ function.+encode :: Expr ByteString -> Expr Text -> Expr Text+encode = function "encode"+++-- | Corresponds to the @initcap@ function.+initcap :: Expr Text -> Expr Text+initcap = function "initcap"+++-- | Corresponds to the @left@ function.+left :: Expr Text -> Expr Int32 -> Expr Text+left = function "left"+++-- | Corresponds to the @length@ function.+length :: Expr Text -> Expr Int32+length = function "length"+++-- | Corresponds to the @length@ function.+lengthEncoding :: Expr ByteString -> Expr Text -> Expr Int32+lengthEncoding = function "length"+++-- | Corresponds to the @lpad@ function.+lpad :: Expr Text -> Expr Int32 -> Maybe (Expr Text) -> Expr Text+lpad a b (Just c) = function "lpad" a b c+lpad a b Nothing = function "lpad" a b+++-- | Corresponds to the @ltrim@ function.+ltrim :: Expr Text -> Maybe (Expr Text) -> Expr Text+ltrim a (Just b) = function "ltrim" a b+ltrim a Nothing = function "ltrim" a+++-- | Corresponds to the @md5@ function.+md5 :: Expr Text -> Expr Text+md5 = function "md5"+++-- | Corresponds to the @pg_client_encoding()@ expression.+pgClientEncoding :: Expr Text+pgClientEncoding = nullaryFunction "pg_client_encoding"+++-- | Corresponds to the @quote_ident@ function.+quoteIdent :: Expr Text -> Expr Text+quoteIdent = function "quote_ident"+++-- | Corresponds to the @quote_literal@ function.+quoteLiteral :: Expr Text -> Expr Text+quoteLiteral = function "quote_literal"+++-- | Corresponds to the @quote_nullable@ function.+quoteNullable :: Expr Text -> Expr Text+quoteNullable = function "quote_nullable"+++-- | Corresponds to the @regexp_replace@ function.+regexpReplace :: ()+  => Expr Text -> Expr Text -> Expr Text -> Maybe (Expr Text) -> Expr Text+regexpReplace a b c (Just d) = function "regexp_replace" a b c d+regexpReplace a b c Nothing = function "regexp_replace" a b c+++-- | Corresponds to the @regexp_split_to_array@ function.+regexpSplitToArray :: ()+  => Expr Text -> Expr Text -> Maybe (Expr Text) -> Expr [Text]+regexpSplitToArray a b (Just c) = function "regexp_split_to_array" a b c+regexpSplitToArray a b Nothing = function "regexp_split_to_array" a b+++-- | Corresponds to the @repeat@ function.+repeat :: Expr Text -> Expr Int32 -> Expr Text+repeat = function "repeat"+++-- | Corresponds to the @replace@ function.+replace :: Expr Text -> Expr Text -> Expr Text -> Expr Text+replace = function "replace"+++-- | Corresponds to the @reverse@ function.+reverse :: Expr Text -> Expr Text+reverse = function "reverse"+++-- | Corresponds to the @right@ function.+right :: Expr Text -> Expr Int32 -> Expr Text+right = function "right"+++-- | Corresponds to the @rpad@ function.+rpad :: Expr Text -> Expr Int32 -> Maybe (Expr Text) -> Expr Text+rpad a b (Just c) = function "rpad" a b c+rpad a b Nothing = function "rpad" a b+++-- | Corresponds to the @rtrim@ function.+rtrim :: Expr Text -> Maybe (Expr Text) -> Expr Text+rtrim a (Just b) = function "rtrim" a b+rtrim a Nothing = function "rtrim" a+++-- | Corresponds to the @split_part@ function.+splitPart :: Expr Text -> Expr Text -> Expr Int32 -> Expr Text+splitPart = function "split_part"+++-- | Corresponds to the @strpos@ function.+strpos :: Expr Text -> Expr Text -> Expr Int32+strpos = function "strpos"+++-- | Corresponds to the @substr@ function.+substr :: Expr Text -> Expr Int32 -> Maybe (Expr Int32) -> Expr Text+substr a b (Just c) = function "substr" a b c+substr a b Nothing = function "substr" a b+++-- | Corresponds to the @translate@ function.+translate :: Expr Text -> Expr Text -> Expr Text -> Expr Text+translate = function "translate"
+ src/Rel8/Expr/Time.hs view
@@ -0,0 +1,167 @@+module Rel8.Expr.Time+  ( -- * Working with @Day@+    today+  , toDay+  , fromDay+  , addDays+  , diffDays+  , subtractDays++    -- * Working with @UTCTime@+  , now+  , addTime+  , diffTime+  , subtractTime++  -- * Working with @CalendarDiffTime@+  , scaleInterval+  , second, seconds+  , minute, minutes+  , hour, hours+  , day, days+  , week, weeks+  , month, months+  , year, years+  ) where++-- base+import Data.Int ( Int32 )+import Prelude++-- rel8+import Rel8.Expr ( Expr )+import Rel8.Expr.Function ( binaryOperator, nullaryFunction )+import Rel8.Expr.Opaleye ( castExpr, unsafeCastExpr, unsafeLiteral )++-- time+import Data.Time.Calendar ( Day )+import Data.Time.Clock ( UTCTime )+import Data.Time.LocalTime ( CalendarDiffTime )+++-- | Corresponds to @date(now())@.+today :: Expr Day+today = toDay now+++-- | Corresponds to calling the @date@ function with a given time.+toDay :: Expr UTCTime -> Expr Day+toDay = unsafeCastExpr+++-- | Corresponds to @x::timestamptz@.+fromDay :: Expr Day -> Expr UTCTime+fromDay = unsafeCastExpr+++-- | Move forward a given number of days from a particular day.+addDays :: Expr Int32 -> Expr Day -> Expr Day+addDays = flip (binaryOperator "+")+++-- | Find the number of days between two days. Corresponds to the @-@ operator.+diffDays :: Expr Day -> Expr Day -> Expr Int32+diffDays = binaryOperator "-"+++-- | Subtract a given number of days from a particular 'Day'. +subtractDays :: Expr Int32 -> Expr Day -> Expr Day+subtractDays = flip (binaryOperator "-")+++-- | Corresponds to @now()@.+now :: Expr UTCTime+now = nullaryFunction "now"+++-- | Add a time interval to a point in time, yielding a new point in time.+addTime :: Expr CalendarDiffTime -> Expr UTCTime -> Expr UTCTime+addTime = flip (binaryOperator "+")+++-- | Find the duration between two times.+diffTime :: Expr UTCTime -> Expr UTCTime -> Expr CalendarDiffTime+diffTime = binaryOperator "-"+++-- | Subtract a time interval from a point in time, yielding a new point in time.+subtractTime :: Expr CalendarDiffTime -> Expr UTCTime -> Expr UTCTime+subtractTime = flip (binaryOperator "-")+++scaleInterval :: Expr Double -> Expr CalendarDiffTime -> Expr CalendarDiffTime+scaleInterval = binaryOperator "*"+++-- | An interval of one second.+second :: Expr CalendarDiffTime+second = singleton "second"+++-- | Create a literal interval from a number of seconds.+seconds :: Expr Double -> Expr CalendarDiffTime+seconds = (`scaleInterval` second)+++-- | An interval of one minute.+minute :: Expr CalendarDiffTime+minute = singleton "minute"+++-- | Create a literal interval from a number of minutes.+minutes :: Expr Double -> Expr CalendarDiffTime+minutes = (`scaleInterval` minute)+++-- | An interval of one hour.+hour :: Expr CalendarDiffTime+hour = singleton "hour"+++-- | Create a literal interval from a number of hours.+hours :: Expr Double -> Expr CalendarDiffTime+hours = (`scaleInterval` hour)+++-- | An interval of one day.+day :: Expr CalendarDiffTime+day = singleton "day"+++-- | Create a literal interval from a number of days.+days ::  Expr Double -> Expr CalendarDiffTime+days = (`scaleInterval` day)+++-- | An interval of one week.+week :: Expr CalendarDiffTime+week = singleton "week"+++-- | Create a literal interval from a number of weeks.+weeks ::  Expr Double -> Expr CalendarDiffTime+weeks = (`scaleInterval` week)+++-- | An interval of one month.+month :: Expr CalendarDiffTime+month = singleton "month"+++-- | Create a literal interval from a number of months.+months ::  Expr Double -> Expr CalendarDiffTime+months = (`scaleInterval` month)+++-- | An interval of one year.+year :: Expr CalendarDiffTime+year = singleton "year"+++-- | Create a literal interval from a number of years.+years ::  Expr Double -> Expr CalendarDiffTime+years = (`scaleInterval` year)+++singleton :: String -> Expr CalendarDiffTime+singleton unit = castExpr $ unsafeLiteral $ "'1 " ++ unit ++ "'"
+ src/Rel8/FCF.hs view
@@ -0,0 +1,26 @@+{-# language DataKinds #-}+{-# language PolyKinds #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeFamilies #-}++module Rel8.FCF+  ( Exp, Eval+  , Compose+  )+where++-- base+import Data.Kind ( Type )+import Prelude ()+++type Exp :: Type -> Type+type Exp e = e -> Type+++type Eval :: Exp e -> e+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))
+ src/Rel8/Generic/Construction.hs view
@@ -0,0 +1,371 @@+{-# language AllowAmbiguousTypes #-}+{-# language ConstraintKinds #-}+{-# language DataKinds #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language LambdaCase #-}+{-# language MultiParamTypeClasses #-}+{-# language NamedFieldPuns #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeApplications #-}+{-# language TypeFamilies #-}+{-# language UndecidableInstances #-}+{-# language ViewPatterns #-}++module Rel8.Generic.Construction+  ( GGBuildable+  , GGBuild, ggbuild+  , GGConstructable+  , GGConstruct, ggconstruct+  , GGDeconstruct, ggdeconstruct+  , GGName, ggname+  , GGAggregate, ggaggregate+  )+where++-- base+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.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.Generic.Construction.ADT+  ( GConstructorADT, GMakeableADT, gmakeADT+  , GConstructableADT+  , GBuildADT, gbuildADT, gunbuildADT+  , GConstructADT, gconstructADT, gdeconstructADT+  , RepresentableConstructors, GConstructors, gcindex, gctabulate+  , RepresentableFields, gfindex, gftabulate+  )+import Rel8.Generic.Construction.Record+  ( GConstructor+  , GConstructable, GConstruct, gconstruct, gdeconstruct+  , Representable, gindex, gtabulate+  )+import Rel8.Generic.Table ( GGColumns )+import Rel8.Kind.Algebra+  ( SAlgebra( SProduct, SSum )+  , KnownAlgebra, algebraSing+  )+import qualified Rel8.Kind.Algebra as K+import Rel8.Schema.Context.Nullify ( runTag )+import Rel8.Schema.HTable ( HTable )+import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )+import qualified Rel8.Schema.Kind as K+import Rel8.Schema.Name ( Col( N ), 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.Table+  ( TTable, TColumns, TUnreify+  , Table, fromColumns, toColumns, reify, unreify+  )+import Rel8.Table.Bool ( case_ )+import Rel8.Type.Tag ( Tag )+++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)))))+  , GGBuildable' algebra name rep+  )+++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)))+    )+  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)))+    )+++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+  GGBuild 'K.Sum name rep r =+    GConstruct TUnreify (GConstructorADT name (Eval (rep (Reify Expr)))) r+++ggbuild :: forall algebra name rep a. GGBuildable algebra name rep+  => (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Expr) -> a)+  -> GGBuild algebra name rep a+ggbuild gfromColumns = case algebraSing @algebra of+  SProduct ->+    gtabulate @TUnreify @(Eval (rep (Reify Expr))) @a $+    gfromColumns .+    hunreify .+    gconstruct+      @(TTable (Reify Expr))+      @TColumns+      @TUnreify+      @(Col (Reify Expr))+      @(Eval (rep (Reify Expr)))+      (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)+  SSum ->+    gtabulate @TUnreify @(GConstructorADT name (Eval (rep (Reify Expr)))) @a $+    gfromColumns .+    hunreify .+    gmakeADT+      @(TTable (Reify Expr))+      @TColumns+      @TUnreify+      @(Col (Reify Expr))+      @name+      @(Eval (rep (Reify Expr)))+      (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)+      (\SSpec {info} -> Reify (E (snull info)))+      (\SSpec {nullity} -> case nullity of+        Null -> id+        NotNull -> \(Reify (E a)) -> Reify (E (nullify a)))+      (HType . Reify . E . 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)))))+  , GGConstructable' algebra rep+  )+++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)))+    )+  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)))+    )+++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 :: forall algebra rep a. GGConstructable algebra rep+  => (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Expr) -> a)+  -> GGConstruct algebra rep a -> a+ggconstruct gfromColumns f = case algebraSing @algebra of+  SProduct ->+    f $+    gtabulate @TUnreify @(Eval (rep (Reify Expr))) @a $+    gfromColumns .+    hunreify .+    gconstruct+      @(TTable (Reify Expr))+      @TColumns+      @TUnreify+      @(Col (Reify Expr))+      @(Eval (rep (Reify Expr)))+      (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)+  SSum ->+    gcindex @TUnreify @(Eval (rep (Reify Expr))) @a f $+    fmap (gfromColumns . hunreify) $+    gconstructADT+      @(TTable (Reify 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+        Null -> id+        NotNull -> \(Reify (E a)) -> Reify (E (nullify a)))+      (HType . Reify . E . 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+  GGDeconstruct 'K.Sum rep a r =+    GConstructADT TUnreify (Eval (rep (Reify 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))+  -> GGDeconstruct algebra rep a r+ggdeconstruct gtoColumns = case algebraSing @algebra of+  SProduct -> \build ->+    gindex @TUnreify @(Eval (rep (Reify Expr))) @r build .+    gdeconstruct+      @(TTable (Reify Expr))+      @TColumns+      @TUnreify+      @(Col (Reify Expr))+      @(Eval (rep (Reify Expr)))+      (\(_ :: proxy x) -> unreify @_ @x Refl . fromColumns) .+    hreify .+    gtoColumns+  SSum ->+    gctabulate @TUnreify @(Eval (rep (Reify Expr))) @r @(a -> r) $ \constructors as ->+      let+        (HType (Reify (E tag)), cases) =+          gdeconstructADT+            @(TTable (Reify Expr))+            @TColumns+            @TUnreify+            @(Col (Reify Expr))+            @(Eval (rep (Reify Expr)))+            (\(_ :: proxy x) -> unreify @_ @x Refl . fromColumns)+            (\SSpec {nullity} -> case nullity of+              Null -> id+              NotNull -> \(Reify (E a)) -> Reify (E (unsafeUnnullify a)))+            constructors $+          hreify $+          gtoColumns as+      in+        case cases of+          ((_, r) :| (map (first ((tag ==.) . litExpr)) -> cases')) ->+            case_ cases' r+++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 :: forall algebra rep a. GGConstructable algebra rep+  => (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Name) -> a)+  -> GGName algebra rep a+ggname gfromColumns = case algebraSing @algebra of+  SProduct ->+    gtabulate @TUnreify @(Eval (rep (Reify Name))) @a $+    gfromColumns .+    hunreify .+    gconstruct+      @(TTable (Reify Name))+      @TColumns+      @TUnreify+      @(Col (Reify Name))+      @(Eval (rep (Reify Name)))+      (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)+  SSum -> \tag ->+    gftabulate @TUnreify @(Eval (rep (Reify Name))) @a $+    gfromColumns .+    hunreify .+    gbuildADT+      @(TTable (Reify 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)))+++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+  GGAggregate 'K.Sum rep r =+    GBuildADT TUnreify (Eval (rep (Reify Aggregate))) r ->+      GBuildADT TUnreify (Eval (rep (Reify 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))+  -> 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))+      @TColumns+      @TUnreify+      @(Col (Reify Aggregate))+      @(Eval (rep (Reify Aggregate)))+      (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)+    where+      f =+        gindex @TUnreify @(Eval (rep (Reify Expr))) @agg .+        agg .+        gtabulate @TUnreify @(Eval (rep (Reify Aggregate))) @agg+      exprs =+        gdeconstruct+          @(TTable (Reify Expr))+          @TColumns+          @TUnreify+          @(Col (Reify Expr))+          @(Eval (rep (Reify Expr)))+          (\(_ :: proxy x) -> unreify @_ @x Refl . fromColumns) $+        hreify $+        gtoColumns es+  SSum -> flip f exprs $+    gfromColumns .+    hunreify .+    gbuildADT+      @(TTable (Reify 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))))+    where+      f =+        gfindex @TUnreify @(Eval (rep (Reify Expr))) @agg .+        agg .+        gftabulate @TUnreify @(Eval (rep (Reify Aggregate))) @agg+      (HType (Reify (E tag)), exprs) =+        gunbuildADT+          @(TTable (Reify Expr))+          @TColumns+          @TUnreify+          @(Col (Reify Expr))+          @(Eval (rep (Reify Expr)))+          (\(_ :: proxy x) -> unreify @_ @x Refl . fromColumns)+          (\SSpec {nullity} -> case nullity of+            Null -> id+            NotNull -> \(Reify (E a)) -> Reify (E (unsafeUnnullify a))) $+        hreify $+        gtoColumns es
+ src/Rel8/Generic/Construction/ADT.hs view
@@ -0,0 +1,493 @@+{-# language AllowAmbiguousTypes #-}+{-# language BlockArguments #-}+{-# language DataKinds #-}+{-# language FlexibleInstances #-}+{-# language MultiParamTypeClasses #-}+{-# language RankNTypes #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneKindSignatures #-}+{-# language TupleSections #-}+{-# language TypeApplications #-}+{-# language TypeFamilies #-}+{-# language TypeOperators #-}+{-# language UndecidableInstances #-}++module Rel8.Generic.Construction.ADT+  ( GConstructableADT+  , GBuildADT, gbuildADT, gunbuildADT+  , GConstructADT, gconstructADT, gdeconstructADT+  , GFields, RepresentableFields, gftabulate, gfindex+  , GConstructors, RepresentableConstructors, gctabulate, gcindex+  , GConstructorADT, GMakeableADT, gmakeADT+  )+where++-- base+import Data.Bifunctor ( first )+import Data.Functor.Identity ( runIdentity )+import Data.Kind ( Constraint, Type )+import Data.List.NonEmpty ( NonEmpty )+import Data.Proxy ( Proxy( Proxy ) )+import GHC.Generics+  ( (:+:), (:*:)( (:*:) ), M1, U1+  , C, D+  , Meta( MetaData, MetaCons )+  )+import GHC.TypeLits+  ( ErrorMessage( (:<>:), Text ), TypeError+  , Symbol, KnownSymbol, symbolVal+  )+import Prelude hiding ( null )++-- rel8+import Rel8.FCF ( Exp )+import Rel8.Generic.Construction.Record+  ( GConstruct, GConstructable, gconstruct, gdeconstruct+  , GFields, Representable, gtabulate, gindex+  , FromColumns, ToColumns+  )+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.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 qualified Rel8.Schema.Kind as K+import Rel8.Type.Tag ( Tag( Tag ) )++-- text+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 Nullifier :: K.HContext -> Type+type Nullifier context = forall labels a. ()+  => SSpec ('Spec labels a)+  -> context ('Spec labels a)+  -> context ('Spec labels (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 NoConstructor :: Symbol -> Symbol -> ErrorMessage+type NoConstructor datatype constructor =+  ( 'Text "The type `" ':<>:+    'Text datatype ':<>:+    'Text "` has no constructor `" ':<>:+    'Text constructor ':<>:+    'Text "`."+  )+++type GConstructorADT :: Symbol -> (Type -> Type) -> Type -> Type+type family GConstructorADT name rep where+  GConstructorADT name (M1 D ('MetaData datatype _ _ _) rep) =+    GConstructorADT' name rep (TypeError (NoConstructor datatype name))+++type GConstructorADT' :: Symbol -> (Type -> Type) -> (Type -> Type) -> Type -> Type+type family GConstructorADT' name rep fallback where+  GConstructorADT' name (M1 D _ rep) fallback =+    GConstructorADT' name rep fallback+  GConstructorADT' name (a :+: b) fallback =+    GConstructorADT' name a (GConstructorADT' name b fallback)+  GConstructorADT' name (M1 C ('MetaCons name _ _) rep) _ = rep+  GConstructorADT' _ _ fallback = fallback+++type GConstructADT+  :: (Type -> Exp Type)+  -> (Type -> Type) -> Type -> Type -> Type+type family GConstructADT f rep r x where+  GConstructADT f (M1 D _ rep) r x = GConstructADT f rep r x+  GConstructADT f (a :+: b) r x = GConstructADT f a r (GConstructADT f b r x)+  GConstructADT f (M1 C _ rep) r x = GConstruct f rep r -> x+++type GConstructors :: (Type -> Exp Type) -> (Type -> Type) -> Type -> Type+type family GConstructors f rep where+  GConstructors f (M1 D _ rep) = GConstructors f rep+  GConstructors f (a :+: b) = GConstructors f a :*: GConstructors f b+  GConstructors f (M1 C _ rep) = (->) (GFields f rep)+++type RepresentableConstructors :: (Type -> Exp Type) -> (Type -> Type) -> Constraint+class RepresentableConstructors f rep where+  gctabulate :: (GConstructors f rep r -> a) -> GConstructADT f rep r a+  gcindex :: GConstructADT f rep r a -> GConstructors f rep r -> a+++instance RepresentableConstructors f rep => RepresentableConstructors f (M1 D meta rep) where+  gctabulate = gctabulate @f @rep+  gcindex = gcindex @f @rep+++instance (RepresentableConstructors f a, RepresentableConstructors f b) =>+  RepresentableConstructors f (a :+: b)+ where+  gctabulate f =+    gctabulate @f @a \a -> gctabulate @f @b \b -> f (a :*: b)+  gcindex f (a :*: b) = gcindex @f @b (gcindex @f @a f a) b+++instance Representable f rep => RepresentableConstructors f (M1 C meta rep) where+  gctabulate f = f . gindex @f @rep+  gcindex f = f . gtabulate @f @rep+++type GBuildADT :: (Type -> Exp Type) -> (Type -> Type) -> Type -> Type+type family GBuildADT f rep r where+  GBuildADT f (M1 D _ rep) r = GBuildADT f rep r+  GBuildADT f (a :+: b) r = GBuildADT f a (GBuildADT f b r)+  GBuildADT f (M1 C _ rep) r = GConstruct f rep r+++type GFieldsADT :: (Type -> Exp Type) -> (Type -> Type) -> Type+type family GFieldsADT f rep where+  GFieldsADT f (M1 D _ rep) = GFieldsADT f rep+  GFieldsADT f (a :+: b) = (GFieldsADT f a, GFieldsADT f b)+  GFieldsADT f (M1 C _ rep) = GFields f rep+++type RepresentableFields :: (Type -> Exp Type) -> (Type -> Type) -> Constraint+class RepresentableFields f rep where+  gftabulate :: (GFieldsADT f rep -> a) -> GBuildADT f rep a+  gfindex :: GBuildADT f rep a -> GFieldsADT f rep -> a+++instance RepresentableFields f rep => RepresentableFields f (M1 D meta rep) where+  gftabulate = gftabulate @f @rep+  gfindex = gfindex @f @rep+++instance (RepresentableFields f a, RepresentableFields f b) => RepresentableFields f (a :+: b) where+  gftabulate f =+    gftabulate @f @a \a -> gftabulate @f @b \b -> f (a, b)+  gfindex f (a, b) = gfindex @f @b (gfindex @f @a f a) b+++instance Representable f rep => RepresentableFields f (M1 C meta rep) where+  gftabulate = gtabulate @f @rep+  gfindex = gindex @f @rep+++type GConstructableADT+  :: (Type -> Exp Constraint)+  -> (Type -> Exp K.HTable)+  -> (Type -> Exp Type)+  -> K.HContext -> (Type -> Type) -> Constraint+class GConstructableADT _Table _Columns f context rep where+  gbuildADT :: ()+    => ToColumns _Table _Columns f context+    -> (Tag -> Nullifier context)+    -> HType Tag context+    -> GFieldsADT f rep+    -> GColumnsADT _Columns rep context++  gunbuildADT :: ()+    => FromColumns _Table _Columns f context+    -> Unnullifier context+    -> GColumnsADT _Columns rep context+    -> (HType Tag context, GFieldsADT f rep)++  gconstructADT :: ()+    => ToColumns _Table _Columns f context+    -> Null context+    -> Nullifier context+    -> (Tag -> HType Tag context)+    -> GConstructors f rep (GColumnsADT _Columns rep context)++  gdeconstructADT :: ()+    => FromColumns _Table _Columns f context+    -> Unnullifier context+    -> GConstructors f rep r+    -> GColumnsADT _Columns rep context+    -> (HType Tag context, NonEmpty (Tag, r))+++instance+  ( htable ~ HLabel "tag" (HType 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++  gunbuildADT fromColumns unnullifier =+    first (hunlabel hunlabeler) .+    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)++  gdeconstructADT fromColumns unnullifier cases =+    first (hunlabel hunlabeler) .+    gdeconstructADT' @_Table @_Columns @f @context @htable @rep fromColumns unnullifier cases+++type GConstructableADT'+  :: (Type -> Exp Constraint)+  -> (Type -> Exp K.HTable)+  -> (Type -> Exp Type)+  -> K.HContext -> K.HTable -> (Type -> Type) -> Constraint+class GConstructableADT' _Table _Columns f context htable rep where+  gbuildADT' :: ()+    => ToColumns _Table _Columns f context+    -> (Tag -> Nullifier context)+    -> htable context+    -> GFieldsADT f rep+    -> GColumnsADT' _Columns htable rep context++  gunbuildADT' :: ()+    => FromColumns _Table _Columns f context+    -> Unnullifier context+    -> GColumnsADT' _Columns htable rep context+    -> (htable context, GFieldsADT f rep)++  gconstructADT' :: ()+    => ToColumns _Table _Columns f context+    -> Null context+    -> Nullifier context+    -> (Tag -> htable context)+    -> GConstructors f rep (GColumnsADT' _Columns htable rep context)++  gdeconstructADT' :: ()+    => FromColumns _Table _Columns f context+    -> Unnullifier context+    -> GConstructors f rep r+    -> GColumnsADT' _Columns htable rep context+    -> (htable context, NonEmpty (Tag, r))++  gfill :: ()+    => Null context+    -> htable context+    -> GColumnsADT' _Columns htable rep context+++instance+  ( htable' ~ GColumnsADT' _Columns htable a+  , Functor (GConstructors f a)+  , GConstructableADT' _Table _Columns f context htable a+  , GConstructableADT' _Table _Columns f context htable' b+  )+  => GConstructableADT' _Table _Columns f context htable (a :+: b)+ where+  gbuildADT' toColumns nullifier htable (a, b) =+    gbuildADT' @_Table @_Columns @f @context @htable' @b toColumns nullifier+      (gbuildADT' @_Table @_Columns @f @context @htable @a toColumns nullifier htable a)+      b++  gunbuildADT' fromColumns unnullifier columns =+    case gunbuildADT' @_Table @_Columns @f @context @htable' @b fromColumns unnullifier columns of+      (htable', b) ->+        case gunbuildADT' @_Table @_Columns @f @context @htable @a fromColumns unnullifier htable' of+          (htable, a) -> (htable, (a, b))++  gconstructADT' toColumns null nullifier mk =+    fmap (gfill @_Table @_Columns @f @context @htable' @b null) (gconstructADT' @_Table @_Columns @f @context @htable @a toColumns null nullifier mk) :*:+    gconstructADT' @_Table @_Columns @f @context @htable' @b toColumns null nullifier (gfill @_Table @_Columns @f @context @htable @a null . mk)++  gdeconstructADT' fromColumns unnullifier (a :*: b) columns =+    case gdeconstructADT' @_Table @_Columns @f @context @htable' @b fromColumns unnullifier b columns of+      (htable', cases) ->+        case gdeconstructADT' @_Table @_Columns @f @context @htable @a fromColumns unnullifier a htable' of+          (htable, cases') -> (htable, cases' <> cases)++  gfill null =+    gfill @_Table @_Columns @f @context @htable' @b null .+    gfill @_Table @_Columns @f @context @htable @a null+++instance (meta ~ 'MetaCons label _fixity _isRecord, KnownSymbol label) =>+  GConstructableADT' _Table _Columns f context htable (M1 C meta U1)+ where+  gbuildADT' _ _ = const+  gunbuildADT' _ _ = (, ())+  gconstructADT' _ _ _ f _ = f tag+    where+      tag = Tag $ pack $ symbolVal (Proxy @label)+  gdeconstructADT' _ _ r htable = (htable, pure (tag, r ()))+    where+      tag = Tag $ pack $ symbolVal (Proxy @label)+  gfill _ = id+++instance {-# OVERLAPPABLE #-}+  ( 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)))+  )+  => GConstructableADT' _Table _Columns f context htable (M1 C meta rep)+ where+  gbuildADT' toColumns nullifier htable =+    HProduct htable .+    hlabel hlabeler .+    hnullify (nullifier tag) .+    gconstruct @_Table @_Columns @f @context @rep toColumns+    where+      tag = Tag $ pack $ symbolVal (Proxy @label)++  gunbuildADT' fromColumns unnullifier (HProduct htable a) =+    ( htable+    , gdeconstruct @_Table @_Columns @f @context @rep fromColumns $+        runIdentity $+        hunnullify (\spec -> pure . unnullifier spec) $+        hunlabel hunlabeler+        a+    )++  gconstructADT' toColumns _ nullifier mk =+    HProduct htable .+    hlabel hlabeler .+    hnullify nullifier .+    gconstruct @_Table @_Columns @f @context @rep toColumns+    where+      tag = Tag $ pack $ symbolVal (Proxy @label)+      htable = mk tag++  gdeconstructADT' fromColumns unnullifier r (HProduct htable columns) =+    ( htable+    , pure (tag, r a)+    )+    where+      a = gdeconstruct @_Table @_Columns @f @context @rep fromColumns $+        runIdentity $+        hunnullify (\spec -> pure . unnullifier spec) $+        hunlabel hunlabeler+        columns+      tag = Tag $ pack $ symbolVal (Proxy @label)++  gfill null htable = HProduct htable (hlabel hlabeler (hnulls null))+++type GMakeableADT+  :: (Type -> Exp Constraint)+  -> (Type -> Exp K.HTable)+  -> (Type -> Exp Type)+  -> K.HContext -> 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)+    -> GFields f (GConstructorADT name rep)+    -> GColumnsADT _Columns rep context+++instance+  ( htable ~ HLabel "tag" (HType 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)+ where+  gmakeADT toColumns null nullifier wrap =+    gmakeADT'+      @_Table @_Columns @f @context @htable @name @rep @fields+      toColumns null nullifier htable+    where+      tag = Tag $ pack $ symbolVal (Proxy @name)+      htable = hlabel hlabeler (wrap tag)+++type GMakeableADT'+  :: (Type -> Exp Constraint)+  -> (Type -> Exp K.HTable)+  -> (Type -> Exp Type)+  -> K.HContext -> K.HTable -> Symbol -> (Type -> Type) -> Type -> Constraint+class GMakeableADT' _Table _Columns f context htable name rep fields where+  gmakeADT' :: ()+    => ToColumns _Table _Columns f context+    -> Null context+    -> Nullifier context+    -> htable context+    -> fields+    -> GColumnsADT' _Columns htable rep context+++instance+  ( htable' ~ GColumnsADT' _Columns htable a+  , GMakeableADT' _Table _Columns f context htable name a fields+  , GMakeableADT' _Table _Columns f context htable' name b fields+  )+  => GMakeableADT' _Table _Columns f context htable name (a :+: b) fields+ where+  gmakeADT' toColumns null nullifier htable x =+    gmakeADT' @_Table @_Columns @f @context @htable' @name @b @fields+      toColumns null nullifier+      (gmakeADT'+         @_Table @_Columns @f @context @htable @name @a @fields toColumns+         null nullifier htable x)+      x+++instance {-# OVERLAPPING #-}+  GMakeableADT' _Table _Columns f context htable name (M1 C ('MetaCons name _fixity _isRecord) U1) fields+ where+  gmakeADT' _ _ _ = const+++instance {-# OVERLAPS #-}+  GMakeableADT' _Table _Columns f context htable name (M1 C ('MetaCons label _fixity _isRecord) U1) fields+ where+  gmakeADT' _ _ _ = const+++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) ~+      HProduct htable (HLabel name (HNullify (GColumns _Columns rep)))+  )+  => GMakeableADT' _Table _Columns f context htable name (M1 C ('MetaCons name _fixity _isRecord) rep) fields+ where+  gmakeADT' toColumns _ nullifier htable =+    HProduct htable .+    hlabel hlabeler .+    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)))+  )+  => GMakeableADT' _Table _Columns f context htable name (M1 C ('MetaCons label _fixity _isRecord) rep) fields+ where+  gmakeADT' _ null _ htable _ =+    HProduct htable $+    hlabel hlabeler $+    hnulls null
+ src/Rel8/Generic/Construction/Record.hs view
@@ -0,0 +1,173 @@+{-# language AllowAmbiguousTypes #-}+{-# language BlockArguments #-}+{-# language DataKinds #-}+{-# language FlexibleInstances #-}+{-# language MultiParamTypeClasses #-}+{-# language RankNTypes #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeApplications #-}+{-# language TypeFamilies #-}+{-# language TypeOperators #-}+{-# language UndecidableInstances #-}++module Rel8.Generic.Construction.Record+  ( GConstructor, GConstruct, GConstructable, gconstruct, gdeconstruct+  , GFields, Representable, gtabulate, gindex+  , FromColumns, ToColumns+  )+where++-- base+import Data.Kind ( Constraint, Type )+import Data.Proxy ( Proxy( Proxy ) )+import GHC.Generics+  ( (:*:), K1, M1, U1+  , D, C, S, Meta( MetaData, MetaCons, MetaSel )+  )+import GHC.TypeLits+  ( ErrorMessage( (:<>:), Text ), TypeError+  , Symbol, KnownSymbol+  )+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+++type FromColumns+  :: (Type -> Exp Constraint)+  -> (Type -> Exp K.HTable)+  -> (Type -> Exp Type)+  -> K.HContext+  -> Type+type FromColumns _Table _Columns f context = forall proxy x.+  Eval (_Table x) => proxy x -> Eval (_Columns x) context -> Eval (f x)+++type ToColumns+  :: (Type -> Exp Constraint)+  -> (Type -> Exp K.HTable)+  -> (Type -> Exp Type)+  -> K.HContext+  -> Type+type ToColumns _Table _Columns f context = forall proxy x.+  Eval (_Table x) => proxy x -> Eval (f x) -> Eval (_Columns x) context+++type GConstructor :: (Type -> Type) -> Symbol+type family GConstructor rep where+  GConstructor (M1 D _ (M1 C ('MetaCons name _ _) _)) = name+  GConstructor (M1 D ('MetaData name _ _ _) _) = TypeError (+    'Text "`" ':<>:+    'Text name ':<>:+    'Text "` does not appear to have exactly 1 constructor"+   )+++type GConstruct :: (Type -> Exp Type) -> (Type -> Type) -> Type -> Type+type family GConstruct f rep r where+  GConstruct f (M1 _ _ rep) r = GConstruct f rep r+  GConstruct f (a :*: b) r = GConstruct f a (GConstruct f b r)+  GConstruct _ U1 r = r+  GConstruct f (K1 _ a) r = Eval (f a) -> r+++type GFields :: (Type -> Exp Type) -> (Type -> Type) -> Type+type family GFields f rep where+  GFields f (M1 _ _ rep) = GFields f rep+  GFields f (a :*: b) = (GFields f a, GFields f b)+  GFields _ U1 = ()+  GFields f (K1 _ a) = Eval (f a)+++type Representable :: (Type -> Exp Type) -> (Type -> Type) -> Constraint+class Representable f rep where+  gtabulate :: (GFields f rep -> a) -> GConstruct f rep a+  gindex :: GConstruct f rep a -> GFields f rep -> a+++instance Representable f rep => Representable f (M1 i meta rep) where+  gtabulate = gtabulate @f @rep+  gindex = gindex @f @rep+++instance (Representable f a, Representable f b) =>+  Representable f (a :*: b)+ where+  gtabulate f = gtabulate @f @a \a -> gtabulate @f @b \b -> f (a, b)+  gindex f (a, b) = gindex @f @b (gindex @f @a f a) b+++instance Representable f U1 where+  gtabulate = ($ ())+  gindex = const+++instance Representable f (K1 i a) where+  gtabulate = id+  gindex = id+++type GConstructable+  :: (Type -> Exp Constraint)+  -> (Type -> Exp K.HTable)+  -> (Type -> Exp Type)+  -> K.HContext -> (Type -> Type) -> Constraint+class GConstructable _Table _Columns f context rep where+  gconstruct :: ()+    => ToColumns _Table _Columns f context+    -> GFields f rep+    -> GColumns _Columns rep context+  gdeconstruct :: ()+    => FromColumns _Table _Columns f context+    -> GColumns _Columns rep context+    -> GFields f rep+++instance (GConstructable _Table _Columns f context rep) =>+  GConstructable _Table _Columns f context (M1 D meta rep)+ where+  gconstruct = gconstruct @_Table @_Columns @f @context @rep+  gdeconstruct = gdeconstruct @_Table @_Columns @f @context @rep+++instance (GConstructable _Table _Columns f context rep) =>+  GConstructable _Table _Columns f context (M1 C meta rep)+ where+  gconstruct = gconstruct @_Table @_Columns @f @context @rep+  gdeconstruct = gdeconstruct @_Table @_Columns @f @context @rep+++instance+  ( GConstructable _Table _Columns f context a+  , GConstructable _Table _Columns f context b+  )+  => GConstructable _Table _Columns f context (a :*: b)+ where+  gconstruct toColumns (a, b) = HProduct+    (gconstruct @_Table @_Columns @f @context @a toColumns a)+    (gconstruct @_Table @_Columns @f @context @b toColumns b)+  gdeconstruct fromColumns (HProduct a b) =+    ( gdeconstruct @_Table @_Columns @f @context @a fromColumns a+    , gdeconstruct @_Table @_Columns @f @context @b fromColumns b+    )+++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
+ src/Rel8/Generic/Map.hs view
@@ -0,0 +1,93 @@+{-# 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)+  )+where++-- base+import Data.Kind ( Constraint, Type )+import GHC.Generics+  ( (:+:)( L1, R1 ), (:*:)( (:*:) ), K1( K1 ), M1( M1 ), U1( U1 ), V1+  )+import Prelude ()++-- rel8+import Rel8.FCF ( Eval, Exp )+++type GMap :: (Type -> Exp Type) -> (Type -> Type) -> Type -> Type+type family GMap f rep where+  GMap f (M1 i c rep) = M1 i c (GMap f rep)+  GMap _ V1 = V1+  GMap f (rep1 :+: rep2) = GMap f rep1 :+: GMap f rep2+  GMap _ U1 = U1+  GMap f (rep1 :*: rep2) = GMap f rep1 :*: GMap f rep2+  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)
+ src/Rel8/Generic/Record.hs view
@@ -0,0 +1,153 @@+{-# language AllowAmbiguousTypes #-}+{-# language DataKinds #-}+{-# language FlexibleInstances #-}+{-# language MultiParamTypeClasses #-}+{-# language PolyKinds #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeApplications #-}+{-# language TypeFamilies #-}+{-# language TypeOperators #-}+{-# language UndecidableInstances #-}++module Rel8.Generic.Record+  ( Record(..)+  , GRecordable, GRecord, grecord, gunrecord+  )+where++-- base+import Data.Kind ( Constraint, Type )+import GHC.Generics+  ( Generic, Rep, from, to+  , (:+:)( L1, R1 ), (:*:)( (:*:) ), M1( M1 )+  , Meta( MetaCons, MetaSel ), D, C, S+  )+import GHC.TypeLits ( type (+), AppendSymbol, Div, Mod, Nat, Symbol )+import Prelude hiding ( Show )+++type GRecord :: (Type -> Type) -> Type -> Type+type family GRecord rep where+  GRecord (M1 D meta rep) = M1 D meta (GRecord rep)+  GRecord (l :+: r) = GRecord l :+: GRecord r+  GRecord (M1 C ('MetaCons name fixity 'False) rep) =+    M1 C ('MetaCons name fixity 'True) (Snd (Count 0 rep))+  GRecord rep = rep+++type Count :: Nat -> (Type -> Type) -> (Nat, Type -> Type)+type family Count n rep where+  Count n (M1 S ('MetaSel _selector su ss ds) rep) =+    '(n + 1, M1 S ('MetaSel ('Just (Show (n + 1))) su ss ds) rep)+  Count n (a :*: b) = CountHelper1 (Count n a) b+  Count n rep = '(n, rep)+++type CountHelper1 :: (Nat, Type -> Type) -> (Type -> Type) -> (Nat, Type -> Type)+type family CountHelper1 tuple b where+  CountHelper1 '(n, a) b = CountHelper2 a (Count n b)+++type CountHelper2 :: (Type -> Type) -> (Nat, Type -> Type) -> (Nat, Type -> Type)+type family CountHelper2 a tuple where+  CountHelper2 a '(n, b) = '(n, a :*: b)+++type Show :: Nat -> Symbol+type Show n =+  AppendSymbol "_" (AppendSymbol (Show' (Div n 10)) (ShowDigit (Mod n 10)))+++type Show' :: Nat -> Symbol+type family Show' n where+  Show' 0 = ""+  Show' n = AppendSymbol (Show' (Div n 10)) (ShowDigit (Mod n 10))+++type ShowDigit :: Nat -> Symbol+type family ShowDigit n where+  ShowDigit 0 = "0"+  ShowDigit 1 = "1"+  ShowDigit 2 = "2"+  ShowDigit 3 = "3"+  ShowDigit 4 = "4"+  ShowDigit 5 = "5"+  ShowDigit 6 = "6"+  ShowDigit 7 = "7"+  ShowDigit 8 = "8"+  ShowDigit 9 = "9"+++type Snd :: (a, b) -> b+type family Snd tuple where+  Snd '(_a, b) = b+++type GRecordable :: (Type -> Type) -> Constraint+class GRecordable rep where+  grecord :: rep x -> GRecord rep x+  gunrecord :: GRecord rep x -> rep x+++instance GRecordable rep => GRecordable (M1 D meta rep) where+  grecord (M1 a) = M1 (grecord a)+  gunrecord (M1 a) = M1 (gunrecord a)+++instance (GRecordable l, GRecordable r) => GRecordable (l :+: r) where+  grecord (L1 a) = L1 (grecord a)+  grecord (R1 a) = R1 (grecord a)+  gunrecord (L1 a) = L1 (gunrecord a)+  gunrecord (R1 a) = R1 (gunrecord a)+++instance Countable 0 rep =>+  GRecordable (M1 C ('MetaCons name fixity 'False) rep)+ where+  grecord (M1 a) = M1 (count @0 a)+  gunrecord (M1 a) = M1 (uncount @0 a)+++instance {-# OVERLAPPABLE #-} GRecord rep ~ rep => GRecordable rep where+  grecord = id+  gunrecord = id+++type Countable :: Nat -> (Type -> Type) -> Constraint+class Countable n rep where+  count :: rep x -> Snd (Count n rep) x+  uncount :: Snd (Count n rep) x -> rep x+++instance Countable n (M1 S ('MetaSel selector su ss ds) rep) where+  count (M1 a) = M1 a+  uncount (M1 a) = M1 a+++instance+  ( Countable n a, Countable n' b+  , '(n', a') ~ Count n a+  , Snd (CountHelper2 a' (Count n' b)) ~ (a' :*: Snd (Count n' b))+  )+  => Countable n (a :*: b)+ where+  count (a :*: b) = count @n a :*: count @n' b+  uncount (a :*: b) = uncount @n a :*: uncount @n' b+++instance {-# OVERLAPPABLE #-} Snd (Count n rep) ~ rep => Countable n rep where+  count = id+  uncount = id+++newtype Record a = Record+  { unrecord :: a+  }+++instance (Generic a, GRecordable (Rep a)) => Generic (Record a) where+  type Rep (Record a) = GRecord (Rep a)++  from (Record a) = grecord (from a)+  to = Record . to . gunrecord
+ src/Rel8/Generic/Reify.hs view
@@ -0,0 +1,24 @@+{-# 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
+ src/Rel8/Generic/Rel8able.hs view
@@ -0,0 +1,175 @@+{-# language AllowAmbiguousTypes #-}+{-# language DataKinds #-}+{-# language DefaultSignatures #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language MultiParamTypeClasses #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeApplications #-}+{-# language TypeFamilies #-}+{-# language UndecidableInstances #-}++module Rel8.Generic.Rel8able+  ( KRel8able, Rel8able+  , Algebra+  , GRep+  , GColumns, gfromColumns, gtoColumns+  , greify, gunreify+  , TUnreifyContext+  )+where++-- base+import Data.Kind ( Constraint, Type )+import Data.Proxy ( Proxy( Proxy ) )+import Data.Type.Equality ( (:~:)( Refl ) )+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.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.Schema.HTable ( HTable )+import qualified Rel8.Schema.Kind as K+import Rel8.Schema.Reify ( Reify, UnwrapReify )+import Rel8.Schema.Result ( Result )+import Rel8.Table+  ( fromColumns, toColumns, reify, unreify+  , TTable, TColumns, TContext, TUnreify+  )+++-- | The kind of 'Rel8able' types+type KRel8able :: Type+type KRel8able = K.Rel8able+++-- | 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:+--+-- @+-- data MyType f =+--   MyType { field1 :: Column f T1 OR HK1 f+--          , field2 :: Column f T2 OR HK2 f+--          , ...+--          , fieldN :: Column f Tn OR HKn f+--          }+-- @+--+-- where @Tn@ is any Haskell type, and @HKn@ is any higher-kinded type.+--+-- That is, higher-kinded data are records where all fields in the record are+-- all either of the type @Column f T@ (for any @T@), or are themselves+-- higher-kinded data:+--+-- [Nested]+--+-- @+-- data Nested f =+--   Nested { nested1 :: MyType f+--          , nested2 :: MyType f+--          }+-- @+--+-- The @Rel8able@ type class is used to give us a special mapping operation+-- that lets us change the type parameter @f@.+--+-- [Supplying @Rel8able@ instances]+--+-- This type class should be derived generically for all table types in your+-- project. To do this, enable the @DeriveAnyType@ and @DeriveGeneric@ language+-- extensions:+--+-- @+-- \{\-\# LANGUAGE DeriveAnyClass, DeriveGeneric #-\}+--+-- data MyType f = MyType { fieldA :: Column f T }+--   deriving ( GHC.Generics.Generic, Rel8able )+-- @+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))++  greify :: (Labelable context, Reifiable context)+    => t context -> t (Reify context)++  gunreify :: (Labelable context, Reifiable context)+    => t (Reify context) -> t context++  type GColumns t = G.GColumns TColumns (GRep t (Reify 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+    )+    => GColumns t (Col (Reify context)) -> t (Reify context)+  gfromColumns =+    unrecord .+    to .+    G.gfromColumns @(TTable (Reify context)) @TColumns fromColumns++  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+    )+    => t (Reify context) -> GColumns t (Col (Reify context))+  gtoColumns =+    G.gtoColumns @(TTable (Reify context)) @TColumns toColumns .+    from .+    Record++  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 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+++type Algebra :: K.Rel8able -> K.Algebra+type Algebra t = GAlgebra (GRep t (Reify Result))+++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))
+ src/Rel8/Generic/Rel8able/Test.hs view
@@ -0,0 +1,157 @@+{-# 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
+ src/Rel8/Generic/Table.hs view
@@ -0,0 +1,188 @@+{-# language AllowAmbiguousTypes #-}+{-# language DataKinds #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language MultiParamTypeClasses #-}+{-# language RankNTypes #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeApplications #-}+{-# language TypeFamilies #-}+{-# language TypeOperators #-}+{-# language UndecidableInstances #-}++module Rel8.Generic.Table+  ( GGTable, GGColumns, GGContext, ggfromColumns, ggtoColumns, ggtable+  , GGToExprs, ggfromResult, ggtoResult+  , GAlgebra+  )+where++-- base+import Data.Kind ( Constraint, Type )+import GHC.Generics ( (:+:), (:*:), K1, M1, U1, V1 )+import Prelude ()++-- 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+  )+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+  :: Algebra+  -> (Type -> Type -> Exp Constraint)+  -> (Type -> Exp K.HTable)+  -> (Type -> Type)+  -> (Type -> Type)+  -> Exp Constraint+++type instance Eval (GGToExprs 'Product _ToExprs _Columns exprs rep) =+  GToExprs _ToExprs _Columns exprs rep+++type instance Eval (GGToExprs 'Sum _ToExprs _Columns exprs rep) =+  GToExprsADT _ToExprs _Columns exprs rep+++data GGColumns+  :: Algebra+  -> (Type -> Exp K.HTable)+  -> (Type -> Type)+  -> Exp K.HTable+++type instance Eval (GGColumns 'Product _Columns rep) = GColumns _Columns rep+++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+  GAlgebra V1 = 'Sum+  GAlgebra (_ :+: _) = 'Sum+  GAlgebra U1 = 'Sum+  GAlgebra (_ :*: _) = 'Product+  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.+  ( KnownAlgebra algebra+  , Eval (GGToExprs algebra _ToExprs _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)+  -> rep x+ggfromResult = case algebraSing @algebra of+  SProduct -> gfromResult @_ToExprs @_Columns @exprs+  SSum -> gfromResultADT @_ToExprs @_Columns @exprs+++ggtoResult :: forall algebra _ToExprs _Columns exprs rep x.+  ( KnownAlgebra algebra+  , Eval (GGToExprs algebra _ToExprs _Columns exprs rep)+  )+  => (forall expr a proxy. Eval (_ToExprs expr a)+      => proxy expr+      -> a+      -> Eval (_Columns expr) (Col 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
+ src/Rel8/Generic/Table/ADT.hs view
@@ -0,0 +1,363 @@+{-# language AllowAmbiguousTypes #-}+{-# language DataKinds #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language LambdaCase #-}+{-# language MultiParamTypeClasses #-}+{-# language PolyKinds #-}+{-# language RankNTypes #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeApplications #-}+{-# language TypeFamilies #-}+{-# language TypeOperators #-}+{-# language UndecidableInstances #-}++module Rel8.Generic.Table.ADT+  ( GTableADT, GColumnsADT, gfromColumnsADT, gtoColumnsADT, gtableADT+  , GTableADT', GColumnsADT'+  , GToExprsADT, gfromResultADT, gtoResultADT+  )+where++-- base+import Data.Kind ( Constraint, Type )+import Data.Proxy ( Proxy( Proxy ) )+import GHC.Generics+  ( (:+:)( L1, R1 ), M1( M1 ), U1( U1 )+  , C, D+  , Meta( MetaCons )+  )+import GHC.TypeLits ( KnownSymbol, symbolVal )+import Prelude hiding ( null )++-- 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.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.Type.Tag ( Tag( Tag ) )++-- text+import Data.Text ( pack )+++type GColumnsADT+  :: (Type -> Exp K.HTable)+  -> (Type -> Type) -> K.HTable+type family GColumnsADT _Columns rep where+  GColumnsADT _Columns (M1 D _ rep) =+    GColumnsADT' _Columns (HLabel "tag" (HType Tag)) rep+++type GColumnsADT'+  :: (Type -> Exp K.HTable)+  -> K.HTable -> (Type -> Type) -> K.HTable+type family GColumnsADT' _Columns htable rep  where+  GColumnsADT' _Columns htable (a :+: b) =+    GColumnsADT' _Columns (GColumnsADT' _Columns htable a) b+  GColumnsADT' _Columns htable (M1 C ('MetaCons _ _ _) U1) = htable+  GColumnsADT' _Columns htable (M1 C ('MetaCons label _ _) rep) =+    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 -> Type -> Exp Constraint)+  -> (Type -> Exp K.HTable)+  -> (Type -> Type) -> (Type -> Type) -> Constraint+class GToExprsADT _ToExprs _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)+    -> rep x++  gtoResultADT :: ()+    => (forall expr a proxy.+        ( Eval (_ToExprs expr a)+        , HTable (Eval (_Columns expr))+        )+        => proxy expr+        -> a+        -> Eval (_Columns expr) (Col Result))+    -> rep x+    -> GColumnsADT _Columns exprs (Col Result)+++instance+  ( htable ~ HLabel "tag" (HType Tag)+  , GToExprsADT' _ToExprs _Columns htable exprs rep+  )+  => GToExprsADT _ToExprs _Columns (M1 D meta exprs) (M1 D meta rep)+ where+  gfromResultADT fromResult columns =+    case gfromResultADT' @_ToExprs @_Columns @_ @exprs 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++  gtoResultADT toResult (M1 rep) =+    gtoResultADT' @_ToExprs @_Columns @_ @exprs toResult tag (Just rep)+    where+      tag = hlabel @_ @"tag" labeler . HType . R+++type GToExprsADT'+  :: (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)+    -> 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))+    -> Maybe (rep x)+    -> GColumnsADT' _Columns htable exprs (Col Result)++  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+  )+  => GToExprsADT' _ToExprs _Columns htable (a :+: b) (rep1 :+: rep2)+ where+  gfromResultADT' fromResult f columns =+    case ma of+      Just a -> Just (L1 a)+      Nothing -> R1 <$>+        gfromResultADT' @_ToExprs @_Columns @_ @b @rep2+          fromResult+          (f . extract @_ToExprs @_Columns @_ @a @rep1)+          columns+    where+      ma =+        gfromResultADT' @_ToExprs @_Columns @_ @a @rep1+          fromResult+          f+          (extract @_ToExprs @_Columns @_ @b @rep2 columns)++  gtoResultADT' toResult tag = \case+    Just (L1 a) ->+      gtoResultADT' @_ToExprs @_Columns @_ @b @rep2+        toResult+        (\_ -> gtoResultADT' @_ToExprs @_Columns @_ @a @rep1+          toResult+          tag+          (Just a))+        Nothing+    Just (R1 b) ->+      gtoResultADT' @_ToExprs @_Columns @_ @b @rep2+        toResult+        (\tag' ->+          gtoResultADT' @_ToExprs @_Columns @_ @a @rep1+            toResult+            (\_ -> tag tag')+            Nothing)+        (Just b)+    Nothing ->+      gtoResultADT' @_ToExprs @_Columns @_ @b @rep2+        toResult+        (\_ -> gtoResultADT' @_ToExprs @_Columns @_ @a @rep1 toResult tag Nothing)+        Nothing++  extract =+    extract @_ToExprs @_Columns @_ @a @rep1 .+    extract @_ToExprs @_Columns @_ @b @rep2+++instance+  ( meta ~ 'MetaCons label _fixity _isRecord+  , KnownSymbol label+  )+  => GToExprsADT' _ToExprs _Columns htable (M1 C meta U1) (M1 C meta U1)+ where+  gfromResultADT' _ tag columns+    | tag columns == tag' = Just (M1 U1)+    | otherwise = Nothing+    where+      tag' = Tag $ pack $ symbolVal (Proxy @label)++  gtoResultADT' _ tag _ = tag tag'+    where+      tag' = Tag $ pack $ symbolVal (Proxy @label)++  extract = id+++instance {-# OVERLAPPABLE #-}+  ( HTable (GColumns _Columns exprs)+  , GToExprs _ToExprs _Columns exprs rep+  , meta ~ 'MetaCons label _fixity _isRecord+  , KnownSymbol label+  , GColumnsADT' _Columns htable (M1 C meta exprs) ~+      HProduct htable (HLabel label (HNullify (GColumns _Columns exprs)))+  )+  => GToExprsADT' _ToExprs _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)+    | otherwise = Nothing+    where+      tag' = Tag $ pack $ symbolVal (Proxy @label)++  gtoResultADT' toResult tag = \case+    Nothing -> HProduct (tag tag') (hlabel labeler (hnulls (const null)))+    Just (M1 rep) -> HProduct (tag tag') $+      hlabel labeler $+      hnullify nullifier $+      gtoResult @_ToExprs @_Columns @exprs 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)
+ src/Rel8/Generic/Table/Record.hs view
@@ -0,0 +1,206 @@+{-# language AllowAmbiguousTypes #-}+{-# language DataKinds #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language MultiParamTypeClasses #-}+{-# language PolyKinds #-}+{-# language RankNTypes #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeApplications #-}+{-# language TypeFamilies #-}+{-# language TypeOperators #-}+{-# language UndecidableInstances #-}++module Rel8.Generic.Table.Record+  ( GTable, GColumns, GContext, gfromColumns, gtoColumns, gtable+  , GToExprs, gfromResult, gtoResult+  )+where++-- base+import Data.Kind ( Constraint, Type )+import Data.Proxy ( Proxy( Proxy ) )+import GHC.Generics+  ( (:*:)( (:*:) ), K1( K1 ), M1( M1 )+  , 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+type family GColumns _Columns rep where+  GColumns _Columns (M1 D _ rep) = GColumns _Columns rep+  GColumns _Columns (M1 C _ rep) = GColumns _Columns rep+  GColumns _Columns (rep1 :*: rep2) =+    HProduct (GColumns _Columns rep1) (GColumns _Columns rep2)+  GColumns _Columns (M1 S ('MetaSel ('Just label) _ _ _) (K1 _ a)) =+    HLabel label (Eval (_Columns a))+++type GContext :: (Type -> Exp K.Context) -> (Type -> Type) -> K.Context+type family GContext _Context rep where+  GContext _Context (M1 _ _ rep) = GContext _Context rep+  GContext _Context (rep1 :*: _rep2) = GContext _Context rep1+  GContext _Context (K1 _ a) = Eval (_Context a)+++type GTable+  :: (Type -> Exp Constraint)+  -> (Type -> Exp K.HTable)+  -> K.HContext -> (Type -> Type) -> Constraint+class GTable _Table _Columns context rep+ where+  gfromColumns :: ()+    => (forall a. Eval (_Table a) => Eval (_Columns a) context -> a)+    -> GColumns _Columns rep context+    -> rep x++  gtoColumns :: ()+    => (forall a. Eval (_Table a) => a -> Eval (_Columns a) context)+    -> rep x+    -> GColumns _Columns rep context++  gtable :: ()+    => (forall a proxy. Eval (_Table a) => proxy a -> Eval (_Columns a) context)+    -> GColumns _Columns rep context+++instance GTable _Table _Columns context rep =>+  GTable _Table _Columns context (M1 D c 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+++instance GTable _Table _Columns context rep =>+  GTable _Table _Columns context (M1 C c 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+++instance+  ( GTable _Table _Columns context rep1+  , GTable _Table _Columns context rep2+  )+  => GTable _Table _Columns context (rep1 :*: rep2)+ 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)+++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)+ 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)+++instance GToExprs _ToExprs _Columns exprs rep =>+  GToExprs _ToExprs _Columns (M1 D c exprs) (M1 D c rep)+ where+  gfromResult fromResult =+    M1 . gfromResult @_ToExprs @_Columns @exprs fromResult+  gtoResult toResult (M1 a) =+    gtoResult @_ToExprs @_Columns @exprs toResult a+++instance GToExprs _ToExprs _Columns exprs rep =>+  GToExprs _ToExprs _Columns (M1 C c exprs) (M1 C c rep)+ where+  gfromResult fromResult =+    M1 . gfromResult @_ToExprs @_Columns @exprs fromResult+  gtoResult toResult (M1 a) =+    gtoResult @_ToExprs @_Columns @exprs toResult a+++instance+  ( GToExprs _ToExprs _Columns exprs1 rep1+  , GToExprs _ToExprs _Columns exprs2 rep2+  )+  => GToExprs _ToExprs _Columns (exprs1 :*: exprs2) (rep1 :*: rep2)+ where+  gfromResult fromResult (HProduct a b) =+    gfromResult @_ToExprs @_Columns @exprs1 fromResult a :*:+    gfromResult @_ToExprs @_Columns @exprs2 fromResult b+  gtoResult toResult (a :*: b) =+    HProduct+      (gtoResult @_ToExprs @_Columns @exprs1 toResult a)+      (gtoResult @_ToExprs @_Columns @exprs2 toResult b)+++instance+  ( Eval (_ToExprs exprs a)+  , HTable (Eval (_Columns exprs))+  , KnownSymbol label+  , meta ~ 'MetaSel ('Just label) _su _ss _ds+  , k1 ~ K1 i exprs+  , k1' ~ K1 i a+  )+  => GToExprs _ToExprs _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)
+ src/Rel8/Kind/Algebra.hs view
@@ -0,0 +1,38 @@+{-# language DataKinds #-}+{-# language FlexibleContexts #-}+{-# language GADTs #-}+{-# language StandaloneKindSignatures #-}++module Rel8.Kind.Algebra+  ( Algebra( Product, Sum )+  , SAlgebra( SProduct, SSum )+  , KnownAlgebra( algebraSing )+  )+where++-- base+import Data.Kind ( Constraint, Type )+import Prelude ()+++type Algebra :: Type+data Algebra = Product | Sum+++type SAlgebra :: Algebra -> Type+data SAlgebra algebra where+  SProduct :: SAlgebra 'Product+  SSum :: SAlgebra 'Sum+++type KnownAlgebra :: Algebra -> Constraint+class KnownAlgebra algebra where+  algebraSing :: SAlgebra algebra+++instance KnownAlgebra 'Product where+  algebraSing = SProduct+++instance KnownAlgebra 'Sum where+  algebraSing = SSum
+ src/Rel8/Kind/Context.hs view
@@ -0,0 +1,81 @@+{-# language DataKinds #-}+{-# language GADTs #-}+{-# language LambdaCase #-}+{-# language StandaloneKindSignatures #-}++module Rel8.Kind.Context+  ( Reifiable( contextSing )+  , SContext(..)+  , sReifiable+  , sLabelable+  )+where++-- base+import Data.Kind ( Constraint, Type )+import Prelude ()++-- 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.Kind ( Context )+import Rel8.Schema.Name ( Name )+import Rel8.Schema.Reify ( Reify )+import Rel8.Schema.Result ( Result )+++type SContext :: Context -> Type+data SContext context where+  SAggregate :: SContext Aggregate+  SExpr :: SContext Expr+  SName :: SContext Name+  SResult :: SContext Result+  SReify :: SContext context -> SContext (Reify context)+++type Reifiable :: Context -> Constraint+class Interpretation context => Reifiable context where+  contextSing :: SContext context+++instance Reifiable Aggregate where+  contextSing = SAggregate+++instance Reifiable Expr where+  contextSing = SExpr+++instance Reifiable 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
+ src/Rel8/Kind/Labels.hs view
@@ -0,0 +1,57 @@+{-# 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
+ src/Rel8/Order.hs view
@@ -0,0 +1,37 @@+{-# language DerivingStrategies #-}+{-# language GeneralizedNewtypeDeriving #-}+{-# language StandaloneKindSignatures #-}++module Rel8.Order+  ( Order(..)+  , toOrderExprs+  )+where++-- base+import Data.Functor.Contravariant ( Contravariant )+import Data.Kind ( Type )+import Prelude++-- contravariant+import Data.Functor.Contravariant.Divisible ( Decidable, Divisible )++-- opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye+import qualified Opaleye.Internal.Order as Opaleye+++-- | An ordering expression for @a@. Primitive orderings are defined with+-- 'Rel8.asc' and 'Rel8.desc', and you can combine @Order@ via its various+-- instances.+--+-- A common pattern is to use '<>' to combine multiple orderings in sequence,+-- and '>$<' (from 'Contravariant') to select individual columns.+type Order :: Type -> Type+newtype Order a = Order (Opaleye.Order a)+  deriving newtype (Contravariant, Divisible, Decidable, Semigroup, Monoid)+++toOrderExprs :: Order a -> a -> [Opaleye.OrderExpr]+toOrderExprs (Order (Opaleye.Order order)) a =+  uncurry Opaleye.OrderExpr <$> order a
+ src/Rel8/Query.hs view
@@ -0,0 +1,49 @@+{-# language DerivingVia #-}+{-# language GeneralizedNewtypeDeriving #-}+{-# language StandaloneKindSignatures #-}++module Rel8.Query+  ( Query( Query )+  )+where++-- base+import Data.Kind ( Type )+import Prelude++-- opaleye+import qualified Opaleye.Select as Opaleye++-- rel8+import Rel8.Query.Set ( unionAll )+import Rel8.Query.Values ( values )+import Rel8.Table.Alternative+  ( AltTable, (<|>:)+  , AlternativeTable, emptyTable+  )++-- semigroupoids+import Data.Functor.Apply ( Apply, WrappedApplicative(..) )+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)+++instance Bind Query where+  (>>-) = (>>=)+++-- | '<|>:' = 'unionAll'.+instance AltTable Query where+  (<|>:) = unionAll+++-- | 'emptyTable' = 'values' @[]@.+instance AlternativeTable Query where+  emptyTable = values []
+ src/Rel8/Query.hs-boot view
@@ -0,0 +1,17 @@+{-# language StandaloneKindSignatures #-}++module Rel8.Query+  ( Query( Query )+  )+where++-- base+import Data.Kind ( Type )+import Prelude ()++-- opaleye+import qualified Opaleye.Select as Opaleye+++type Query :: Type -> Type+newtype Query a = Query (Opaleye.Select a)
+ src/Rel8/Query/Aggregate.hs view
@@ -0,0 +1,37 @@+{-# language FlexibleContexts #-}+{-# language MonoLocalBinds #-}++module Rel8.Query.Aggregate+  ( aggregate+  , countRows+  )+where++-- base+import Data.Int ( Int64 )+import Prelude++-- opaleye+import qualified Opaleye.Aggregate as Opaleye++-- rel8+import Rel8.Aggregate ( Aggregates )+import Rel8.Expr ( Expr )+import Rel8.Expr.Aggregate ( countStar )+import Rel8.Query ( Query )+import Rel8.Query.Maybe ( optional )+import Rel8.Query.Opaleye ( mapOpaleye )+import Rel8.Table.Opaleye ( aggregator )+import Rel8.Table.Maybe ( maybeTable )+++-- | Apply an aggregation to all rows returned by a 'Query'.+aggregate :: Aggregates aggregates exprs => Query aggregates -> Query exprs+aggregate = mapOpaleye (Opaleye.aggregate aggregator)+++-- | Count the number of rows returned by a query. Note that this is different+-- from @countStar@, as even if the given query yields no rows, @countRows@+-- will return @0@.+countRows :: Query a -> Query (Expr Int64)+countRows = fmap (maybeTable 0 id) . optional . aggregate . fmap (const countStar)
+ src/Rel8/Query/Distinct.hs view
@@ -0,0 +1,45 @@+{-# options_ghc -fno-warn-redundant-constraints #-}++module Rel8.Query.Distinct+  ( distinct+  , distinctOn+  , distinctOnBy+  )+where++-- base+import Prelude++-- opaleye+import qualified Opaleye.Distinct as Opaleye+import qualified Opaleye.Internal.Order as Opaleye+import qualified Opaleye.Internal.QueryArr as Opaleye++-- rel8+import Rel8.Order ( Order( Order ) )+import Rel8.Query ( Query )+import Rel8.Query.Opaleye ( mapOpaleye )+import Rel8.Table.Eq ( EqTable )+import Rel8.Table.Opaleye ( distinctspec, unpackspec )+++-- | Select all distinct rows from a query, removing duplicates.  @distinct q@+-- is equivalent to the SQL statement @SELECT DISTINCT q@.+distinct :: EqTable a => Query a -> Query a+distinct = mapOpaleye (Opaleye.distinctExplicit distinctspec)+++-- | Select all distinct rows from a query, where rows are equivalent according+-- to a projection. If multiple rows have the same projection, it is+-- unspecified which row will be returned. If this matters, use 'distinctOnBy'.+distinctOn :: EqTable b => (a -> b) -> Query a -> Query a+distinctOn proj =+  mapOpaleye (\q -> Opaleye.productQueryArr (Opaleye.distinctOn unpackspec proj . Opaleye.runSimpleQueryArr q))+++-- | Select all distinct rows from a query, where rows are equivalent according+-- to a projection. If there are multiple rows with the same projection, the+-- first row according to the specified 'Order' will be returned.+distinctOnBy :: EqTable b => (a -> b) -> Order a -> Query a -> Query a+distinctOnBy proj (Order order) =+  mapOpaleye (\q -> Opaleye.productQueryArr (Opaleye.distinctOnBy unpackspec proj order . Opaleye.runSimpleQueryArr q))
+ src/Rel8/Query/Each.hs view
@@ -0,0 +1,32 @@+{-# language FlexibleContexts #-}+{-# language MonoLocalBinds #-}++module Rel8.Query.Each+  ( each+  )+where++-- base+import Prelude++-- opaleye+import qualified Opaleye.Table as Opaleye++-- rel8+import Rel8.Query ( Query )+import Rel8.Query.Opaleye ( fromOpaleye )+import Rel8.Schema.Name ( Selects )+import Rel8.Schema.Table ( TableSchema )+import Rel8.Table ( fromColumns, toColumns )+import Rel8.Table.Opaleye ( table, unpackspec )+++-- | Select each row from a table definition. This is equivalent to @FROM+-- table@.+each :: Selects names exprs => TableSchema names -> Query exprs+each =+  fmap fromColumns .+  fromOpaleye .+  Opaleye.selectTableExplicit unpackspec .+  table .+  fmap toColumns
+ src/Rel8/Query/Either.hs view
@@ -0,0 +1,65 @@+{-# language FlexibleContexts #-}++module Rel8.Query.Either+  ( keepLeftTable+  , keepRightTable+  , bitraverseEitherTable+  )+where++-- base+import Prelude++-- rel8+import Rel8.Expr.Eq ( (==.) )+import Rel8.Query ( Query )+import Rel8.Query.Filter ( where_ )+import Rel8.Query.Maybe ( optional )+import Rel8.Table.Either+  ( EitherTable( EitherTable )+  , isLeftTable, isRightTable+  )+import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )+++-- | Filter 'EitherTable's, keeping only 'leftTable's.+keepLeftTable :: EitherTable a b -> Query a+keepLeftTable e@(EitherTable _ a _) = do+  where_ $ isLeftTable e+  pure a+++-- | Filter 'EitherTable's, keeping only 'rightTable's.+keepRightTable :: EitherTable a b -> Query b+keepRightTable e@(EitherTable _ _ b) = do+  where_ $ isRightTable e+  pure b+++-- | @bitraverseEitherTable f g x@ will pass all @leftTable@s through @f@ and+-- all @rightTable@s through @g@. The results are then lifted back into+-- @leftTable@ and @rightTable@, respectively. This is similar to 'bitraverse'+-- for 'Either'.+--+-- For example,+--+-- >>> :{+-- select do+--   x <- values (map lit [ Left True, Right (42 :: Int32) ])+--   bitraverseEitherTable (\y -> values [y, not_ y]) (\y -> pure (y * 100)) x+-- :}+-- [ Left True+-- , Left False+-- , Right 4200+-- ]+bitraverseEitherTable :: ()+  => (a -> Query c)+  -> (b -> Query d)+  -> EitherTable a b+  -> Query (EitherTable c d)+bitraverseEitherTable f g e@(EitherTable tag _ _) = do+  mc@(MaybeTable _ c) <- optional (f =<< keepLeftTable e)+  md@(MaybeTable _ d) <- optional (g =<< keepRightTable e)+  where_ $ isJustTable mc ==. isLeftTable e+  where_ $ isJustTable md ==. isRightTable e+  pure $ EitherTable tag c d
+ src/Rel8/Query/Evaluate.hs view
@@ -0,0 +1,82 @@+{-# language DerivingStrategies #-}+{-# language FlexibleContexts #-}+{-# language GeneralizedNewtypeDeriving #-}+{-# language NamedFieldPuns #-}+{-# language StandaloneKindSignatures #-}++module Rel8.Query.Evaluate+  ( Evaluate+  , eval+  , evaluate+  )+where++-- base+import Data.Kind ( Type )+import Data.Monoid ( Endo ( Endo ), appEndo )+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+import qualified Opaleye.Internal.Unpackspec as Opaleye++-- rel8+import Rel8.Expr ( Expr )+import Rel8.Query ( Query( Query ) )+import Rel8.Table ( Table )+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))+  }+++-- | 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)+++instance Bind Evaluate where+  (>>-) = (>>=)+++-- | '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+  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'+++-- | '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')
+ src/Rel8/Query/Exists.hs view
@@ -0,0 +1,68 @@+{-# language DataKinds #-}++module Rel8.Query.Exists+  ( exists, inQuery+  , whereExists, with, withBy+  , whereNotExists, without, withoutBy+  )+where++-- base+import Prelude hiding ( filter )++-- opaleye+import qualified Opaleye.Operators as Opaleye++-- rel8+import Rel8.Expr ( Expr )+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+++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@+-- is equivalent to @WHERE EXISTS@ in SQL.+whereExists :: Query a -> Query ()+whereExists = mapOpaleye Opaleye.restrictExists+++-- | Produce the empty query if the given query returns rows. @whereNotExists@+-- is equivalent to @WHERE NOT EXISTS@ in SQL.+whereNotExists :: Query a -> Query ()+whereNotExists = 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 :: (a -> Query b) -> a -> Query a+with f a = a <$ whereExists (f a)+++-- | Like @with@, but with a custom membership test.+withBy :: (a -> b -> Expr Bool) -> Query b -> a -> Query a+withBy predicate bs = with $ \a -> bs >>= filter (predicate a)+++-- | Filter rows where @a -> Query b@ yields no rows.+without :: (a -> Query b) -> a -> Query a+without f a = a <$ whereNotExists (f a)+++-- | Like @without@, but with a custom membership test.+withoutBy :: (a -> b -> Expr Bool) -> Query b -> a -> Query a+withoutBy predicate bs = without $ \a -> bs >>= filter (predicate a)
+ src/Rel8/Query/Filter.hs view
@@ -0,0 +1,35 @@+module Rel8.Query.Filter+  ( filter+  , where_+  )+where++-- base+import Prelude hiding ( filter )++-- opaleye+import qualified Opaleye.Operators as Opaleye++-- profunctors+import Data.Profunctor ( lmap )++-- rel8+import Rel8.Expr ( Expr )+import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )+import Rel8.Query ( Query )+import Rel8.Query.Opaleye ( fromOpaleye )+++-- | @filter f x@ will be a zero-row query when @f x@ is @False@, and will+-- return @x@ unchanged when @f x@ is @True@. This is similar to+-- 'Control.Monad.guard', but as the predicate is separate from the argument,+-- it is easy to use in a pipeline of 'Query' transformations.+filter :: (a -> Expr Bool) -> a -> Query a+filter f a = a <$ where_ (f a)+++-- | Drop any rows that don't match a predicate.  @where_ expr@ is equivalent+-- to the SQL @WHERE expr@.+where_ :: Expr Bool -> Query ()+where_ condition =+  fromOpaleye $ lmap (\_ -> toColumn $ toPrimExpr condition) Opaleye.restrict
+ src/Rel8/Query/Limit.hs view
@@ -0,0 +1,27 @@+module Rel8.Query.Limit+  ( limit+  , offset+  )+where++-- base+import Prelude++-- opaleye+import qualified Opaleye++-- rel8+import Rel8.Query ( Query )+import Rel8.Query.Opaleye ( mapOpaleye )+++-- | @limit n@ select at most @n@ rows from a query.  @limit n@ is equivalent+-- to the SQL @LIMIT n@.+limit :: Word -> Query a -> Query a+limit = mapOpaleye . Opaleye.limit . fromIntegral+++-- | @offset n@ drops the first @n@ rows from a query. @offset n@ is equivalent+-- to the SQL @OFFSET n@.+offset :: Word -> Query a -> Query a+offset = mapOpaleye . Opaleye.offset . fromIntegral
+ src/Rel8/Query/List.hs view
@@ -0,0 +1,118 @@+{-# language FlexibleContexts #-}+{-# language GADTs #-}+{-# language NamedFieldPuns #-}++module Rel8.Query.List+  ( many, some+  , manyExpr, someExpr+  , catListTable, catNonEmptyTable+  , catList, catNonEmpty+  )+where++-- base+import Data.Functor.Identity ( runIdentity )+import Data.List.NonEmpty ( NonEmpty )+import Prelude++-- opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye++-- rel8+import Rel8.Expr ( Col( E, unE ), Expr )+import Rel8.Expr.Aggregate ( listAggExpr, nonEmptyAggExpr )+import Rel8.Expr.Opaleye ( mapPrimExpr )+import Rel8.Query ( Query )+import Rel8.Query.Aggregate ( aggregate )+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.Table.Aggregate ( listAgg, nonEmptyAgg )+import Rel8.Table.List ( ListTable( ListTable ) )+import Rel8.Table.Maybe ( maybeTable )+import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) )+import Rel8.Type ( DBType, typeInformation )+import Rel8.Type.Array ( extractArrayElement )+import Rel8.Type.Information ( TypeInformation )+++-- | Aggregate a 'Query' into a 'ListTable'. If the supplied query returns 0+-- rows, this function will produce a 'Query' that returns one row containing+-- the empty @ListTable@. If the supplied @Query@ does return rows, @many@ will+-- return exactly one row, with a @ListTable@ collecting all returned rows.+--+-- @many@ is analogous to 'Control.Applicative.many' from+-- @Control.Applicative@.+many :: Table Expr a => Query a -> Query (ListTable a)+many =+  fmap (maybeTable mempty (\(ListTable a) -> ListTable a)) .+  optional .+  aggregate .+  fmap (listAgg . toColumns)+++-- | Aggregate a 'Query' into a 'NonEmptyTable'. If the supplied query returns+-- 0 rows, this function will produce a 'Query' that is empty - that is, will+-- produce zero @NonEmptyTable@s. If the supplied @Query@ does return rows,+-- @some@ will return exactly one row, with a @NonEmptyTable@ collecting all+-- returned rows.+--+-- @some@ is analogous to 'Control.Applicative.some' from+-- @Control.Applicative@.+some :: Table Expr a => Query a -> Query (NonEmptyTable a)+some =+  fmap (\(NonEmptyTable a) -> NonEmptyTable a) .+  aggregate .+  fmap (nonEmptyAgg . toColumns)+++-- | A version of 'many' specialised to single expressions.+manyExpr :: Sql DBType a => Query (Expr a) -> Query (Expr [a])+manyExpr = fmap (maybeTable mempty id) . optional . aggregate . fmap listAggExpr+++-- | A version of 'many' specialised to single expressions.+someExpr :: Sql DBType a => Query (Expr a) -> Query (Expr (NonEmpty a))+someExpr = aggregate . fmap nonEmptyAggExpr+++-- | Expand a 'ListTable' into a 'Query', where each row in the query is an+-- 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+++-- | 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+++-- | Expand an expression that contains a list into a 'Query', where each row+-- in the query is an element of the given list.+--+-- @catList@ is an inverse to 'manyExpr'.+catList :: Sql DBType a => Expr [a] -> Query (Expr a)+catList = pure . sunnest typeInformation+++-- | Expand an expression that contains a non-empty list into a 'Query', where+-- each row in the query is an element of the given list.+--+-- @catNonEmpty@ is an inverse to 'someExpr'.+catNonEmpty :: Sql DBType a => Expr (NonEmpty a) -> Query (Expr a)+catNonEmpty = pure . sunnest typeInformation+++sunnest :: TypeInformation (Unnullify a) -> Expr (list a) -> Expr a+sunnest info = mapPrimExpr $+  extractArrayElement info .+  Opaleye.UnExpr (Opaleye.UnOpOther "UNNEST")
+ src/Rel8/Query/Maybe.hs view
@@ -0,0 +1,73 @@+module Rel8.Query.Maybe+  ( optional+  , catMaybeTable+  , traverseMaybeTable+  )+where++-- base+import Prelude++-- 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++-- rel8+import Rel8.Expr.Bool ( true )+import Rel8.Expr.Eq ( (==.) )+import Rel8.Expr.Opaleye ( toPrimExpr )+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 )+++-- | Convert a query that might return zero rows to a query that always returns+-- at least one row.+--+-- 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+++-- | Filter out 'MaybeTable's, returning only the tables that are not-null.+--+-- 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 ma@(MaybeTable _ a) = do+  where_ $ isJustTable ma+  pure 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 +-- @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 query ma@(MaybeTable input _) = do+  MaybeTable output b <- optional (query =<< catMaybeTable ma)+  where_ $ expr output ==. expr input+  pure $ MaybeTable input b
+ src/Rel8/Query/Null.hs view
@@ -0,0 +1,23 @@+module Rel8.Query.Null+  ( catNull+  )+where++-- base+import Prelude++-- rel8+import Rel8.Expr ( Expr )+import Rel8.Expr.Null ( isNonNull, unsafeUnnullify )+import Rel8.Query ( Query )+import Rel8.Query.Filter ( where_ )+++-- | Filter a 'Query' that might return @null@ to a 'Query' without any+-- @null@s.+--+-- Corresponds to 'Data.Maybe.catMaybes'.+catNull :: Expr (Maybe a) -> Query (Expr a)+catNull a = do+  where_ $ isNonNull a+  pure $ unsafeUnnullify a
+ src/Rel8/Query/Opaleye.hs view
@@ -0,0 +1,34 @@+module Rel8.Query.Opaleye+  ( fromOpaleye+  , toOpaleye+  , mapOpaleye+  , zipOpaleyeWith+  )+where++-- base+import Prelude++-- opaleye+import qualified Opaleye.Select as Opaleye++-- rel8+import {-# SOURCE #-} Rel8.Query ( Query( Query ) )+++fromOpaleye :: Opaleye.Select a -> Query a+fromOpaleye = Query+++toOpaleye :: Query a -> Opaleye.Select a+toOpaleye (Query a) = a+++mapOpaleye :: (Opaleye.Select a -> Opaleye.Select b) -> Query a -> Query b+mapOpaleye f = fromOpaleye . f . toOpaleye+++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)
+ src/Rel8/Query/Order.hs view
@@ -0,0 +1,20 @@+module Rel8.Query.Order+  ( orderBy+  )+where++-- base+import Prelude ()++-- opaleye+import qualified Opaleye.Order as Opaleye ( orderBy )++-- rel8+import Rel8.Order ( Order( Order ) )+import Rel8.Query ( Query )+import Rel8.Query.Opaleye ( mapOpaleye )+++-- | Order the rows returned by a query.+orderBy :: Order a -> Query a -> Query a+orderBy (Order o) = mapOpaleye (Opaleye.orderBy o)
+ src/Rel8/Query/SQL.hs view
@@ -0,0 +1,74 @@+{-# language FlexibleContexts #-}+{-# language TypeFamilies #-}+{-# language ViewPatterns #-}++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.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 )+++-- | Convert a query to a 'String' containing the query as 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))
+ src/Rel8/Query/Set.hs view
@@ -0,0 +1,58 @@+{-# language FlexibleContexts #-}++module Rel8.Query.Set+  ( union, unionAll+  , intersect, intersectAll+  , except, exceptAll+  )+where++-- base+import Prelude ()++-- opaleye+import qualified Opaleye.Binary as Opaleye++-- rel8+import Rel8.Expr ( Expr )+import {-# SOURCE #-} Rel8.Query ( Query )+import Rel8.Query.Opaleye ( zipOpaleyeWith )+import Rel8.Table ( Table  )+import Rel8.Table.Eq ( EqTable )+import Rel8.Table.Opaleye ( binaryspec )+++-- | Combine the results of two queries of the same type, collapsing+-- duplicates.  @union a b@ is the same as the SQL statement @x UNION b@.+union :: EqTable a => Query a -> Query a -> Query a+union = zipOpaleyeWith (Opaleye.unionExplicit binaryspec)+++-- | Combine the results of two queries of the same type, retaining duplicates.+-- @unionAll a b@ is the same as the SQL statement @x UNION ALL b@.+unionAll :: Table Expr a => Query a -> Query a -> Query a+unionAll = zipOpaleyeWith (Opaleye.unionAllExplicit binaryspec)+++-- | Find the intersection of two queries, collapsing duplicates.  @intersect a+-- b@ is the same as the SQL statement @x INTERSECT b@.+intersect :: EqTable a => Query a -> Query a -> Query a+intersect = zipOpaleyeWith (Opaleye.intersectExplicit binaryspec)+++-- | Find the intersection of two queries, retaining duplicates.  @intersectAll+-- a b@ is the same as the SQL statement @x INTERSECT ALL b@.+intersectAll :: EqTable a => Query a -> Query a -> Query a+intersectAll = zipOpaleyeWith (Opaleye.intersectAllExplicit binaryspec)+++-- | Find the difference of two queries, collapsing duplicates @except a b@ is+-- the same as the SQL statement @x INTERSECT b@.+except :: EqTable a => Query a -> Query a -> Query a+except = zipOpaleyeWith (Opaleye.exceptExplicit binaryspec)+++-- | Find the difference of two queries, retaining duplicates.  @exceptAll a b@+-- is the same as the SQL statement @x EXCEPT ALL b@.+exceptAll :: EqTable a => Query a -> Query a -> Query a+exceptAll = zipOpaleyeWith (Opaleye.exceptAllExplicit binaryspec)
+ src/Rel8/Query/These.hs view
@@ -0,0 +1,125 @@+{-# language FlexibleContexts #-}++module Rel8.Query.These+  ( alignBy+  , keepHereTable, loseHereTable+  , keepThereTable, loseThereTable+  , keepThisTable, loseThisTable+  , keepThatTable, loseThatTable+  , keepThoseTable, loseThoseTable+  , bitraverseTheseTable+  )+where++-- base+import Prelude++-- opaleye+import qualified Opaleye.Internal.Join as Opaleye+import qualified Opaleye.Internal.PrimQuery 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.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 )+  , hasHereTable, hasThereTable+  , isThisTable, isThatTable, isThoseTable+  )+import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ) )+++-- | Corresponds to a @FULL OUTER JOIN@ between two queries.+alignBy :: (Table Expr a, Table Expr b)+  => (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+++-- | Filter 'TheseTable's, keeping only 'thisTable's and 'thoseTable's.+keepHereTable :: TheseTable a b -> Query (a, MaybeTable b)+keepHereTable = loseThatTable+++-- | Filter 'TheseTable's, keeping on+loseHereTable :: TheseTable a b -> Query b+loseHereTable = keepThatTable+++keepThereTable :: TheseTable a b -> Query (MaybeTable a, b)+keepThereTable = loseThisTable+++loseThereTable :: TheseTable a b -> Query a+loseThereTable = keepThisTable+++keepThisTable :: TheseTable a b -> Query a+keepThisTable t@(TheseTable (MaybeTable _ a) _) = do+  where_ $ isThisTable t+  pure a+++loseThisTable :: TheseTable a b -> Query (MaybeTable a, b)+loseThisTable t@(TheseTable ma (MaybeTable _ b)) = do+  where_ $ not_ $ isThisTable t+  pure (ma, b)+++keepThatTable :: TheseTable a b -> Query b+keepThatTable t@(TheseTable _ (MaybeTable _ b)) = do+  where_ $ isThatTable t+  pure b+++loseThatTable :: TheseTable a b -> Query (a, MaybeTable b)+loseThatTable t@(TheseTable (MaybeTable _ a) mb) = do+  where_ $ not_ $ isThatTable t+  pure (a, mb)+++keepThoseTable :: TheseTable a b -> Query (a, b)+keepThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do+  where_ $ isThoseTable t+  pure (a, b)+++loseThoseTable :: TheseTable a b -> Query (EitherTable a b)+loseThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do+  where_ $ not_ $ isThoseTable t+  pure $ EitherTable result 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)+bitraverseTheseTable f g t = do+  mc <- optional (f . fst =<< keepHereTable t)+  md <- optional (g . snd =<< keepThereTable t)+  where_ $ isJustTable mc ==. hasHereTable t+  where_ $ isJustTable md ==. hasThereTable t+  pure $ TheseTable mc md
+ src/Rel8/Query/Values.hs view
@@ -0,0 +1,27 @@+{-# language FlexibleContexts #-}++module Rel8.Query.Values+  ( values+  )+where++-- base+import Data.Foldable ( toList )+import Prelude++-- opaleye+import qualified Opaleye.Values as Opaleye++-- rel8+import Rel8.Expr ( Expr )+import {-# SOURCE #-} Rel8.Query ( Query )+import Rel8.Query.Opaleye ( fromOpaleye )+import Rel8.Table ( Table )+import Rel8.Table.Opaleye ( valuesspec )+++-- | Construct a query that returns the given input list of rows. This is like+-- folding a list of 'return' statements under 'Rel8.union', but uses the SQL+-- @VALUES@ expression for efficiency.+values :: (Table Expr a, Foldable f) => f a -> Query a+values = fromOpaleye . Opaleye.valuesExplicit valuesspec . toList
+ src/Rel8/Schema/Context.hs view
@@ -0,0 +1,20 @@+{-# 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
+ src/Rel8/Schema/Context/Label.hs view
@@ -0,0 +1,62 @@+{-# 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
+ src/Rel8/Schema/Context/Nullify.hs view
@@ -0,0 +1,188 @@+{-# language DataKinds #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language InstanceSigs #-}+{-# language MultiParamTypeClasses #-}+{-# 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+  )+where++-- base+import Data.Kind ( Constraint, Type )+import GHC.TypeLits ( KnownSymbol )+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.Expr.Bool ( boolExpr )+import Rel8.Expr.Null ( nullify, unsafeUnnullify )+import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )+import Rel8.Schema.Context ( Interpretation )+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 )+++type Nullifiable :: K.Context -> Constraint+class Interpretation context => Nullifiable context where+  type ConstrainTag context :: Type -> Constraint+  type ConstrainTag _context = DefaultConstrainTag++  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)+++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 #-}+++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 #-}+++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)++  {-# INLINABLE encodeTag #-}+  {-# INLINABLE decodeTag #-}+  {-# INLINABLE nullifier #-}+  {-# INLINABLE unnullifier #-}+++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+++unnull :: Nullity a -> Expr (Nullify a) -> Expr a+unnull nullity a = case nullity of+  Null -> a+  NotNull -> unsafeUnnullify a+++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)++  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))++  hunnullifier :: ()+    => SSpec ('Spec labels x)+    -> context ('Spec labels (Nullify x))+    -> context ('Spec labels x)+++instance Nullifiable context => HNullifiable (Col context) where+  type HConstrainTag (Col context) = ConstrainTag context+  hencodeTag = encodeTag+  hdecodeTag = decodeTag+  hnullifier = nullifier+  hunnullifier = unnullifier+++instance HNullifiable (Dict (ConstrainDBType constraint)) where+  type HConstrainTag (Dict (ConstrainDBType constraint)) = constraint++  hencodeTag _ = Dict+  hdecodeTag = mempty+  hnullifier _ _ = ConstrainDBType.nullifier+  hunnullifier = ConstrainDBType.unnullifier+++type DefaultConstrainTag :: Type -> Constraint+class DefaultConstrainTag a+instance DefaultConstrainTag a
+ src/Rel8/Schema/Dict.hs view
@@ -0,0 +1,18 @@+{-# language ConstraintKinds #-}+{-# language GADTs #-}+{-# language PolyKinds #-}+{-# language StandaloneKindSignatures #-}++module Rel8.Schema.Dict+  ( Dict( Dict )+  )+where++-- base+import Data.Kind ( Constraint, Type )+import Prelude ()+++type Dict :: (a -> Constraint) -> a -> Type+data Dict c a where+  Dict :: c a => Dict c a
+ src/Rel8/Schema/HTable.hs view
@@ -0,0 +1,181 @@+{-# language AllowAmbiguousTypes #-}+{-# language DataKinds #-}+{-# language DefaultSignatures #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language FunctionalDependencies #-}+{-# language LambdaCase #-}+{-# language RankNTypes #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeApplications #-}+{-# language TypeFamilyDependencies #-}+{-# language TypeOperators #-}+{-# language UndecidableInstances #-}++module Rel8.Schema.HTable+  ( HTable (HField, HConstrainTable)+  , hfield, htabulate, htraverse, hdicts, hspecs+  , hmap, htabulateA+  )+where++-- base+import Data.Kind ( Constraint, Type )+import Data.Functor.Compose ( Compose( Compose ), getCompose )+import Data.Proxy ( Proxy )+import GHC.Generics+  ( (:*:)( (:*:) )+  , Generic (Rep, from, to)+  , K1( K1 )+  , M1( M1 )+  )+import Prelude++-- rel8+import Rel8.Schema.Dict ( Dict )+import Rel8.Schema.Spec ( Spec, SSpec )+import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )+import qualified Rel8.Schema.Kind as K++-- semigroupoids+import Data.Functor.Apply ( Apply, (<.>) )+++-- | A @HTable@ is a functor-indexed/higher-kinded data type that is+-- representable ('htabulate'/'hfield'), constrainable ('hdicts'), and+-- specified ('hspecs').+--+-- This is an internal concept for Rel8, and you should not need to define+-- 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++  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)+  hdicts :: HConstrainTable t c => t (Dict c)+  hspecs :: t SSpec++  type HField t = GHField t+  type HConstrainTable t c = HConstrainTable (GHColumns (Rep (t Proxy))) c++  default hfield ::+    ( Generic (t context)+    , HField t ~ GHField t+    , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))+    , GHTable context (Rep (t context))+    )+    => t context -> HField t spec -> context spec+  hfield table (GHField field) = hfield (toGHColumns (from table)) field++  default htabulate ::+    ( Generic (t context)+    , HField t ~ GHField t+    , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))+    , GHTable context (Rep (t context))+    )+    => (forall spec. HField t spec -> context spec) -> t context+  htabulate f = to $ fromGHColumns $ htabulate (f . GHField)++  default htraverse+    :: forall f g m+     . ( Apply m+       , Generic (t f), GHTable f (Rep (t f))+       , 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)+  htraverse f = fmap (to . fromGHColumns) . htraverse f . toGHColumns . from++  default hdicts+    :: forall c+     . ( Generic (t (Dict c))+       , GHTable (Dict c) (Rep (t (Dict c)))+       , GHColumns (Rep (t Proxy)) ~ GHColumns (Rep (t (Dict c)))+       , HConstrainTable (GHColumns (Rep (t Proxy))) c+       )+    => t (Dict c)+  hdicts = to $ fromGHColumns (hdicts @(GHColumns (Rep (t Proxy))) @c)++  default hspecs ::+    ( Generic (t SSpec)+    , GHTable SSpec (Rep (t SSpec))+    )+    => t SSpec+  hspecs = to $ fromGHColumns hspecs++  {-# INLINABLE hfield #-}+  {-# INLINABLE htabulate #-}+  {-# INLINABLE htraverse #-}+  {-# INLINABLE hdicts #-}+  {-# INLINABLE hspecs #-}+++hmap :: HTable t+  => (forall spec. context spec -> context' spec) -> 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)+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 GHTable :: K.HContext -> (Type -> Type) -> Constraint+class HTable (GHColumns rep) => GHTable context rep | rep -> context where+  type GHColumns rep :: K.HTable+  toGHColumns :: rep x -> GHColumns rep context+  fromGHColumns :: GHColumns rep context -> rep x+++instance GHTable context rep => GHTable context (M1 i c rep) where+  type GHColumns (M1 i c rep) = GHColumns rep+  toGHColumns (M1 a) = toGHColumns a+  fromGHColumns = M1 . fromGHColumns+++instance HTable table => GHTable context (K1 i (table context)) where+  type GHColumns (K1 i (table context)) = table+  toGHColumns (K1 a) = a+  fromGHColumns = K1+++instance (GHTable context a, GHTable context b) => GHTable context (a :*: b) where+  type GHColumns (a :*: b) = HProduct (GHColumns a) (GHColumns b)+  toGHColumns (a :*: b) = HProduct (toGHColumns a) (toGHColumns b)+  fromGHColumns (HProduct a b) = fromGHColumns a :*: fromGHColumns b+++-- | 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)+++instance (HTable x, HTable y) => HTable (HProduct x y) where+  type HConstrainTable (HProduct x y) c = (HConstrainTable x c, HConstrainTable y c)+  type HField (HProduct x y) = HProductField x y++  hfield (HProduct l r) = \case+    HFst i -> hfield l i+    HSnd i -> hfield r i++  htabulate f = HProduct (htabulate (f . HFst)) (htabulate (f . HSnd))+  htraverse f (HProduct x y) = HProduct <$> htraverse f x <.> htraverse f y+  hdicts = HProduct hdicts hdicts+  hspecs = HProduct hspecs hspecs++  {-# INLINABLE hfield #-}+  {-# INLINABLE htabulate #-}+  {-# INLINABLE htraverse #-}+  {-# INLINABLE hdicts #-}+  {-# INLINABLE hspecs #-}
+ src/Rel8/Schema/HTable/Either.hs view
@@ -0,0 +1,33 @@+{-# language DataKinds #-}+{-# language DeriveAnyClass #-}+{-# language DeriveGeneric #-}+{-# language DerivingStrategies #-}+{-# language StandaloneKindSignatures #-}++module Rel8.Schema.HTable.Either+  ( HEitherTable(..)+  )+where++-- base+import GHC.Generics ( Generic )+import Prelude ()++-- rel8+import Rel8.Schema.HTable ( HTable )+import Rel8.Schema.HTable.Identity ( HIdentity(..) )+import Rel8.Schema.HTable.Label ( HLabel )+import Rel8.Schema.HTable.Nullify ( HNullify )+import qualified Rel8.Schema.Kind as K+import Rel8.Schema.Spec ( Spec( Spec ) )+import Rel8.Type.Tag ( EitherTag )+++type HEitherTable :: K.HTable -> K.HTable -> K.HTable+data HEitherTable left right context = HEitherTable+  { htag :: HIdentity ('Spec '["isRight"] EitherTag) context+  , hleft :: HLabel "Left" (HNullify left) context+  , hright :: HLabel "Right" (HNullify right) context+  }+  deriving stock Generic+  deriving anyclass HTable
+ src/Rel8/Schema/HTable/Identity.hs view
@@ -0,0 +1,55 @@+{-# language DataKinds #-}+{-# language GADTs #-}+{-# language PatternSynonyms #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeFamilies #-}++module Rel8.Schema.HTable.Identity+  ( HIdentity( HIdentity, HType, unHIdentity )+  , HType+  )+where++-- base+import Data.Kind ( Type )+import Prelude++-- rel8+import Rel8.Schema.Dict ( Dict( Dict ) )+import Rel8.Schema.HTable+  ( HTable, HConstrainTable, HField+  , 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 #-}+++type HIdentity :: Spec -> K.HTable+newtype HIdentity spec context = HIdentity+  { unHIdentity :: context spec+  }+++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++  hfield (HIdentity a) HIdentityField = a+  htabulate f = HIdentity $ f HIdentityField+  htraverse f (HIdentity a) = HIdentity <$> f a+  hdicts = HIdentity Dict+  hspecs = HIdentity specSing
+ src/Rel8/Schema/HTable/Label.hs view
@@ -0,0 +1,83 @@+{-# 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 TypeFamilies #-}+{-# language TypeOperators #-}+{-# language UndecidableInstances #-}++module Rel8.Schema.HTable.Label+  ( HLabel, Label+  , hlabel, hunlabel+  )+where++-- base+import Data.Proxy ( Proxy( Proxy ) )+import GHC.TypeLits ( KnownSymbol, Symbol )+import Prelude++-- rel8+import Rel8.Kind.Labels ( SLabels( SCons ) )+import Rel8.Schema.HTable+  ( HTable+  , hfield, htabulate, 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)+++type HLabel :: Symbol -> K.HTable -> K.HTable+newtype HLabel label table context = HLabel (HMapTable (Label label) table context)+  deriving stock Generic+  deriving anyclass HTable+++data Label :: Symbol -> Spec -> Exp Spec+++type instance Eval (Label label ('Spec labels a)) = 'Spec (label : labels) a+++instance KnownSymbol l => MapSpec (Label l) where+  mapInfo = \case+    SSpec {..} -> SSpec {labels = SCons Proxy labels, ..}+++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)+{-# 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+{-# INLINABLE hunlabel #-}
+ src/Rel8/Schema/HTable/List.hs view
@@ -0,0 +1,18 @@+{-# language DataKinds #-}+{-# language StandaloneKindSignatures #-}++module Rel8.Schema.HTable.List+  ( HListTable+  )+where++-- base+import Prelude ()++-- rel8+import qualified Rel8.Schema.Kind as K+import Rel8.Schema.HTable.Vectorize ( HVectorize )+++type HListTable :: K.HTable -> K.HTable+type HListTable = HVectorize []
+ src/Rel8/Schema/HTable/MapTable.hs view
@@ -0,0 +1,89 @@+{-# language AllowAmbiguousTypes #-}+{-# language BlockArguments #-}+{-# language ConstraintKinds #-}+{-# language DataKinds #-}+{-# language FlexibleInstances #-}+{-# language GADTs #-}+{-# language InstanceSigs #-}+{-# language MultiParamTypeClasses #-}+{-# language PolyKinds #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeApplications #-}+{-# language TypeFamilies #-}+{-# language UndecidableInstances #-}+{-# language UndecidableSuperClasses #-}++module Rel8.Schema.HTable.MapTable+  ( HMapTable(..)+  , MapSpec(..)+  , Precompose(..)+  , HMapTableField(..)+  )+where++-- base+import Data.Kind ( Constraint, Type )+import Prelude ( ($), (.), (<$>), fmap )++-- rel8+import Rel8.FCF+import Rel8.Schema.HTable+import Rel8.Schema.Spec ( Spec, SSpec )+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 Precompose :: (a -> Exp b) -> (b -> Type) -> a -> Type+newtype Precompose f g x = Precompose+  { precomposed :: g (Eval (f x))+  }+++type HMapTableField :: (Spec -> Exp a) -> K.HTable -> a -> Type+data HMapTableField f t x where+  HMapTableField :: HField t a -> HMapTableField f t (Eval (f a))+++instance (HTable t, MapSpec f) => HTable (HMapTable f t) where+  type HField (HMapTable f t) = +    HMapTableField f t++  type HConstrainTable (HMapTable f t) c =+    HConstrainTable t (ComposeConstraint f c)++  hfield (HMapTable x) (HMapTableField i) = +    precomposed (hfield x i) ++  htabulate f = +    HMapTable $ htabulate (Precompose . f . HMapTableField)++  htraverse f (HMapTable x) = +    HMapTable <$> htraverse (fmap Precompose . f . precomposed) x+  {-# INLINABLE htraverse #-}++  hdicts :: forall c. HConstrainTable (HMapTable f t) c => HMapTable f t (Dict c)+  hdicts = +    htabulate \(HMapTableField j) ->+      case hfield (hdicts @_ @(ComposeConstraint f c)) j of+        Dict -> Dict++  hspecs = +    HMapTable $ htabulate $ Precompose . mapInfo @f . hfield hspecs+  {-# INLINABLE hspecs #-}+++type MapSpec :: (Spec -> Exp Spec) -> Constraint+class MapSpec f where+  mapInfo :: SSpec x -> SSpec (Eval (f x))+++type ComposeConstraint :: (a -> Exp b) -> (b -> Constraint) -> a -> Constraint+class c (Eval (f a)) => ComposeConstraint f c a+instance c (Eval (f a)) => ComposeConstraint f c a
+ src/Rel8/Schema/HTable/Maybe.hs view
@@ -0,0 +1,32 @@+{-# language DataKinds #-}+{-# language DeriveAnyClass #-}+{-# language DeriveGeneric #-}+{-# language DerivingStrategies #-}+{-# language StandaloneKindSignatures #-}++module Rel8.Schema.HTable.Maybe+  ( HMaybeTable(..)+  )+where++-- base+import GHC.Generics ( Generic )+import Prelude++-- rel8+import Rel8.Schema.HTable ( HTable )+import Rel8.Schema.HTable.Identity ( HIdentity(..) )+import Rel8.Schema.HTable.Label ( HLabel )+import Rel8.Schema.HTable.Nullify ( HNullify )+import qualified Rel8.Schema.Kind as K+import Rel8.Schema.Spec ( Spec( Spec ) )+import Rel8.Type.Tag ( MaybeTag )+++type HMaybeTable :: K.HTable -> K.HTable+data HMaybeTable table context = HMaybeTable+  { htag :: HIdentity ('Spec '["isJust"] (Maybe MaybeTag)) context+  , hjust :: HLabel "Just" (HNullify table) context+  }+  deriving stock Generic+  deriving anyclass HTable
+ src/Rel8/Schema/HTable/NonEmpty.hs view
@@ -0,0 +1,19 @@+{-# language DataKinds #-}+{-# language StandaloneKindSignatures #-}++module Rel8.Schema.HTable.NonEmpty+  ( HNonEmptyTable+  )+where++-- base+import Data.List.NonEmpty ( NonEmpty )+import Prelude ()++-- rel8+import Rel8.Schema.HTable.Vectorize ( HVectorize )+import qualified Rel8.Schema.Kind as K+++type HNonEmptyTable :: K.HTable -> K.HTable+type HNonEmptyTable = HVectorize NonEmpty
+ src/Rel8/Schema/HTable/Nullify.hs view
@@ -0,0 +1,102 @@+{-# language ConstraintKinds #-}+{-# language DataKinds #-}+{-# language DeriveAnyClass #-}+{-# language DerivingStrategies #-}+{-# language DeriveGeneric #-}+{-# language FlexibleInstances #-}+{-# language GADTs #-}+{-# language LambdaCase #-}+{-# language MultiParamTypeClasses #-}+{-# language NamedFieldPuns #-}+{-# language QuantifiedConstraints #-}+{-# language RankNTypes #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeFamilies #-}+{-# language UndecidableInstances #-}++module Rel8.Schema.HTable.Nullify+  ( HNullify( HNullify )+  , Nullify+  , hnulls, hnullify, hunnullify+  )+where++-- base+import Prelude hiding ( null )++-- rel8+import Rel8.Schema.HTable ( HTable, hfield, htabulate, htabulateA, hspecs )+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(..) )++-- semigroupoids+import Data.Functor.Apply ( Apply )+import Rel8.Schema.HTable.MapTable+import Rel8.FCF+import GHC.Generics (Generic)+++type HNullify :: K.HTable -> K.HTable+newtype HNullify table context = HNullify (HMapTable Nullify table context)+  deriving stock Generic+  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)+++instance MapSpec Nullify where+  mapInfo = \case+    SSpec{labels, info, nullity} -> SSpec+      { labels+      , info+      , nullity = case nullity of+          Null    -> Null+          NotNull -> Null+      } +++hnulls :: HTable t+  => (forall labels a. ()+    => SSpec ('Spec labels a)+    -> context ('Spec labels (Type.Nullify a)))+  -> HNullify t context+hnulls null = HNullify $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of+  spec@SSpec {} -> null spec+{-# INLINABLE hnulls #-}+++hnullify :: HTable t+  => (forall labels a. ()+    => SSpec ('Spec labels a)+    -> context ('Spec labels a)+    -> context ('Spec labels (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)+{-# 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)))+  -> 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+      a -> unnullifier spec a+{-# INLINABLE hunnullify #-}
+ src/Rel8/Schema/HTable/Product.hs view
@@ -0,0 +1,17 @@+{-# language DataKinds #-}+{-# language StandaloneKindSignatures #-}++module Rel8.Schema.HTable.Product+  ( HProduct(..)+  )+where++-- base+import Prelude ()++-- rel8+import qualified Rel8.Schema.Kind as K+++type HProduct :: K.HTable -> K.HTable -> K.HTable+data HProduct a b context = HProduct (a context) (b context)
+ src/Rel8/Schema/HTable/These.hs view
@@ -0,0 +1,34 @@+{-# language DataKinds #-}+{-# language DeriveAnyClass #-}+{-# language DeriveGeneric #-}+{-# language DerivingStrategies #-}+{-# language StandaloneKindSignatures #-}++module Rel8.Schema.HTable.These+  ( HTheseTable(..)+  )+where++-- base+import GHC.Generics ( Generic )+import Prelude++-- rel8+import Rel8.Schema.HTable ( HTable )+import Rel8.Schema.HTable.Identity ( HIdentity )+import Rel8.Schema.HTable.Label ( HLabel )+import Rel8.Schema.HTable.Nullify ( HNullify )+import qualified Rel8.Schema.Kind as K+import Rel8.Schema.Spec ( Spec( Spec ) )+import Rel8.Type.Tag ( MaybeTag )+++type HTheseTable :: K.HTable -> K.HTable -> K.HTable+data HTheseTable here there context = HTheseTable+  { hhereTag :: HIdentity ('Spec '["hasHere"] (Maybe MaybeTag)) context+  , hhere :: HLabel "Here" (HNullify here) context+  , hthereTag :: HIdentity ('Spec '["hasThere"] (Maybe MaybeTag)) context+  , hthere :: HLabel "There" (HNullify there) context+  }+  deriving stock Generic+  deriving anyclass HTable
+ src/Rel8/Schema/HTable/Vectorize.hs view
@@ -0,0 +1,151 @@+{-# language AllowAmbiguousTypes #-}+{-# language ConstraintKinds #-}+{-# language DataKinds #-}+{-# language DeriveAnyClass #-}+{-# language DeriveGeneric #-}+{-# language DerivingStrategies #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language GADTs #-}+{-# language LambdaCase #-}+{-# language MultiParamTypeClasses #-}+{-# language NamedFieldPuns #-}+{-# language QuantifiedConstraints #-}+{-# language RankNTypes #-}+{-# language RecordWildCards #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeApplications #-}+{-# language TypeFamilies #-}+{-# language UndecidableInstances #-}++module Rel8.Schema.HTable.Vectorize+  ( HVectorize+  , hvectorize, hunvectorize+  , happend, hempty+  )+where++-- base+import Data.Kind ( Type )+import Data.List.NonEmpty ( NonEmpty )+import Prelude++-- rel8+import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler )+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.Null ( Unnullify, NotNull, Nullity( NotNull ) )+import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )+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+  listNotNull :: proxy a -> Dict NotNull (list a)+  vectorTypeInformation :: ()+    => Nullity a+    -> TypeInformation (Unnullify a)+    -> TypeInformation (list a)+++instance Vector [] where+  listNotNull _ = Dict+  vectorTypeInformation = listTypeInformation+++instance Vector NonEmpty where+  listNotNull _ = Dict+  vectorTypeInformation = nonEmptyTypeInformation+++type HVectorize :: (Type -> Type) -> K.HTable -> K.HTable+newtype HVectorize list table context = HVectorize (HMapTable (Vectorize list) table context)+  deriving stock Generic+  deriving anyclass HTable+++data Vectorize :: (Type -> Type) -> Spec -> Exp Spec+++type instance Eval (Vectorize list ('Spec labels a)) = 'Spec labels (list a)+++instance Vector list => MapSpec (Vectorize list) where+  mapInfo = \case+    SSpec {..} -> case listNotNull @list nullity of+      Dict -> SSpec+        { nullity = NotNull+        , info = vectorTypeInformation nullity info+        , ..+        }+++hvectorize :: (HTable t, Unzip f, Vector list)+  => (forall labels a. ()+    => SSpec ('Spec labels a)+    -> f (context ('Spec labels a))+    -> context' ('Spec labels (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)+{-# 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)))+  -> 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+      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))+  )+  -> 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+++hempty :: HTable t =>+  ( forall labels a. ()+    => Nullity a+    -> TypeInformation (Unnullify a)+    -> context ('Spec labels [a])+  )+  -> HVectorize [] t context+hempty empty = HVectorize $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of+  SSpec {nullity, info} -> empty nullity info+++instance HLabelable g => HLabelable (Precompose (Vectorize list) g) where+  hlabeler = Precompose . hlabeler . precomposed+  hunlabeler = Precompose . hunlabeler . precomposed
+ src/Rel8/Schema/Kind.hs view
@@ -0,0 +1,33 @@+{-# language StandaloneKindSignatures #-}++module Rel8.Schema.Kind+  ( Context, Rel8able+  , HContext, HTable+  )+where++-- base+import Data.Kind ( Type )+import Prelude ()++-- rel8+import Rel8.Schema.Spec ( Spec )+++type HContext :: Type+type HContext = Spec -> Type+++type HTable :: Type+type HTable = HContext -> Type+++data X+++type Context :: Type+type Context = X -> Type+++type Rel8able :: Type+type Rel8able = Context -> Type
+ src/Rel8/Schema/Name.hs view
@@ -0,0 +1,99 @@+{-# language DataKinds #-}+{-# language DerivingStrategies #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language GADTs #-}+{-# 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+  )+where++-- base+import Data.Functor.Identity ( Identity )+import Data.Kind ( Constraint, Type )+import Data.String ( IsString, fromString )+import Prelude++-- 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 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+  )+import Rel8.Table.Recontextualize ( Recontextualize )+import Rel8.Type ( DBType )+++-- | A @Name@ is the name of a column, as it would be defined in a table's+-- 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+++instance Sql DBType a => Table Name (Name a) where+  type Columns (Name a) = HType 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)+++instance Labelable Name where+  labeler (N a) = N a+  unlabeler (N a) = N 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
+ src/Rel8/Schema/Null.hs view
@@ -0,0 +1,110 @@+{-# language ConstraintKinds #-}+{-# language DataKinds #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language GADTs #-}+{-# language MultiParamTypeClasses #-}+{-# language RankNTypes #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeFamilies #-}+{-# language UndecidableInstances #-}+{-# language UndecidableSuperClasses #-}++module Rel8.Schema.Null+  ( Nullify, Unnullify+  , NotNull+  , Homonullable+  , Nullity( Null, NotNull )+  , Nullable, nullable+  , Sql+  )+where++-- base+import Data.Kind ( Constraint, Type )+import Prelude+++type IsMaybe :: Type -> Bool+type family IsMaybe a where+  IsMaybe (Maybe _) = 'True+  IsMaybe _ = 'False+++type Unnullify' :: Bool -> Type -> Type+type family Unnullify' isMaybe ma where+  Unnullify' 'False a = a+  Unnullify' 'True (Maybe a) = a+++type Unnullify :: Type -> Type+type Unnullify a = Unnullify' (IsMaybe a) a+++type Nullify' :: Bool -> Type -> Type+type family Nullify' isMaybe a where+  Nullify' 'False a = a+  Nullify' 'True a = Maybe a+++type Nullify :: Type -> Type+type Nullify a = Maybe (Unnullify a)+++-- | @nullify a@ means @a@ cannot take @null@ as a value.+type NotNull :: Type -> Constraint+class (Nullable a, IsMaybe a ~ 'False) => NotNull a+instance (Nullable a, IsMaybe a ~ 'False) => NotNull a+++-- | @Homonullable a b@ means that both @a@ and @b@ can be @null@, or neither+-- @a@ or @b@ can be @null@.+type Homonullable :: Type -> Type -> Constraint+class IsMaybe a ~ IsMaybe b => Homonullable a b+instance IsMaybe a ~ IsMaybe b => Homonullable a b+++type Nullity :: Type -> Type+data Nullity a where+  NotNull :: NotNull a => Nullity a+  Null :: NotNull a => Nullity (Maybe a)+++type Nullable' :: Bool -> Type -> Constraint+class+  ( IsMaybe a ~ isMaybe+  , IsMaybe (Unnullify a) ~ 'False+  , Nullify' isMaybe (Unnullify a) ~ a+  ) => Nullable' isMaybe a+ where+  nullable' :: Nullity a+++instance IsMaybe a ~ 'False => Nullable' 'False a where+  nullable' = NotNull+++instance IsMaybe a ~ 'False => Nullable' 'True (Maybe a) where+  nullable' = Null+++-- | @Nullable a@ means that @rel8@ is able to check if the type @a@ is a+-- type that can take @null@ values or not.+type Nullable :: Type -> Constraint+class Nullable' (IsMaybe a) a => Nullable a+instance Nullable' (IsMaybe a) a => Nullable a+++nullable :: Nullable a => Nullity a+nullable = nullable'+++-- | The @Sql@ type class describes both null and not null database values,+-- constrained by a specific class.+--+-- For example, if you see @Sql DBEq a@, this means any database type that+-- supports equality, and @a@ can either be exactly an @a@, or it could also be+-- @Maybe a@.+type Sql :: (Type -> Constraint) -> Type -> Constraint+class (constraint (Unnullify a), Nullable a) => Sql constraint a+instance (constraint (Unnullify a), Nullable a) => Sql constraint a
+ src/Rel8/Schema/Reify.hs view
@@ -0,0 +1,74 @@+{-# 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
+ src/Rel8/Schema/Result.hs view
@@ -0,0 +1,79 @@+{-# language DataKinds #-}+{-# language GADTs #-}+{-# language NamedFieldPuns #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeFamilies #-}++module Rel8.Schema.Result+  ( Col( R, unR ), Result+  , relabel+  , null, nullifier, unnullifier+  , vectorizer, unvectorizer+  )+where++-- base+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(..) )+++-- | The @Result@ context is the context used for decoded query results.+--+-- 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)+++null :: Col Result ('Spec labels (Maybe a))+null = R 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+  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) =+  case nullity of+    Null -> pure $ R a+    NotNull -> R <$> a+++vectorizer :: Functor f+  => SSpec ('Spec labels a)+  -> f (Col Result ('Spec labels a))+  -> Col Result ('Spec labels (f a))+vectorizer _ = R . fmap unR+++unvectorizer :: Functor f+  => SSpec ('Spec labels a)+  -> Col Result ('Spec labels (f a))+  -> f (Col Result ('Spec labels a))+unvectorizer _ (R results) = R <$> results
+ src/Rel8/Schema/Spec.hs view
@@ -0,0 +1,54 @@+{-# language DataKinds #-}+{-# language FlexibleContexts #-}+{-# language GADTs #-}+{-# language StandaloneKindSignatures #-}+{-# language UndecidableInstances #-}++module Rel8.Schema.Spec+  ( Spec( Spec )+  , SSpec( SSpec, labels, info, nullity )+  , KnownSpec( specSing )+  )+where++-- base+import Data.Kind ( Constraint, 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+++instance+  ( KnownLabels labels+  , Sql DBType a+  )+  => KnownSpec ('Spec labels a)+ where+  specSing = SSpec+    { labels = labelsSing+    , info = typeInformation+    , nullity = nullable+    }
+ src/Rel8/Schema/Spec/ConstrainDBType.hs view
@@ -0,0 +1,89 @@+{-# 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
+ src/Rel8/Schema/Table.hs view
@@ -0,0 +1,29 @@+{-# language DeriveFunctor #-}+{-# language DerivingStrategies #-}++module Rel8.Schema.Table+  ( TableSchema(..)+  )+where++-- base+import Prelude+++-- | 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.+-- +-- For each selectable table in your database, you should provide a+-- @TableSchema@ in order to interact with the table via Rel8.+data TableSchema names = TableSchema+  { name :: String+    -- ^ The name of the table.+  , schema :: Maybe String+    -- ^ The schema that this table belongs to. If 'Nothing', whatever is on+    -- the connection's @search_path@ will be used.+  , columns :: names+    -- ^ The columns of the table. Typically you would use a a higher-kinded+    -- data type here, parameterized by the 'Rel8.ColumnSchema.ColumnSchema' functor.+  }+  deriving stock Functor
+ src/Rel8/Statement/Delete.hs view
@@ -0,0 +1,92 @@+{-# language DuplicateRecordFields #-}+{-# language GADTs #-}+{-# language NamedFieldPuns #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeApplications #-}++module Rel8.Statement.Delete+  ( Delete(..)+  , delete+  )+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++-- rel8+import Rel8.Expr ( Expr )+import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )+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 )++-- text+import qualified Data.Text as Text+import Data.Text.Encoding ( encodeUtf8 )+++-- | The constituent parts of a @DELETE@ statement.+type Delete :: Type -> Type+data Delete a where+  Delete :: Selects names exprs =>+    { from :: TableSchema names+      -- ^ Which table to delete from.+    , deleteWhere :: exprs -> Expr Bool+      -- ^ Which rows should be selected for deletion.+    , returning :: Returning names a+      -- ^ What to return from the @DELETE@ statement.+    }+    -> 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++    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+  where+    decoder :: forall exprs projection a. Serializable projection a+      => (exprs -> projection) -> Hasql.Result [a]+    decoder _ = Hasql.rowList (parse @projection @a)
+ src/Rel8/Statement/Insert.hs view
@@ -0,0 +1,118 @@+{-# language DuplicateRecordFields #-}+{-# language GADTs #-}+{-# language NamedFieldPuns #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeApplications #-}++module Rel8.Statement.Insert+  ( Insert(..)+  , OnConflict(..)+  , insert+  )+where++-- base+import Control.Exception ( throwIO )+import Data.List.NonEmpty ( NonEmpty( (:|) ) )+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++-- 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 )++-- 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+      -- ^ What to do if the inserted rows conflict with data already in the+      -- table.+    , returning :: Returning names a+      -- ^ What information to return on completion.+    }+    -> 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 []++    (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++  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)
+ src/Rel8/Statement/Returning.hs view
@@ -0,0 +1,29 @@+{-# language GADTs #-}+{-# language StandaloneKindSignatures #-}++module Rel8.Statement.Returning+  ( Returning(..)+  )+where++-- base+import Data.Int ( Int64 )+import Data.Kind ( Type )+import Prelude ()++-- rel8+import Rel8.Schema.Name ( Selects )+import Rel8.Table.Serialize ( Serializable )+++-- | @INSERT@, @UPDATE@ and @DELETE@ all support returning either the number of+-- rows affected, or the actual rows modified. 'Projection' allows you to+-- project out of these returned rows, which can be useful if you want to log+-- exactly which rows were deleted, or to view a generated id (for example, if+-- using a column with an autoincrementing counter as a default value).+type Returning :: Type -> Type -> Type+data Returning names a where+  NumberOfRowsAffected :: Returning names Int64+  Projection :: (Selects names exprs, Serializable projection a)+    => (exprs -> projection)+    -> Returning names [a]
+ src/Rel8/Statement/Select.hs view
@@ -0,0 +1,62 @@+{-# language MonoLocalBinds #-}+{-# language ScopedTypeVariables #-}+{-# language TypeApplications #-}++module Rel8.Statement.Select+  ( select+  , selectWithNames+  )+where++-- base+import Control.Exception ( throwIO )+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++-- rel8+import Rel8.Query ( Query )+import Rel8.Query.SQL ( sqlForQuery, sqlForQueryWithNames )+import Rel8.Schema.Name ( Selects )+import Rel8.Table.Serialize ( Serializable, parse )++-- text+import qualified Data.Text as Text+import Data.Text.Encoding ( encodeUtf8 )+++-- | Run a @SELECT@ query, returning all rows.+select :: forall exprs a. Serializable exprs a+  => Connection -> Query exprs -> IO [a]+select c query = case sqlForQuery query of+  Nothing -> pure []+  Just sql -> 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.rowList (parse @exprs @a)+      prepare = False+++selectWithNames :: forall exprs a names.+  ( Selects names exprs+  , Serializable exprs a+  )+  => Connection -> names -> Query exprs -> IO [a]+selectWithNames c names query = case sqlForQueryWithNames names query of+  Nothing -> pure []+  Just sql -> 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.rowList (parse @exprs @a)+      prepare = False
+ src/Rel8/Statement/Update.hs view
@@ -0,0 +1,101 @@+{-# language GADTs #-}+{-# language NamedFieldPuns #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeApplications #-}++module Rel8.Statement.Update+  ( Update(..)+  , update+  )+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++-- rel8+import Rel8.Expr ( Expr )+import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )+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 )++-- text+import qualified Data.Text as Text+import Data.Text.Encoding ( encodeUtf8 )+++-- | The constituent parts of an @UPDATE@ statement.+type Update :: Type -> Type+data Update a where+  Update :: Selects names exprs =>+    { target :: TableSchema names+      -- ^ Which table to update.+    , set :: exprs -> exprs+      -- ^ How to update each selected row.+    , updateWhere :: exprs -> Expr Bool+      -- ^ Which rows to select for update.+    , returning :: Returning names a+      -- ^ What to return from the @UPDATE@ statement.+    }+    -> Update a+++-- | Run an @UPDATE@ statement.+update :: Connection -> Update a -> IO a+update c Update {target, set, updateWhere, 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.arrangeUpdateSql target' set' where'+          where+            target' = table $ toColumns <$> target+            set' = toColumns . set . fromColumns+            where' = toColumn . toPrimExpr . updateWhere . fromColumns++    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.arrangeUpdateReturningSql+            unpackspec+            target'+            set'+            where'+            project'+          where+            target' = table $ toColumns <$> target+            set' = toColumns . set . fromColumns+            where' = toColumn . toPrimExpr . updateWhere . fromColumns+            project' = castTable . toColumns . project . fromColumns++  where+    decoder :: forall exprs projection a. Serializable projection a+      => (exprs -> projection) -> Hasql.Result [a]+    decoder _ = Hasql.rowList (parse @projection @a)
+ src/Rel8/Statement/View.hs view
@@ -0,0 +1,63 @@+{-# language FlexibleContexts #-}+{-# language MonoLocalBinds #-}++module Rel8.Statement.View+  ( createView+  )+where++-- base+import Control.Exception ( throwIO )+import Control.Monad ( (>=>) )+import Data.Foldable ( fold )+import Data.Maybe ( fromMaybe )+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++-- rel8+import Rel8.Query ( Query )+import Rel8.Query.SQL ( sqlForQueryWithNames )+import Rel8.Schema.Name ( Selects )+import Rel8.Schema.Table ( TableSchema( TableSchema ) )+import Rel8.Table.Alternative ( emptyTable )++-- text+import qualified Data.Text as Text+import Data.Text.Encoding ( encodeUtf8 )+++-- | Given a 'TableSchema' and 'Query', @createView@ runs a @CREATE VIEW@+-- statement that will save the given query as a view. This can be useful if+-- you want to share Rel8 queries with other applications.+createView :: Selects names exprs+  => TableSchema names -> Query exprs -> Connection -> IO ()+createView (TableSchema name mschema names) query =+  Hasql.run session >=> 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.noResult+    prepare = False+    sql = "CREATE VIEW " <> title <> " AS " <> select+      where+        title = case mschema of+          Nothing -> quote name+          Just schema -> quote schema <> "." <> quote name+    select = fromMaybe fallback $ sqlForQueryWithNames names query+      where+        fallback = fold $ sqlForQueryWithNames names emptyTable+++quote :: String -> String+quote string = "\"" <> concatMap go string <> "\""+  where+    go '"' = "\"\""+    go c = [c]
+ src/Rel8/Table.hs view
@@ -0,0 +1,386 @@+{-# language AllowAmbiguousTypes #-}+{-# language DataKinds #-}+{-# language DefaultSignatures #-}+{-# language DisambiguateRecordFields #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language FunctionalDependencies #-}+{-# language LambdaCase #-}+{-# language NamedFieldPuns #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeApplications #-}+{-# language TypeFamilies #-}+{-# language TypeOperators #-}+{-# language UndecidableInstances #-}++module Rel8.Table+  ( Table (Columns, Context, Unreify, toColumns, fromColumns, reify, unreify)+  , Congruent+  , TTable, TColumns, TContext, TUnreify+  )+where++-- base+import Data.Functor ( ($>) )+import Data.Functor.Identity ( Identity( Identity ) )+import Data.Kind ( Constraint, Type )+import Data.List.NonEmpty ( NonEmpty )+import Data.Proxy ( Proxy( Proxy ) )+import Data.Type.Equality ( (:~:)( Refl ) )+import GHC.Generics ( Generic, Rep, from, to )+import Prelude hiding ( null )++-- rel8+import Rel8.FCF ( Eval, Exp )+import Rel8.Kind.Algebra ( KnownAlgebra )+import Rel8.Generic.Map ( GMap, GMappable, gmap, gunmap )+import Rel8.Generic.Table+  ( GGTable, GGColumns, GGContext, ggfromColumns, ggtoColumns+  , GAlgebra+  )+import Rel8.Generic.Record ( Record(..) )+import Rel8.Generic.Reify ( ARep )+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )+import Rel8.Schema.HTable ( HTable )+import Rel8.Schema.HTable.Either ( HEitherTable(..) )+import Rel8.Schema.HTable.Identity ( HIdentity(..), HType )+import Rel8.Schema.HTable.Label ( hlabel, hunlabel )+import Rel8.Schema.HTable.List ( HListTable )+import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )+import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )+import Rel8.Schema.HTable.Nullify ( hnulls, hnullify, hunnullify )+import Rel8.Schema.HTable.These ( HTheseTable(..) )+import Rel8.Schema.HTable.Vectorize ( hvectorize, hunvectorize )+import qualified Rel8.Schema.Kind as K+import Rel8.Schema.Null ( Sql )+import Rel8.Schema.Reify+  ( Reify, Col( Reify ), hreify, hunreify+  , UnwrapReify+  , notReify+  )+import Rel8.Schema.Result+  ( Col( R ), Result+  , relabel+  , null, nullifier, unnullifier+  , vectorizer, unvectorizer+  )+import Rel8.Schema.Spec ( KnownSpec )+import Rel8.Type ( DBType )+import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ),  MaybeTag( IsJust ) )++-- these+import Data.These ( These( This, That, These ) )+import Data.These.Combinators ( justHere, justThere )+++-- | @Table@s are one of the foundational elements of Rel8, and describe data+-- types that have a finite number of columns. Each of these columns contains+-- data under a shared context, and contexts describe how to interpret the+-- metadata about a column to a particular Haskell type. In Rel8, we have+-- contexts for expressions (the 'Rel8.Expr' context), aggregations (the+-- 'Rel8.Aggregate' context), insert values (the 'Rel8.Insert' contex), among+-- others.+--+-- In typical usage of Rel8 you don't need to derive instances of 'Table'+-- yourself, as anything that's an instance of 'Rel8.Rel8able' is always a+-- 'Table'.+type Table :: K.Context -> Type -> Constraint+class (HTable (Columns a), context ~ Context a) => Table context a | a -> context where+  -- | The 'HTable' functor that describes the schema of this table.+  type Columns a :: K.HTable++  -- | The common context that all columns use as an interpretation.+  type Context a :: K.Context++  type Unreify a :: Type++  toColumns :: a -> Columns a (Col context)+  fromColumns :: Columns a (Col context) -> a++  reify :: context :~: Reify ctx -> Unreify a -> a+  unreify :: context :~: Reify ctx -> a -> Unreify a++  type Columns a = Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))+  type Context a = Eval (GGContext (GAlgebra (Rep (Record a))) TContext (Rep (Record a)))+  type Unreify a = DefaultUnreify a++  default toColumns ::+    ( Generic (Record a)+    , KnownAlgebra (GAlgebra (Rep (Record a)))+    , Eval (GGTable (GAlgebra (Rep (Record a))) (TTable context) TColumns (Col context) (Rep (Record a)))+    , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))+    , Context a ~ Eval (GGContext (GAlgebra (Rep (Record a))) TContext (Rep (Record a)))+    )+    => a -> Columns a (Col context)+  toColumns =+    ggtoColumns+      @(GAlgebra (Rep (Record a)))+      @(TTable context)+      @TColumns+      id+      id+      toColumns .+    from .+    Record++  default fromColumns ::+    ( Generic (Record a)+    , KnownAlgebra (GAlgebra (Rep (Record a)))+    , Eval (GGTable (GAlgebra (Rep (Record a))) (TTable context) TColumns (Col context) (Rep (Record a)))+    , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))+    , Context a ~ Eval (GGContext (GAlgebra (Rep (Record a))) TContext (Rep (Record a)))+    )+    => Columns a (Col context) -> a+  fromColumns =+    unrecord .+    to .+    ggfromColumns+      @(GAlgebra (Rep (Record a)))+      @(TTable context)+      @TColumns+      id+      id+      fromColumns++  default reify ::+    ( Generic (Record a)+    , Generic (Record (Unreify a))+    , GMappable (TTable context) (Rep (Record a))+    , Rep (Record (Unreify a)) ~ GMap TUnreify (Rep (Record a))+    )+    => context :~: Reify ctx -> Unreify a -> a+  reify Refl =+    unrecord .+    to .+    gunmap @(TTable context) (Proxy @TUnreify) (reify Refl) .+    from .+    Record++  default unreify ::+    ( Generic (Record a)+    , Generic (Record (Unreify a))+    , GMappable (TTable context) (Rep (Record a))+    , Rep (Record (Unreify a)) ~ GMap TUnreify (Rep (Record a))+    )+    => context :~: Reify ctx -> a -> Unreify a+  unreify Refl =+    unrecord .+    to .+    gmap @(TTable context) (Proxy @TUnreify) (unreify Refl) .+    from .+    Record+++data TTable :: K.Context -> Type -> Exp Constraint+type instance Eval (TTable context a) = Table context a+++data TColumns :: Type -> Exp K.HTable+type instance Eval (TColumns a) = Columns a+++data TContext :: Type -> Exp K.Context+type instance Eval (TContext a) = Context a+++data TUnreify :: Type -> Exp Type+type instance Eval (TUnreify a) = Unreify a+++type DefaultUnreify :: Type -> Type+type family DefaultUnreify a where+  DefaultUnreify (t a b c d e f g) =+    t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e) (Unreify f) (Unreify g)+  DefaultUnreify (t a b c d e f) =+    t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e) (Unreify f)+  DefaultUnreify (t a b c d e) =+    t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e)+  DefaultUnreify (t a b c d) =+    t (Unreify a) (Unreify b) (Unreify c) (Unreify d)+  DefaultUnreify (t a b c) = t (Unreify a) (Unreify b) (Unreify c)+  DefaultUnreify (t a b) = t (Unreify a) (Unreify b)+  DefaultUnreify (t a) = t (Unreify a)+  DefaultUnreify a = ARep (GMap TUnreify (Rep a))+++-- | Any 'HTable' is also a 'Table'.+instance HTable t => Table context (t (Col context)) where+  type Columns (t (Col context)) = t+  type Context (t (Col context)) = context+  type Unreify (t (Col context)) = t (Col (UnwrapReify context))++  toColumns = id+  fromColumns = id++  reify Refl = hreify+  unreify Refl = hunreify+++-- | Any context is trivially a table.+instance KnownSpec spec => Table context (Col context spec) where+  type Columns (Col context spec) = HIdentity spec+  type Context (Col context spec) = context+  type Unreify (Col context spec) = Col (UnwrapReify context) spec++  toColumns = HIdentity+  fromColumns = unHIdentity++  reify Refl = Reify+  unreify Refl (Reify a) = a+++instance Sql DBType a => Table Result (Identity a) where+  type Columns (Identity a) = HType a+  type Context (Identity a) = Result++  toColumns (Identity a) = HType (R a)+  fromColumns (HType (R a)) = Identity a++  reify = notReify+  unreify = notReify+++instance (Table Result a, Table Result b) => Table Result (Either a b) where+  type Columns (Either a b) = HEitherTable (Columns a) (Columns b)+  type Context (Either a b) = Result++  toColumns = \case+    Left table -> HEitherTable+      { htag = HIdentity (R IsLeft)+      , hleft = hlabel labeler (hnullify nullifier (toColumns table))+      , hright = hlabel labeler (hnulls (const null))+      }+    Right table -> HEitherTable+      { htag = HIdentity (R IsRight)+      , hleft = hlabel labeler (hnulls (const null))+      , hright = hlabel labeler (hnullify nullifier (toColumns table))+      }++  fromColumns HEitherTable {htag, hleft, hright} = case htag of+    HIdentity (R tag) -> case tag of+      IsLeft -> maybe err (Left . fromColumns) $ hunnullify unnullifier (hunlabel unlabeler hleft)+      IsRight -> maybe err (Right . fromColumns) $ hunnullify unnullifier (hunlabel unlabeler hright)+    where+      err = error "Either.fromColumns: mismatch between tag and data"+++instance Table Result a => Table Result [a] where+  type Columns [a] = HListTable (Columns a)+  type Context [a] = Result++  toColumns = hvectorize vectorizer . fmap toColumns+  fromColumns = fmap fromColumns . hunvectorize unvectorizer+++instance Table Result a => Table Result (Maybe a) where+  type Columns (Maybe a) = HMaybeTable (Columns a)+  type Context (Maybe a) = Result++  toColumns = \case+    Nothing -> HMaybeTable+      { htag = HIdentity (R Nothing)+      , hjust = hlabel labeler (hnulls (const null))+      }+    Just table -> HMaybeTable+      { htag = HIdentity (R (Just IsJust))+      , hjust = hlabel labeler (hnullify nullifier (toColumns table))+      }++  fromColumns HMaybeTable {htag, hjust} = case htag of+    HIdentity (R tag) -> tag $>+      case hunnullify unnullifier (hunlabel unlabeler hjust) of+        Nothing -> error "Maybe.fromColumns: mismatch between tag and data"+        Just just -> fromColumns just+++instance Table Result a => Table Result (NonEmpty a) where+  type Columns (NonEmpty a) = HNonEmptyTable (Columns a)+  type Context (NonEmpty a) = Result++  toColumns = hvectorize vectorizer . fmap toColumns+  fromColumns = fmap fromColumns . hunvectorize unvectorizer+++instance (Table Result a, Table Result b) => Table Result (These a b) where+  type Columns (These a b) = HTheseTable (Columns a) (Columns b)+  type Context (These a b) = Result++  toColumns tables = HTheseTable+    { hhereTag = relabel hhereTag+    , hhere = hlabel labeler (hunlabel unlabeler (toColumns hhere))+    , hthereTag = relabel hthereTag+    , hthere = hlabel labeler (hunlabel unlabeler (toColumns hthere))+    }+    where+      HMaybeTable+        { htag = hhereTag+        , hjust = hhere+        } = toColumns (justHere tables)+      HMaybeTable+        { htag = hthereTag+        , hjust = hthere+        } = toColumns (justThere tables)++  fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} =+    case (fromColumns mhere, fromColumns mthere) of+      (Just a, Nothing) -> This (fromColumns a)+      (Nothing, Just b) -> That (fromColumns b)+      (Just a, Just b) -> These (fromColumns a) (fromColumns b)+      _ -> error "These.fromColumns: mismatch between tags and data"+    where+      mhere = HMaybeTable+        { htag = relabel hhereTag+        , hjust = hlabel labeler (hunlabel unlabeler hhere)+        }+      mthere = HMaybeTable+        { htag = relabel hthereTag+        , hjust = hlabel labeler (hunlabel unlabeler hthere)+        }+++instance (Table context a, Table context b, Labelable context)+  => Table context (a, b)+++instance+  ( Table context a, Table context b, Table context c+  , Labelable context+  )+  => Table context (a, b, c)+++instance+  ( Table context a, Table context b, Table context c, Table context d+  , Labelable context+  )+  => Table context (a, b, c, d)+++instance+  ( Table context a, Table context b, Table context c, Table context d+  , Table context e+  , Labelable context+  )+  => Table context (a, b, c, d, e)+++instance+  ( Table context a, Table context b, Table context c, Table context d+  , Table context e, Table context f+  , Labelable context+  )+  => Table context (a, b, c, d, e, f)+++instance+  ( Table context a, Table context b, Table context c, Table context d+  , Table context e, Table context f, Table context g+  , Labelable context+  )+  => Table context (a, b, c, d, e, f, g)+++type Congruent :: Type -> Type -> Constraint+class Columns a ~ Columns b => Congruent a b+instance Columns a ~ Columns b => Congruent a b
+ src/Rel8/Table/ADT.hs view
@@ -0,0 +1,205 @@+{-# language AllowAmbiguousTypes #-}+{-# language DataKinds #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language MultiParamTypeClasses #-}+{-# language RankNTypes #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeApplications #-}+{-# language TypeFamilies #-}+{-# language UndecidableInstances #-}+{-# language UndecidableSuperClasses #-}++module Rel8.Table.ADT+  ( ADT( ADT )+  , ADTable, fromADT, toADT+  , BuildableADT+  , BuildADT, buildADT+  , ConstructableADT+  , ConstructADT, constructADT+  , DeconstructADT, deconstructADT+  , NameADT, nameADT+  , AggregateADT, aggregateADT+  , ADTRep+  )+where++-- base+import Data.Kind ( Constraint, Type )+import Data.Proxy ( Proxy( Proxy ) )+import Data.Type.Equality ( (:~:)( Refl ) )+import GHC.Generics ( Generic, Rep, from, to )+import GHC.TypeLits ( Symbol )+import Prelude++-- rel8+import Rel8.Aggregate ( Aggregate )+import Rel8.Expr ( Expr )+import Rel8.FCF ( Eval, Exp )+import Rel8.Generic.Construction+  ( GGBuildable+  , GGBuild, ggbuild+  , GGConstructable+  , GGConstruct, ggconstruct+  , GGDeconstruct, ggdeconstruct+  , GGName, ggname+  , GGAggregate, ggaggregate+  )+import Rel8.Generic.Map ( GMappable, GMap, gmap, gunmap )+import Rel8.Generic.Record ( GRecordable, GRecord, grecord, gunrecord )+import Rel8.Generic.Rel8able+  ( Rel8able+  , GRep, GColumns, gfromColumns, gtoColumns+  , greify, gunreify+  )+import qualified Rel8.Generic.Table.ADT as G+import qualified Rel8.Kind.Algebra as K+import Rel8.Schema.Context ( Col )+import Rel8.Schema.HTable ( HTable )+import qualified Rel8.Schema.Kind as K+import Rel8.Schema.Name ( Name )+import Rel8.Schema.Reify ( Col( Reify ), Reify, hreify, hunreify )+import Rel8.Schema.Result ( Result )+import Rel8.Table+  ( Table+  , fromColumns, toColumns, reify, unreify+  , TTable, TColumns, TUnreify+  )+++type ADT :: K.Rel8able -> K.Rel8able+newtype ADT t context = ADT (GColumnsADT t (Col context))+++instance ADTable t => Rel8able (ADT t) where+  type GColumns (ADT t) = GColumnsADT t++  gfromColumns = ADT+  gtoColumns (ADT a) = a++  greify (ADT a) = ADT (hreify a)+  gunreify (ADT a) = ADT (hunreify a)+++instance (ADTable t, context ~ Result) => Generic (ADT t context) where+  type Rep (ADT t context) = Rep (t context)++  from =+    gmap @(TTable (Reify Result)) (Proxy @TUnreify) (unreify Refl) .+    gunrecord @(Rep (t (Reify Result))) .+    G.gfromColumnsADT+      @(TTable (Reify Result))+      @TColumns+      (\(Reify a) -> a)+      Reify+      fromColumns .+    hreify .+    (\(ADT a) -> a)++  to =+    ADT .+    hunreify .+    G.gtoColumnsADT+      @(TTable (Reify Result))+      @TColumns+      (\(Reify a) -> a)+      Reify+      toColumns .+    grecord @(Rep (t (Reify Result))) .+    gunmap @(TTable (Reify Result)) (Proxy @TUnreify) (reify Refl)+++fromADT :: ADTable t => ADT t Result -> t Result+fromADT = to . from+++toADT :: ADTable t => t Result -> ADT t Result+toADT = to . from+++type ADTable :: K.Rel8able -> Constraint+class+  ( Generic (t Result)+  , HTable (GColumnsADT t)+  , G.GTableADT (TTable (Reify Result)) TColumns (Col (Reify Result)) (GRecord (Rep (t (Reify Result))))+  , GRecordable (Rep (t (Reify Result)))+  , GMappable (TTable (Reify Result)) (Rep (t (Reify Result)))+  , GMap TUnreify (Rep (t (Reify Result))) ~ Rep (t Result)+  )+  => ADTable t+instance+  ( Generic (t Result)+  , HTable (GColumnsADT t)+  , G.GTableADT (TTable (Reify Result)) TColumns (Col (Reify Result)) (GRecord (Rep (t (Reify Result))))+  , GRecordable (Rep (t (Reify Result)))+  , GMappable (TTable (Reify Result)) (Rep (t (Reify Result)))+  , GMap TUnreify (Rep (t (Reify Result))) ~ Rep (t Result)+  )+  => ADTable t+++type BuildableADT :: K.Rel8able -> Symbol -> Constraint+class GGBuildable 'K.Sum name (ADTRep t) => BuildableADT t name+instance GGBuildable 'K.Sum name (ADTRep t) => BuildableADT t name+++type BuildADT :: K.Rel8able -> Symbol -> Type+type BuildADT t name = GGBuild 'K.Sum name (ADTRep t) (ADT t Expr)+++buildADT :: forall t name. BuildableADT t name => BuildADT t name+buildADT =+  ggbuild @'K.Sum @name @(ADTRep t) @(ADT t Expr) ADT+++type ConstructableADT :: K.Rel8able -> Constraint+class GGConstructable 'K.Sum (ADTRep t) => ConstructableADT t+instance GGConstructable 'K.Sum (ADTRep t) => ConstructableADT t+++type ConstructADT :: K.Rel8able -> Type+type ConstructADT t = forall r. GGConstruct 'K.Sum (ADTRep t) r+++constructADT :: forall t. ConstructableADT t => ConstructADT t -> ADT t Expr+constructADT f =+  ggconstruct @'K.Sum @(ADTRep t) @(ADT t Expr) ADT+    (f @(ADT t Expr))+++type DeconstructADT :: K.Rel8able -> Type -> Type+type DeconstructADT t r = GGDeconstruct 'K.Sum (ADTRep t) (ADT t Expr) r+++deconstructADT :: forall t r. (ConstructableADT t, Table Expr r)+  => DeconstructADT t r+deconstructADT =+  ggdeconstruct @'K.Sum @(ADTRep t) @(ADT t Expr) @r (\(ADT a) -> a)+++type NameADT :: K.Rel8able -> Type+type NameADT t = GGName 'K.Sum (ADTRep t) (ADT t Name)+++nameADT :: forall t. ConstructableADT t => NameADT t+nameADT = ggname @'K.Sum @(ADTRep t) @(ADT t Name) ADT+++type AggregateADT :: K.Rel8able -> Type+type AggregateADT t = forall r. GGAggregate 'K.Sum (ADTRep t) r+++aggregateADT :: forall t. ConstructableADT t+  => AggregateADT t -> ADT t Expr -> ADT t Aggregate+aggregateADT f =+  ggaggregate @'K.Sum @(ADTRep t) @(ADT t Expr) @(ADT t Aggregate) ADT (\(ADT a) -> a)+    (f @(ADT t Aggregate))+++data ADTRep :: K.Rel8able -> K.Context -> Exp (Type -> Type)+type instance Eval (ADTRep t context) = GRep t context+++type GColumnsADT :: K.Rel8able -> K.HTable+type GColumnsADT t = G.GColumnsADT TColumns (GRep t (Reify Result))
+ src/Rel8/Table/Aggregate.hs view
@@ -0,0 +1,81 @@+{-# language FlexibleContexts #-}+{-# language NamedFieldPuns #-}+{-# language ScopedTypeVariables #-}+{-# language TypeApplications #-}+{-# language TypeFamilies #-}+{-# language ViewPatterns #-}++module Rel8.Table.Aggregate+  ( groupBy, hgroupBy+  , listAgg, nonEmptyAgg+  )+where++-- base+import Data.Functor.Identity ( Identity( Identity ) )+import Prelude++-- rel8+import Rel8.Aggregate ( Aggregate, Aggregates, Col( A ) )+import Rel8.Expr ( Expr, Col( E ) )+import Rel8.Expr.Aggregate+  ( groupByExpr+  , slistAggExpr+  , snonEmptyAggExpr+  )+import Rel8.Schema.Dict ( Dict( Dict ) )+import Rel8.Schema.HTable ( HTable, hfield, htabulate )+import Rel8.Schema.HTable.Vectorize ( hvectorize )+import Rel8.Schema.Spec ( SSpec( SSpec, info ) )+import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )+import Rel8.Table ( toColumns, fromColumns )+import Rel8.Table.Eq ( EqTable, eqTable )+import Rel8.Table.List ( ListTable )+import Rel8.Table.NonEmpty ( NonEmptyTable )+import Rel8.Type.Eq ( DBEq )+++-- | Group equal tables together. This works by aggregating each column in the+-- given table with 'groupByExpr'.+groupBy :: forall exprs aggregates. (EqTable exprs, Aggregates aggregates exprs)+  => exprs -> aggregates+groupBy = fromColumns . hgroupBy (eqTable @exprs) . toColumns+++hgroupBy :: HTable t+  => t (Dict (ConstrainDBType DBEq)) -> t (Col Expr) -> t (Col Aggregate)+hgroupBy eqs exprs = fromColumns $ htabulate $ \field ->+  case hfield eqs field of+    Dict -> case hfield exprs field of+      E expr -> A $ groupByExpr expr+++-- | Aggregate rows into a single row containing an array of all aggregated+-- rows. This can be used to associate multiple rows with a single row, without+-- changing the over cardinality of the query. This allows you to essentially+-- return a tree-like structure from queries.+--+-- For example, if we have a table of orders and each orders contains multiple+-- items, we could aggregate the table of orders, pairing each order with its+-- items:+--+-- @+-- ordersWithItems :: Query (Order Expr, ListTable (Item Expr))+-- ordersWithItems = do+--   order <- each orderSchema+--   items <- aggregate $ listAgg <$> itemsFromOrder order+--   return (order, items)+-- @+listAgg :: Aggregates aggregates exprs => exprs -> ListTable aggregates+listAgg (toColumns -> exprs) = fromColumns $+  hvectorize+    (\SSpec {info} (Identity (E a)) -> A $ slistAggExpr info a)+    (pure exprs)+++-- | Like 'listAgg', but the result is guaranteed to be a non-empty list.+nonEmptyAgg :: Aggregates aggregates exprs => exprs -> NonEmptyTable aggregates+nonEmptyAgg (toColumns -> exprs) = fromColumns $+  hvectorize+    (\SSpec {info} (Identity (E a)) -> A $ snonEmptyAggExpr info a)+    (pure exprs)
+ src/Rel8/Table/Alternative.hs view
@@ -0,0 +1,37 @@+{-# language FlexibleContexts #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeFamilies #-}++module Rel8.Table.Alternative+  ( AltTable ( (<|>:) )+  , AlternativeTable ( emptyTable )+  )+where++-- base+import Data.Kind ( Constraint, Type )+import Prelude ()++-- rel8+import Rel8.Expr ( Expr )+import Rel8.Table ( Table )+++-- | Like 'Alt' in Haskell. This class is purely a Rel8 concept, and allows you+-- to take a choice between two tables. See also 'AlternativeTable'.+--+-- For example, using '<|>:' on 'Rel8.MaybeTable' allows you to combine two+-- tables and to return the first one that is a "just" MaybeTable.+type AltTable :: (Type -> Type) -> Constraint+class AltTable f where+  -- | An associative binary operation on 'Table's.+  (<|>:) :: Table Expr a => f a -> f a -> f a+  infixl 3 <|>:+++-- | Like 'Alternative' in Haskell, some 'Table's form a monoid on applicative+-- functors.+type AlternativeTable :: (Type -> Type) -> Constraint+class AltTable f => AlternativeTable f where+  -- | The identity of '<|>:'.+  emptyTable :: Table Expr a => f a
+ src/Rel8/Table/Bool.hs view
@@ -0,0 +1,49 @@+{-# language FlexibleContexts #-}+{-# language TypeFamilies #-}+{-# language ViewPatterns #-}++module Rel8.Table.Bool+  ( bool+  , case_+  , nullable+  )+where++-- base+import Prelude++-- rel8+import Rel8.Expr ( Expr, Col( E, unE ) )+import Rel8.Expr.Bool ( boolExpr, caseExpr )+import Rel8.Expr.Null ( isNull, unsafeUnnullify )+import Rel8.Schema.HTable ( htabulate, hfield )+import Rel8.Table ( Table, fromColumns, toColumns )+++-- | An if-then-else expression on tables.+--+-- @bool x y p@ returns @x@ if @p@ is @False@, and returns @y@ if @p@ is+-- @True@.+bool :: Table Expr a => a -> a -> Expr Bool -> a+bool (toColumns -> false) (toColumns -> true) condition =+  fromColumns $ htabulate $ \field ->+    case (hfield false field, hfield true field) of+      (E falseExpr, E trueExpr) ->+        E (boolExpr falseExpr trueExpr condition)+{-# INLINABLE bool #-}+++-- | Produce a table expression from a list of alternatives. Returns the first+-- table where the @Expr Bool@ expression is @True@. If no alternatives are+-- true, the given default is returned.+case_ :: Table Expr a => [(Expr Bool, a)] -> a -> a+case_ (map (fmap toColumns) -> branches) (toColumns -> fallback) =+  fromColumns $ htabulate $ \field -> case hfield fallback field of+    E fallbackExpr ->+      case map (fmap (unE . (`hfield` field))) branches of+        branchExprs -> E (caseExpr branchExprs fallbackExpr)+++-- | Like 'maybe', but to eliminate @null@.+nullable :: Table Expr b => b -> (Expr a -> b) -> Expr (Maybe a) -> b+nullable b f ma = bool (f (unsafeUnnullify ma)) b (isNull ma)
+ src/Rel8/Table/Either.hs view
@@ -0,0 +1,248 @@+{-# language DataKinds #-}+{-# language DeriveFunctor #-}+{-# language DerivingStrategies #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language LambdaCase #-}+{-# language MultiParamTypeClasses #-}+{-# language NamedFieldPuns #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeApplications #-}+{-# language TypeFamilies #-}+{-# language UndecidableInstances #-}++{-# options_ghc -fno-warn-orphans #-}++module Rel8.Table.Either+  ( EitherTable(..)+  , eitherTable, leftTable, rightTable+  , isLeftTable, isRightTable+  , nameEitherTable+  )+where++-- base+import Control.Applicative ( liftA2 )+import Data.Bifunctor ( Bifunctor, bimap )+import Data.Functor.Identity ( runIdentity )+import Data.Kind ( Type )+import Prelude hiding ( undefined )++-- rel8+import Rel8.Expr ( Expr )+import Rel8.Expr.Serialize ( litExpr )+import Rel8.Schema.Context.Label+  ( Labelable+  , HLabelable, hlabeler, hunlabeler+  )+import Rel8.Schema.Context.Nullify+  ( Nullifiable, ConstrainTag+  , HNullifiable, HConstrainTag+  , hencodeTag, hdecodeTag+  , hnullifier, hunnullifier+  )+import Rel8.Schema.HTable ( HTable )+import Rel8.Schema.HTable.Either ( HEitherTable(..) )+import Rel8.Schema.HTable.Identity ( HIdentity(..) )+import Rel8.Schema.HTable.Label ( hlabel, hunlabel )+import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )+import Rel8.Schema.Name ( Name )+import Rel8.Table+  ( Table, Columns, Context, fromColumns, toColumns+  , reify, unreify+  )+import Rel8.Table.Bool ( bool )+import Rel8.Table.Eq ( EqTable, eqTable )+import Rel8.Table.Ord ( OrdTable, ordTable )+import Rel8.Table.Recontextualize ( Recontextualize )+import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )+import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )+import Rel8.Table.Undefined ( undefined )+import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )++-- semigroupoids+import Data.Functor.Apply ( Apply, (<.>) )+import Data.Functor.Bind ( Bind, (>>-) )+++-- | An @EitherTable a b@ is a Rel8 table that contains either the table @a@ or+-- the table @b@. You can construct an @EitherTable@ using 'leftTable' and+-- 'rightTable', and eliminate/pattern match using 'eitherTable'.+--+-- An @EitherTable@ is operationally the same as Haskell's 'Either' type, but+-- adapted to work with Rel8.+type EitherTable :: Type -> Type -> Type+data EitherTable a b = EitherTable+  { tag :: Tag "isRight" EitherTag+  , left :: a+  , right :: b+  }+  deriving stock Functor+++instance Bifunctor EitherTable where+  bimap f g (EitherTable tag a b) = EitherTable tag (f a) (g b)+++instance Table Expr a => Apply (EitherTable a) where+  EitherTable tag l1 f <.> EitherTable tag' l2 a =+    EitherTable (tag <> tag') (bool l1 l2 (isLeft (expr tag))) (f a)+++instance Table Expr a => Applicative (EitherTable a) where+  pure = rightTable+  (<*>) = (<.>)+++instance Table Expr a => Bind (EitherTable a) where+  EitherTable tag l1 a >>- f = case f a of+    EitherTable tag' l2 b ->+      EitherTable (tag <> tag') (bool l1 l2 (isRight (expr tag))) b+++instance Table Expr a => Monad (EitherTable a) where+  (>>=) = (>>-)+++instance (Table Expr a, Table Expr b) => Semigroup (EitherTable a b) where+  a <> b = bool a b (isRightTable a)+++instance+  ( Table context a, Table context b+  , Labelable context, Nullifiable context, ConstrainTag context EitherTag+  ) =>+  Table context (EitherTable a b)+ where+  type Columns (EitherTable a b) = HEitherTable (Columns a) (Columns b)+  type Context (EitherTable a b) = Context a++  toColumns = toColumns2 toColumns toColumns+  fromColumns = fromColumns2 fromColumns fromColumns+  reify = liftA2 bimap reify reify+  unreify = liftA2 bimap unreify unreify+++instance+  ( Nullifiable from, Labelable from, ConstrainTag from EitherTag+  , Nullifiable to, Labelable to, ConstrainTag to EitherTag+  , Recontextualize from to a1 b1+  , Recontextualize from to a2 b2+  )+  => Recontextualize from to (EitherTable a1 a2) (EitherTable b1 b2)+++instance (EqTable a, EqTable b) => EqTable (EitherTable a b) where+  eqTable = toColumns2 id id (rightTableWith (eqTable @a) (eqTable @b))+++instance (OrdTable a, OrdTable b) => OrdTable (EitherTable a b) where+  ordTable = toColumns2 id id (rightTableWith (ordTable @a) (ordTable @b))+++type instance FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)+++instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable exprs1 exprs2) =>+  ToExprs x (Either a b)+ where+  fromResult =+    bimap (fromResult @exprs1) (fromResult @exprs2) .+    fromColumns+  toResult =+    toColumns .+    bimap (toResult @exprs1) (toResult @exprs2)+++-- | Test if an 'EitherTable' is a 'leftTable'.+isLeftTable :: EitherTable a b -> Expr Bool+isLeftTable = isLeft . expr . tag+++-- | Test if an 'EitherTable' is a 'rightTable'.+isRightTable :: EitherTable a b -> Expr Bool+isRightTable = isRight . expr . tag+++-- | Pattern match/eliminate an 'EitherTable', by providing mappings from a+-- 'leftTable' and 'rightTable'.+eitherTable :: Table Expr c+  => (a -> c) -> (b -> c) -> EitherTable a b -> c+eitherTable f g EitherTable {tag, left, right} =+  bool (f left) (g right) (isRight (expr tag))+++-- | Construct a left 'EitherTable'. Like 'Left'.+leftTable :: Table Expr b => a -> EitherTable a b+leftTable a = EitherTable (fromExpr (litExpr IsLeft)) a undefined+++-- | Construct a right 'EitherTable'. Like 'Right'.+rightTable :: Table Expr a => b -> EitherTable a b+rightTable = rightTableWith undefined+++rightTableWith :: a -> b -> EitherTable a b+rightTableWith = EitherTable (fromExpr (litExpr IsRight))+++-- | Construct a 'EitherTable' in the 'Name' context. This can be useful if you+-- have a 'EitherTable' that you are storing in a table and need to construct a+-- 'TableSchema'.+nameEitherTable+  :: Name EitherTag+     -- ^ The name of the column to track whether a row is a 'leftTable' or+     -- 'rightTable'.+  -> a+     -- ^ Names of the columns in the @a@ table.+  -> b+     -- ^ Names of the columns in the @b@ table.+  -> EitherTable a b+nameEitherTable = EitherTable . fromName+++toColumns2 ::+  ( HTable t+  , HTable u+  , HConstrainTag context EitherTag+  , HLabelable context+  , HNullifiable context+  )+  => (a -> t context)+  -> (b -> u context)+  -> EitherTable a b+  -> HEitherTable t u context+toColumns2 f g EitherTable {tag, left, right} = HEitherTable+  { htag+  , hleft = hlabel hlabeler $ hnullify (hnullifier tag isLeft) $ f left+  , hright = hlabel hlabeler $ hnullify (hnullifier tag isRight) $ g right+  }+  where+    htag = HIdentity (hencodeTag tag)+++fromColumns2 ::+  ( HTable t+  , HTable u+  , HConstrainTag context EitherTag+  , HLabelable context+  , HNullifiable context+  )+  => (t context -> a)+  -> (u context -> b)+  -> HEitherTable t u context+  -> EitherTable a b+fromColumns2 f g HEitherTable {htag, hleft, hright} = EitherTable+  { tag+  , left = f $ runIdentity $+     hunnullify (\a -> pure . hunnullifier a) $+     hunlabel hunlabeler+     hleft+  , right = g $ runIdentity $+     hunnullify (\a -> pure . hunnullifier a) $+     hunlabel hunlabeler+     hright+  }+  where+    tag = hdecodeTag $ unHIdentity htag
+ src/Rel8/Table/Eq.hs view
@@ -0,0 +1,145 @@+{-# language AllowAmbiguousTypes #-}+{-# language BlockArguments #-}+{-# language DataKinds #-}+{-# language DefaultSignatures #-}+{-# language DisambiguateRecordFields #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeApplications #-}+{-# language TypeFamilies #-}+{-# language TypeOperators #-}+{-# language UndecidableInstances #-}+{-# language UndecidableSuperClasses #-}+{-# language ViewPatterns #-}++module Rel8.Table.Eq+  ( EqTable( eqTable ), (==:), (/=:)+  )+where++-- base+import Data.Foldable ( foldl' )+import Data.Functor.Const ( Const( Const ), getConst )+import Data.Kind ( Constraint, Type )+import Data.List.NonEmpty ( NonEmpty( (:|) ) )+import GHC.Generics ( Rep )+import Prelude++-- rel8+import Rel8.Expr ( Expr, Col( E ) )+import Rel8.Expr.Bool ( (||.), (&&.) )+import Rel8.Expr.Eq ( (==.), (/=.) )+import Rel8.FCF ( Eval, Exp )+import Rel8.Generic.Record ( Record )+import Rel8.Generic.Table+  ( GGTable, GGColumns, ggtable+  , GAlgebra+  )+import Rel8.Kind.Algebra ( KnownAlgebra )+import Rel8.Schema.Dict ( Dict( Dict ) )+import Rel8.Schema.HTable+  ( HTable, HConstrainTable+  , htabulateA, hfield, hdicts+  )+import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )+import Rel8.Schema.Null ( Sql )+import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType, nullifier )+import Rel8.Table ( Table, Columns, toColumns, TColumns )+import Rel8.Type.Eq ( DBEq )+++-- | The class of 'Table's that can be compared for equality. Equality on+-- tables is defined by equality of all columns all columns, so this class+-- means "all columns in a 'Table' have an instance of 'DBEq'".+type EqTable :: Type -> Constraint+class Table Expr a => EqTable a where+  eqTable :: Columns a (Dict (ConstrainDBType DBEq))++  default eqTable ::+    ( KnownAlgebra (GAlgebra (Rep (Record a)))+    , Eval (GGTable (GAlgebra (Rep (Record a))) TEqTable TColumns (Dict (ConstrainDBType DBEq)) (Rep (Record a)))+    , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))+    )+    => Columns a (Dict (ConstrainDBType DBEq))+  eqTable =+    ggtable+      @(GAlgebra (Rep (Record a)))+      @TEqTable+      @TColumns+      @(Rep (Record a))+      table+      nullifier+    where+      table (_ :: proxy x) = eqTable @x+++data TEqTable :: Type -> Exp Constraint+type instance Eval (TEqTable a) = EqTable a+++instance+  ( HTable t+  , f ~ Col Expr+  , HConstrainTable t (ConstrainDBType DBEq)+  )+  => EqTable (t f)+ where+  eqTable = hdicts @(Columns (t f)) @(ConstrainDBType DBEq)+++instance Sql DBEq a => EqTable (Expr a) where+  eqTable = HType Dict+++instance (EqTable a, EqTable b) => EqTable (a, b)+++instance (EqTable a, EqTable b, EqTable c) => EqTable (a, b, c)+++instance (EqTable a, EqTable b, EqTable c, EqTable d) => EqTable (a, b, c, d)+++instance (EqTable a, EqTable b, EqTable c, EqTable d, EqTable e) =>+  EqTable (a, b, c, d, e)+++instance (EqTable a, EqTable b, EqTable c, EqTable d, EqTable e, EqTable f) =>+  EqTable (a, b, c, d, e, f)+++instance+  ( EqTable a, EqTable b, EqTable c, EqTable d, EqTable e, EqTable f+  , EqTable g+  )+  => EqTable (a, b, c, d, e, f, g)+++-- | Compare two 'Table's for equality. This corresponds to comparing all+-- columns inside each table for equality, and combining all comparisons with+-- @AND@.+(==:) :: forall a. EqTable a => a -> a -> Expr Bool+(toColumns -> as) ==: (toColumns -> bs) =+  foldl1' (&&.) $ getConst $ htabulateA $ \field ->+    case (hfield as field, hfield bs field) of+      (E a, E b) -> case hfield (eqTable @a) field of+        Dict -> Const (pure (a ==. b))+infix 4 ==:+++-- | Test if two 'Table's are different. This corresponds to comparing all+-- columns inside each table for inequality, and combining all comparisons with+-- @OR@.+(/=:) :: forall a. EqTable a => a -> a -> Expr Bool+(toColumns -> as) /=: (toColumns -> bs) =+  foldl1' (||.) $ getConst $ htabulateA $ \field ->+    case (hfield as field, hfield bs field) of+      (E a, E b) -> case hfield (eqTable @a) field of+        Dict -> Const (pure (a /=. b))+infix 4 /=:+++foldl1' :: (a -> a -> a) -> NonEmpty a -> a+foldl1' f (a :| as) = foldl' f a as
+ src/Rel8/Table/HKD.hs view
@@ -0,0 +1,268 @@+{-# language AllowAmbiguousTypes #-}+{-# language DataKinds #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language MultiParamTypeClasses #-}+{-# language RankNTypes #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeApplications #-}+{-# language TypeFamilies #-}+{-# language UndecidableInstances #-}+{-# language UndecidableSuperClasses #-}++module Rel8.Table.HKD+  ( HKD( HKD )+  , HKDable, fromHKD, toHKD, HKDT(..)+  , BuildableHKD+  , BuildHKD, buildHKD+  , ConstructableHKD+  , ConstructHKD, constructHKD+  , DeconstructHKD, deconstructHKD+  , NameHKD, nameHKD+  , AggregateHKD, aggregateHKD+  , HKDRep+  )+where++-- base+import Data.Kind ( Constraint, Type )+import Data.Proxy ( Proxy( Proxy ) )+import Data.Type.Equality ( (:~:)( Refl ) )+import Data.Void ( Void )+import GHC.Generics ( Generic, Rep, from, to )+import GHC.TypeLits ( Symbol )+import Prelude++-- rel8+import Rel8.Aggregate ( Aggregate )+import Rel8.Column ( TColumn )+import Rel8.Expr ( Expr )+import Rel8.FCF ( Eval, Exp )+import Rel8.Kind.Algebra ( KnownAlgebra )+import Rel8.Generic.Construction+  ( GGBuildable+  , GGBuild, ggbuild+  , GGConstructable+  , GGConstruct, ggconstruct+  , GGDeconstruct, ggdeconstruct+  , GGName, ggname+  , GGAggregate, ggaggregate+  )+import Rel8.Generic.Map ( GMap, GMappable, gmap, gunmap )+import Rel8.Generic.Record ( GRecord, GRecordable, grecord, gunrecord )+import Rel8.Generic.Rel8able+  ( Rel8able+  , GColumns, gfromColumns, gtoColumns+  , greify, gunreify+  , TUnreifyContext+  )+import Rel8.Generic.Table+  ( GGTable, GGColumns, GGContext, ggfromColumns, ggtoColumns+  , GAlgebra+  )+import Rel8.Schema.Context ( Col )+import qualified Rel8.Schema.Kind as K+import Rel8.Schema.HTable ( HTable )+import Rel8.Schema.Name ( Name )+import Rel8.Schema.Reify ( Col( Reify ), Reify, hreify, hunreify, notReify )+import Rel8.Schema.Result ( Result )+import Rel8.Table+  ( Table, Columns, Context, Unreify+  , fromColumns, toColumns, reify, unreify+  , TTable, TColumns, TUnreify+  )+import Rel8.Table.Serialize ( ToExprs, fromResult, toResult )+++type GColumnsHKD :: Type -> K.HTable+type GColumnsHKD a =+  Eval (GGColumns (GAlgebra (Rep a)) TColumns (GRecord (GMap (TColumn (Reify Result)) (Rep a))))+++type HKD :: Type -> K.Rel8able+newtype HKD a f = HKD (GColumnsHKD a (Col f))+++instance HKDable a => Rel8able (HKD a) where+  type GColumns (HKD a) = GColumnsHKD a++  gfromColumns = HKD+  gtoColumns (HKD a) = a++  greify (HKD a) = HKD (hreify a)+  gunreify (HKD a) = HKD (hunreify a)+++instance+  ( KnownAlgebra (GAlgebra (Rep a))+  , HTable (GColumnsHKD a)+  , Eval (GGTable (GAlgebra (Rep a)) (TTable (Reify f)) TColumns (Col (Reify f)) (GRecord (GMap (TColumn (Reify f)) (Rep a))))+  , Eval (GGColumns (GAlgebra (Rep a)) TColumns (GRecord (GMap (TColumn (Reify f)) (Rep a)))) ~ GColumnsHKD a+  , Eval (GGContext (GAlgebra (Rep a)) TUnreifyContext (GRecord (GMap (TColumn (Reify f)) (Rep a)))) ~ f+  , GRecordable (GMap (TColumn (Reify f)) (Rep a))+  , GMappable (TTable (Reify f)) (GMap (TColumn (Reify f)) (Rep a))+  , GMap TUnreify (GMap (TColumn (Reify f)) (Rep a)) ~ GMap (TColumn f) (Rep a)+  )+  => Generic (HKD a f)+ where+  type Rep (HKD a f) = GMap (TColumn f) (Rep a)++  from =+    gmap @(TTable (Reify f)) (Proxy @TUnreify) (unreify Refl) .+    gunrecord @(GMap (TColumn (Reify f)) (Rep a)) .+    ggfromColumns+      @(GAlgebra (Rep a))+      @(TTable (Reify f))+      @TColumns+      (\(Reify a) -> a)+      Reify+      fromColumns .+    hreify .+    (\(HKD a) -> a)++  to =+    HKD .+    hunreify .+    ggtoColumns+      @(GAlgebra (Rep a))+      @(TTable (Reify f))+      @TColumns+      (\(Reify a) -> a)+      Reify+      toColumns .+    grecord @(GMap (TColumn (Reify f)) (Rep a)) .+    gunmap @(TTable (Reify f)) (Proxy @TUnreify) (reify Refl)+++type HKDT :: Type -> Type+newtype HKDT a = HKDT+  { unHKDT :: a+  }+++instance HKDable a => Table Result (HKDT a) where+  type Columns (HKDT a) = GColumnsHKD a+  type Context (HKDT a) = Result+  type Unreify (HKDT a) = Void++  fromColumns = HKDT . fromHKD . HKD+  toColumns = (\(HKD a) -> a) . toHKD . (\(HKDT a) -> a)+  reify = notReify+  unreify = notReify+++instance+  ( Table Expr (HKD a Expr)+  , Columns (HKD a Expr) ~ GColumns (HKD a)+  , HKDable a+  , x ~ HKD a Expr+  )+  => ToExprs x (HKDT a)+ where+  toResult = (\(HKD a) -> a) . toHKD . (\(HKDT a) -> a)+  fromResult = HKDT . fromHKD . HKD+++fromHKD :: HKDable a => HKD a Result -> a+fromHKD = to . gunmap @Top (Proxy @(TColumn Result)) id . from+++toHKD :: HKDable a => a -> HKD a Result+toHKD = to . gmap @Top (Proxy @(TColumn Result)) id . from+++class Top_+instance Top_+++data Top :: Type -> Exp Constraint+type instance Eval (Top _) = Top_+++class+  ( Generic a+  , HTable (GColumns (HKD a))+  , KnownAlgebra (GAlgebra (Rep a))+  , Eval (GGTable (GAlgebra (Rep a)) (TTable (Reify Result)) TColumns (Col (Reify Result)) (GRecord (GMap (TColumn (Reify Result)) (Rep a))))+  , Eval (GGContext (GAlgebra (Rep a)) TUnreifyContext (GRecord (GMap (TColumn (Reify Result)) (Rep a)))) ~ Result+  , GRecordable (GMap (TColumn (Reify Result)) (Rep a))+  , GMappable Top (Rep a)+  , GMappable (TTable (Reify Result)) (GMap (TColumn (Reify Result)) (Rep a))+  , GMap TUnreify (GMap (TColumn (Reify Result)) (Rep a)) ~ GMap (TColumn Result) (Rep a)+  )+  => HKDable a+instance+  ( Generic a+  , HTable (GColumns (HKD a))+  , KnownAlgebra (GAlgebra (Rep a))+  , Eval (GGTable (GAlgebra (Rep a)) (TTable (Reify Result)) TColumns (Col (Reify Result)) (GRecord (GMap (TColumn (Reify Result)) (Rep a))))+  , Eval (GGContext (GAlgebra (Rep a)) TUnreifyContext (GRecord (GMap (TColumn (Reify Result)) (Rep a)))) ~ Result+  , GRecordable (GMap (TColumn (Reify Result)) (Rep a))+  , GMappable Top (Rep a)+  , GMappable (TTable (Reify Result)) (GMap (TColumn (Reify Result)) (Rep a))+  , GMap TUnreify (GMap (TColumn (Reify Result)) (Rep a)) ~ GMap (TColumn Result) (Rep a)+  )+  => HKDable a+++type BuildableHKD :: Type -> Symbol -> Constraint+class GGBuildable (GAlgebra (Rep a)) name (HKDRep a) => BuildableHKD a name+instance GGBuildable (GAlgebra (Rep a)) name (HKDRep a) => BuildableHKD a name+++type BuildHKD :: Type -> Symbol -> Type+type BuildHKD a name = GGBuild (GAlgebra (Rep a)) name (HKDRep a) (HKD a Expr)+++buildHKD :: forall a name. BuildableHKD a name => BuildHKD a name+buildHKD =+  ggbuild @(GAlgebra (Rep a)) @name @(HKDRep a) @(HKD a Expr) HKD+++type ConstructableHKD :: Type -> Constraint+class GGConstructable (GAlgebra (Rep a)) (HKDRep a) => ConstructableHKD a+instance GGConstructable (GAlgebra (Rep a)) (HKDRep a) => ConstructableHKD a+++type ConstructHKD :: Type -> Type+type ConstructHKD a = forall r. GGConstruct (GAlgebra (Rep a)) (HKDRep a) r+++constructHKD :: forall a. ConstructableHKD a => ConstructHKD a -> HKD a Expr+constructHKD f =+  ggconstruct @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Expr) HKD+    (f @(HKD a Expr))+++type DeconstructHKD :: Type -> Type -> Type+type DeconstructHKD a r = GGDeconstruct (GAlgebra (Rep a)) (HKDRep a) (HKD a Expr) r+++deconstructHKD :: forall a r. (ConstructableHKD a, Table Expr r)+  => DeconstructHKD a r+deconstructHKD = ggdeconstruct @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Expr) @r (\(HKD a) -> a)+++type NameHKD :: Type -> Type+type NameHKD a = GGName (GAlgebra (Rep a)) (HKDRep a) (HKD a Name)+++nameHKD :: forall a. ConstructableHKD a => NameHKD a+nameHKD = ggname @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Name) HKD+++type AggregateHKD :: Type -> Type+type AggregateHKD a = forall r. GGAggregate (GAlgebra (Rep a)) (HKDRep a) r+++aggregateHKD :: forall a. ConstructableHKD a+  => AggregateHKD a -> HKD a Expr -> HKD a Aggregate+aggregateHKD f =+  ggaggregate @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Expr) @(HKD a Aggregate) HKD (\(HKD a) -> a)+    (f @(HKD a Aggregate))+++data HKDRep :: Type -> K.Context -> Exp (Type -> Type)+type instance Eval (HKDRep a context) =+  GRecord (GMap (TColumn context) (Rep a))
+ src/Rel8/Table/List.hs view
@@ -0,0 +1,139 @@+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language MultiParamTypeClasses #-}+{-# language NamedFieldPuns #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeApplications #-}+{-# language TypeFamilies #-}+{-# language UndecidableInstances #-}++module Rel8.Table.List+  ( ListTable(..)+  , listTable, nameListTable+  )+where++-- base+import Data.Functor.Identity ( Identity( Identity ) )+import Data.Kind ( Type )+import Data.Type.Equality ( (:~:)( Refl ) )+import Prelude++-- rel8+import Rel8.Expr ( Expr, Col( E, unE ) )+import Rel8.Expr.Array ( sappend, sempty, slistOf )+import Rel8.Schema.Dict ( Dict( Dict ) )+import Rel8.Schema.HTable.List ( HListTable )+import Rel8.Schema.HTable.Vectorize ( happend, hempty, hvectorize )+import Rel8.Schema.Name ( Col( N ), Name( Name ) )+import Rel8.Schema.Null ( Nullity( Null, NotNull ) )+import Rel8.Schema.Spec ( SSpec(..) )+import Rel8.Schema.Spec.ConstrainDBType ( dbTypeDict, dbTypeNullity )+import Rel8.Schema.Reify ( hreify, hunreify )+import Rel8.Table+  ( Table, Context, Columns, fromColumns, toColumns+  , reify, unreify+  )+import Rel8.Table.Alternative+  ( AltTable, (<|>:)+  , AlternativeTable, emptyTable+  )+import Rel8.Table.Eq ( EqTable, eqTable )+import Rel8.Table.Ord ( OrdTable, ordTable )+import Rel8.Table.Recontextualize ( Recontextualize )+import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )+import Rel8.Table.Unreify ( Unreifies )+++-- | A @ListTable@ value contains zero or more instances of @a@. You construct+-- @ListTable@s with 'Rel8.many' or 'Rel8.listAgg'.+type ListTable :: Type -> Type+newtype ListTable a = ListTable (HListTable (Columns a) (Col (Context a)))+++instance (Table context a, Unreifies context a) =>+  Table context (ListTable a)+ where+  type Columns (ListTable a) = HListTable (Columns a)+  type Context (ListTable a) = Context a++  fromColumns = ListTable+  toColumns (ListTable a) = a++  reify Refl (ListTable a) = ListTable (hreify a)+  unreify Refl (ListTable a) = ListTable (hunreify a)+++instance+  ( Unreifies from a, Unreifies to b+  , Recontextualize from to a b+  )+  => Recontextualize from to (ListTable a) (ListTable b)+++instance EqTable a => EqTable (ListTable a) where+  eqTable =+    hvectorize+      (\SSpec {} (Identity dict) -> case dbTypeDict dict of+          Dict -> case dbTypeNullity dict of+            Null -> Dict+            NotNull -> Dict)+      (Identity (eqTable @a))+++instance OrdTable a => OrdTable (ListTable a) where+  ordTable =+    hvectorize+      (\SSpec {} (Identity dict) -> case dbTypeDict dict of+          Dict -> case dbTypeNullity dict of+            Null -> Dict+            NotNull -> Dict)+      (Identity (ordTable @a))+++type instance FromExprs (ListTable a) = [FromExprs a]+++instance ToExprs exprs a => ToExprs (ListTable exprs) [a] where+  fromResult = fmap (fromResult @exprs) . fromColumns+  toResult = toColumns . fmap (toResult @exprs)+++instance AltTable ListTable where+  (<|>:) = (<>)+++instance AlternativeTable ListTable where+  emptyTable = mempty+++instance Table Expr a => Semigroup (ListTable a) where+  ListTable as <> ListTable bs = ListTable $+    happend (\_ _ (E a) (E b) -> E (sappend a b)) as bs+++instance Table Expr a => Monoid (ListTable a) where+  mempty = ListTable $ hempty $ \_ -> E . sempty+++-- | Construct a @ListTable@ from a list of expressions.+listTable :: Table Expr a => [a] -> ListTable a+listTable =+  ListTable .+  hvectorize (\SSpec {info} -> E . slistOf info . fmap unE) .+  fmap toColumns+++-- | Construct a 'ListTable' in the 'Name' context. This can be useful if you+-- have a 'ListTable' that you are storing in a table and need to construct a+-- 'TableSchema'.+nameListTable+  :: Table Name a+  => a -- ^ The names of the columns of elements of the list.+  -> ListTable a+nameListTable =+  ListTable .+  hvectorize (\_ (Identity (N (Name a))) -> N (Name a)) .+  pure .+  toColumns
+ src/Rel8/Table/Maybe.hs view
@@ -0,0 +1,254 @@+{-# language DataKinds #-}+{-# language DeriveFunctor #-}+{-# language DerivingStrategies #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language LambdaCase #-}+{-# language MultiParamTypeClasses #-}+{-# language NamedFieldPuns #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeApplications #-}+{-# language TypeFamilies #-}+{-# language UndecidableInstances #-}++module Rel8.Table.Maybe+  ( MaybeTable(..)+  , maybeTable, nothingTable, justTable+  , isNothingTable, isJustTable+  , ($?)+  , nameMaybeTable+  )+where++-- base+import Data.Functor.Identity ( runIdentity )+import Data.Kind ( Type )+import Prelude hiding ( null, undefined )++-- rel8+import Rel8.Expr ( Expr )+import Rel8.Expr.Bool ( boolExpr )+import Rel8.Expr.Null ( isNull, isNonNull, null, nullify )+import Rel8.Schema.Context.Label+  ( Labelable, HLabelable, hlabeler, hunlabeler+  )+import Rel8.Schema.Context.Nullify+  ( Nullifiable, ConstrainTag+  , HNullifiable, HConstrainTag+  , hencodeTag, hdecodeTag+  , hnullifier, hunnullifier+  )+import Rel8.Schema.HTable ( HTable )+import Rel8.Schema.HTable.Identity ( HIdentity(..) )+import Rel8.Schema.HTable.Label ( hlabel, hunlabel )+import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )+import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )+import Rel8.Schema.Name ( Name )+import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql, nullable )+import Rel8.Table+  ( Table, Columns, Context, fromColumns, toColumns+  , reify, unreify+  )+import Rel8.Table.Alternative+  ( AltTable, (<|>:)+  , AlternativeTable, emptyTable+  )+import Rel8.Table.Bool ( bool )+import Rel8.Table.Eq ( EqTable, eqTable )+import Rel8.Table.Ord ( OrdTable, ordTable )+import Rel8.Table.Recontextualize ( Recontextualize )+import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )+import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )+import Rel8.Table.Undefined ( undefined )+import Rel8.Type ( DBType )+import Rel8.Type.Tag ( MaybeTag )++-- semigroupoids+import Data.Functor.Apply ( Apply, (<.>) )+import Data.Functor.Bind ( Bind, (>>-) )+++-- | @MaybeTable t@ is the table @t@, but as the result of an outer join. If+-- the outer join fails to match any rows, this is essentialy @Nothing@, and if+-- the outer join does match rows, this is like @Just@. Unfortunately, SQL+-- makes it impossible to distinguish whether or not an outer join matched any+-- rows based generally on the row contents - if you were to join a row+-- entirely of nulls, you can't distinguish if you matched an all null row, or+-- if the match failed.  For this reason @MaybeTable@ contains an extra field -+-- a "nullTag" - to track whether or not the outer join produced any rows.+type MaybeTable :: Type -> Type+data MaybeTable a = MaybeTable+  { tag :: Tag "isJust" (Maybe MaybeTag)+  , just :: a+  }+  deriving stock Functor+++instance Apply MaybeTable where+  MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f a)+++-- | Has the same behavior as the @Applicative@ instance for @Maybe@. See also:+-- 'Rel8.traverseMaybeTable'.+instance Applicative MaybeTable where+  (<*>) = (<.>)+  pure = justTable+++instance Bind MaybeTable where+  MaybeTable tag a >>- f = case f a of+    MaybeTable tag' b -> MaybeTable (tag <> tag') b+++-- | Has the same behavior as the @Monad@ instance for @Maybe@.+instance Monad MaybeTable where+  (>>=) = (>>-)+++instance AltTable MaybeTable where+  ma@(MaybeTable tag a) <|>: MaybeTable tag' b = MaybeTable+    { tag = (tag <> tag')+        { expr = boolExpr (expr tag) (expr tag') condition+        }+    , just = bool a b condition+    }+    where+      condition = isNothingTable ma+++instance AlternativeTable MaybeTable where+  emptyTable = nothingTable+++instance (Table Expr a, Semigroup a) => Semigroup (MaybeTable a) where+  ma <> mb = maybeTable mb (\a -> maybeTable ma (justTable . (a <>)) mb) ma+++instance (Table Expr a, Semigroup a) => Monoid (MaybeTable a) where+  mempty = nothingTable+++instance+  ( Table context a+  , Labelable context, Nullifiable context+  , ConstrainTag context MaybeTag+  ) => Table context (MaybeTable a)+ where+  type Columns (MaybeTable a) = HMaybeTable (Columns a)+  type Context (MaybeTable a) = Context a++  toColumns = toColumns1 toColumns+  fromColumns = fromColumns1 fromColumns+  reify = fmap fmap reify+  unreify = fmap fmap unreify+++instance+  ( Labelable from, Nullifiable from, ConstrainTag from MaybeTag+  , Labelable to, Nullifiable to, ConstrainTag to MaybeTag+  , Recontextualize from to a b+  )+  => Recontextualize from to (MaybeTable a) (MaybeTable b)+++instance EqTable a => EqTable (MaybeTable a) where+  eqTable = toColumns1 id (justTable (eqTable @a))+++instance OrdTable a => OrdTable (MaybeTable a) where+  ordTable = toColumns1 id (justTable (ordTable @a))+++type instance FromExprs (MaybeTable a) = Maybe (FromExprs a)+++instance ToExprs exprs a => ToExprs (MaybeTable exprs) (Maybe a) where+  fromResult = fmap (fromResult @exprs) . fromColumns+  toResult = toColumns . fmap (toResult @exprs)+++-- | Check if a @MaybeTable@ is absent of any row. Like 'Data.Maybe.isNothing'.+isNothingTable :: MaybeTable a -> Expr Bool+isNothingTable (MaybeTable tag _) = isNull (expr tag)+++-- | Check if a @MaybeTable@ contains a row. Like 'Data.Maybe.isJust'.+isJustTable :: MaybeTable a -> Expr Bool+isJustTable (MaybeTable tag _) = isNonNull (expr tag)+++-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.+maybeTable :: Table Expr b => b -> (a -> b) -> MaybeTable a -> b+maybeTable b f ma@(MaybeTable _ a) = bool (f a) b (isNothingTable ma)+{-# INLINABLE maybeTable #-}+++-- | The null table. Like 'Nothing'.+nothingTable :: Table Expr a => MaybeTable a+nothingTable = MaybeTable (fromExpr null) undefined+++-- | Lift any table into 'MaybeTable'. Like 'Just'. Note you can also use+-- 'pure'.+justTable :: a -> MaybeTable a+justTable = MaybeTable (fromExpr mempty)+++-- | Project a single expression out of a 'MaybeTable'. You can think of this+-- operator like the '$' operator, but it also has the ability to return+-- @null@.+($?) :: forall a b. Sql DBType b+  => (a -> Expr b) -> MaybeTable a -> Expr (Nullify b)+f $? ma@(MaybeTable _ a) = case nullable @b of+  Null -> boolExpr (f a) null (isNothingTable ma)+  NotNull -> boolExpr (nullify (f a)) null (isNothingTable ma)+infixl 4 $?+++-- | Construct a 'MaybeTable' in the 'Name' context. This can be useful if you+-- have a 'MaybeTable' that you are storing in a table and need to construct a+-- 'TableSchema'.+nameMaybeTable+  :: Name (Maybe MaybeTag)+     -- ^ The name of the column to track whether a row is a 'justTable' or+     -- 'nothingTable'.+  -> a+     -- ^ Names of the columns in @a@.+  -> MaybeTable a+nameMaybeTable = MaybeTable . fromName+++toColumns1 ::+  ( HTable t+  , HConstrainTag context MaybeTag+  , HLabelable context+  , HNullifiable context+  )+  => (a -> t context)+  -> MaybeTable a+  -> HMaybeTable t context+toColumns1 f MaybeTable {tag, just} = HMaybeTable+  { htag+  , hjust = hlabel hlabeler $ hnullify (hnullifier tag isNonNull) $ f just+  }+  where+    htag = HIdentity (hencodeTag tag)+++fromColumns1 ::+  ( HTable t+  , HConstrainTag context MaybeTag+  , HLabelable context+  , HNullifiable context+  )+  => (t context -> a)+  -> HMaybeTable t context+  -> MaybeTable a+fromColumns1 f HMaybeTable {htag = HIdentity htag, hjust} = MaybeTable+  { tag+  , just = f $ runIdentity $+      hunnullify (\a -> pure . hunnullifier a) (hunlabel hunlabeler hjust)+  }+  where+    tag = hdecodeTag htag
+ src/Rel8/Table/Name.hs view
@@ -0,0 +1,84 @@+{-# language FlexibleContexts #-}+{-# language NamedFieldPuns #-}+{-# language ScopedTypeVariables #-}+{-# language TypeApplications #-}+{-# language TypeFamilies #-}+{-# language ViewPatterns #-}++module Rel8.Table.Name+  ( namesFromLabels+  , namesFromLabelsWith+  , showExprs+  , showLabels+  , showNames+  )+where++-- base+import Data.Foldable ( fold )+import Data.Functor.Const ( Const( Const ), getConst )+import Data.List.NonEmpty ( NonEmpty, intersperse )+import Prelude++-- opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye++-- rel8+import Rel8.Expr ( Expr, Col( E ) )+import Rel8.Expr.Opaleye ( toPrimExpr )+import Rel8.Kind.Labels ( renderLabels )+import Rel8.Schema.HTable ( htabulate, htabulateA, hfield, hspecs )+import Rel8.Schema.Name ( Name( Name ), Col( N ) )+import Rel8.Schema.Spec ( SSpec(..) )+import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )+++-- | Construct a table in the 'Name' context containing the names of all+-- columns. Nested column names will be combined with @/@.+--+-- See also: 'namesFromLabelsWith'.+namesFromLabels :: Table Name a => a+namesFromLabels = namesFromLabelsWith go+  where+    go = fold . intersperse "/"+++-- | Construct a table in the 'Name' context containing the names of all+-- columns. The supplied function can be used to transform column names.+--+-- This function can be used to generically derive the columns for a+-- 'TableSchema'. For example,+--+-- @+-- myTableSchema :: TableSchema (MyTable Name)+-- myTableSchema = TableSchema+--   { columns = namesFromLabelsWith last+--   }+-- @+--+-- will construct a 'TableSchema' where each columns names exactly corresponds+-- to the name of the Haskell field.+namesFromLabelsWith :: Table Name a+  => (NonEmpty String -> String) -> a+namesFromLabelsWith f = fromColumns $ htabulate $ \field ->+  case hfield hspecs field of+    SSpec {labels} -> N (Name (f (renderLabels labels)))+++showExprs :: Table Expr a => a -> [(String, Opaleye.PrimExpr)]+showExprs as = case (namesFromLabels, toColumns as) of+  (names, exprs) -> getConst $ htabulateA $ \field ->+    case (hfield names field, hfield exprs field) of+      (N (Name name), E expr) -> Const [(name, toPrimExpr expr)]+++showLabels :: forall a. Table (Context a) a => a -> [NonEmpty String]+showLabels _ = getConst $+  htabulateA @(Columns a) $ \field -> case hfield hspecs field of+    SSpec {labels} -> Const [renderLabels labels]+++showNames :: forall a. Table Name a => a -> [String]+showNames (toColumns -> names) = getConst $+  htabulateA @(Columns a) $ \field -> case hfield names field of+    N (Name name) -> Const [name]
+ src/Rel8/Table/NonEmpty.hs view
@@ -0,0 +1,131 @@+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language MultiParamTypeClasses #-}+{-# language NamedFieldPuns #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeApplications #-}+{-# language TypeFamilies #-}+{-# language UndecidableInstances #-}++module Rel8.Table.NonEmpty+  ( NonEmptyTable(..)+  , nonEmptyTable, nameNonEmptyTable+  )+where++-- base+import Data.Functor.Identity ( Identity( Identity ) )+import Data.Kind ( Type )+import Data.List.NonEmpty ( NonEmpty )+import Data.Type.Equality ( (:~:)( Refl ) )+import Prelude++-- rel8+import Rel8.Expr ( Expr, Col( E, unE ) )+import Rel8.Expr.Array ( sappend1, snonEmptyOf )+import Rel8.Schema.Dict ( Dict( Dict ) )+import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )+import Rel8.Schema.HTable.Vectorize ( happend, hvectorize )+import Rel8.Schema.Name ( Col( N ), Name( Name ) )+import Rel8.Schema.Null ( Nullity( Null, NotNull ) )+import Rel8.Schema.Reify ( hreify, hunreify )+import Rel8.Schema.Spec ( SSpec(..) )+import Rel8.Schema.Spec.ConstrainDBType ( dbTypeDict, dbTypeNullity )+import Rel8.Table+  ( Table, Context, Columns, fromColumns, toColumns+  , reify, unreify+  )+import Rel8.Table.Alternative ( AltTable, (<|>:) )+import Rel8.Table.Eq ( EqTable, eqTable )+import Rel8.Table.Ord ( OrdTable, ordTable )+import Rel8.Table.Recontextualize ( Recontextualize )+import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )+import Rel8.Table.Unreify ( Unreifies )+++-- | A @NonEmptyTable@ value contains one or more instances of @a@. You+-- construct @NonEmptyTable@s with 'Rel8.some' or 'nonEmptyAgg'.+type NonEmptyTable :: Type -> Type+newtype NonEmptyTable a =+  NonEmptyTable (HNonEmptyTable (Columns a) (Col (Context a)))+++instance (Table context a, Unreifies context a) =>+  Table context (NonEmptyTable a)+ where+  type Columns (NonEmptyTable a) = HNonEmptyTable (Columns a)+  type Context (NonEmptyTable a) = Context a++  fromColumns = NonEmptyTable+  toColumns (NonEmptyTable a) = a++  reify Refl (NonEmptyTable a) = NonEmptyTable (hreify a)+  unreify Refl (NonEmptyTable a) = NonEmptyTable (hunreify a)+++instance+  ( Unreifies from a, Unreifies to b+  , Recontextualize from to a b+  )+  => Recontextualize from to (NonEmptyTable a) (NonEmptyTable b)+++instance EqTable a => EqTable (NonEmptyTable a) where+  eqTable =+    hvectorize+      (\SSpec {} (Identity dict) -> case dbTypeDict dict of+          Dict -> case dbTypeNullity dict of+            Null -> Dict+            NotNull -> Dict)+      (Identity (eqTable @a))+++instance OrdTable a => OrdTable (NonEmptyTable a) where+  ordTable =+    hvectorize+      (\SSpec {} (Identity dict) -> case dbTypeDict dict of+          Dict -> case dbTypeNullity dict of+            Null -> Dict+            NotNull -> Dict)+      (Identity (ordTable @a))+++type instance FromExprs (NonEmptyTable a) = NonEmpty (FromExprs a)+++instance ToExprs exprs a => ToExprs (NonEmptyTable exprs) (NonEmpty a)+ where+  fromResult = fmap (fromResult @exprs) . fromColumns+  toResult = toColumns . fmap (toResult @exprs)+++instance AltTable NonEmptyTable where+  (<|>:) = (<>)+++instance Table Expr a => Semigroup (NonEmptyTable a) where+  NonEmptyTable as <> NonEmptyTable bs = NonEmptyTable $+    happend (\_ _ (E a) (E b) -> E (sappend1 a b)) as bs+++-- | Construct a @NonEmptyTable@ from a non-empty list of expressions.+nonEmptyTable :: Table Expr a => NonEmpty a -> NonEmptyTable a+nonEmptyTable =+  NonEmptyTable .+  hvectorize (\SSpec {info} -> E . snonEmptyOf info . fmap unE) .+  fmap toColumns+++-- | Construct a 'NonEmptyTable' in the 'Name' context. This can be useful if+-- you have a 'NonEmptyTable' that you are storing in a table and need to+-- construct a 'TableSchema'.+nameNonEmptyTable+  :: Table Name a+  => a -- ^ The names of the columns of elements of the list.+  -> NonEmptyTable a+nameNonEmptyTable =+  NonEmptyTable .+  hvectorize (\_ (Identity (N (Name a))) -> N (Name a)) .+  pure .+  toColumns
+ src/Rel8/Table/Opaleye.hs view
@@ -0,0 +1,136 @@+{-# language BlockArguments #-}+{-# language DisambiguateRecordFields #-}+{-# language FlexibleContexts #-}+{-# language LambdaCase #-}+{-# language NamedFieldPuns #-}+{-# language TypeFamilies #-}+{-# language ViewPatterns #-}++module Rel8.Table.Opaleye+  ( aggregator+  , binaryspec+  , distinctspec+  , table+  , tableFields+  , unpackspec+  , valuesspec+  , castTable+  )+where++-- base+import Prelude hiding ( undefined )++-- opaleye+import qualified Opaleye.Internal.Aggregate as Opaleye+import qualified Opaleye.Internal.Binary as Opaleye+import qualified Opaleye.Internal.Distinct as Opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye+import qualified Opaleye.Internal.PackMap as Opaleye+import qualified Opaleye.Internal.Unpackspec as Opaleye+import qualified Opaleye.Internal.Values as Opaleye+import qualified Opaleye.Internal.Table as Opaleye++-- profunctors+import Data.Profunctor ( dimap, lmap )++-- rel8+import Rel8.Aggregate ( Col( A ), Aggregate( Aggregate ), Aggregates )+import Rel8.Expr ( Expr, Col(..) )+import Rel8.Expr.Opaleye+  ( fromPrimExpr, toPrimExpr+  , traversePrimExpr+  , fromColumn, toColumn+  , scastExpr+  )+import Rel8.Schema.HTable ( htabulateA, hfield, htraverse, hspecs, htabulate )+import Rel8.Schema.Name ( Col( N ), Name( Name ), Selects )+import Rel8.Schema.Spec ( SSpec(..) )+import Rel8.Schema.Table ( TableSchema(..) )+import Rel8.Table ( Table, fromColumns, toColumns )+import Rel8.Table.Undefined ( undefined )++-- semigroupoids+import Data.Functor.Apply ( WrappedApplicative(..) )+++aggregator :: Aggregates aggregates exprs => Opaleye.Aggregator aggregates exprs+aggregator = Opaleye.Aggregator $ Opaleye.PackMap $ \f aggregates ->+  fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->+    WrapApplicative $ case hfield (toColumns aggregates) field of+      A (Aggregate (Opaleye.Aggregator (Opaleye.PackMap inner))) ->+        E <$> inner f ()+++binaryspec :: Table Expr a => Opaleye.Binaryspec a a+binaryspec = Opaleye.Binaryspec $ Opaleye.PackMap $ \f (as, bs) ->+  fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->+    WrapApplicative $+      case (hfield (toColumns as) field, hfield (toColumns bs) field) of+        (E a, E b) -> E . fromPrimExpr <$> f (toPrimExpr a, toPrimExpr b)+++distinctspec :: Table Expr a => Opaleye.Distinctspec a a+distinctspec =+  Opaleye.Distinctspec $ Opaleye.Aggregator $ Opaleye.PackMap $ \f ->+    fmap fromColumns .+    unwrapApplicative .+    htraverse+      (\(E a) ->+         WrapApplicative $ E . fromPrimExpr <$> f (Nothing, toPrimExpr a)) .+    toColumns+++table ::Selects names exprs => TableSchema names -> Opaleye.Table exprs exprs+table (TableSchema name schema columns) =+  case schema of+    Nothing -> Opaleye.Table name (tableFields columns)+    Just schemaName -> Opaleye.TableWithSchema schemaName name (tableFields columns)+++tableFields ::Selects names exprs+  => names -> Opaleye.TableFields exprs exprs+tableFields (toColumns -> names) = dimap toColumns fromColumns $+  unwrapApplicative $ htabulateA $ \field -> WrapApplicative $+    case hfield names field of+      name -> lmap (`hfield` field) (go name)+  where+    go :: Col Name spec -> Opaleye.TableFields (Col Expr spec) (Col Expr spec)+    go (N (Name name)) =+      lmap (\(E a) -> toColumn $ toPrimExpr a) $+        E . fromPrimExpr . fromColumn <$>+          Opaleye.requiredTableField name+++unpackspec :: Table Expr a => Opaleye.Unpackspec a a+unpackspec = Opaleye.Unpackspec $ Opaleye.PackMap $ \f ->+  fmap fromColumns .+  unwrapApplicative .+  htraverse (\(E a) -> WrapApplicative $ E <$> traversePrimExpr f a) .+  toColumns+{-# INLINABLE unpackspec #-}+++valuesspec :: Table Expr a => Opaleye.ValuesspecSafe a a+valuesspec = Opaleye.ValuesspecSafe (toPackMap undefined) unpackspec+++toPackMap :: Table Expr a+  => a -> Opaleye.PackMap Opaleye.PrimExpr Opaleye.PrimExpr () a+toPackMap as = Opaleye.PackMap $ \f () ->+  fmap fromColumns $+  unwrapApplicative .+  htraverse (\(E a) -> WrapApplicative $ E <$> traversePrimExpr f a) $+  toColumns as+++-- | Transform a table by adding 'CAST' to all columns. This is most useful for+-- finalising a SELECT or RETURNING statement, guaranteed that the output+-- matches what is encoded in each columns TypeInformation.+castTable :: Table Expr a => a -> a+castTable (toColumns -> as) = fromColumns $ htabulate \i ->+  case hfield hspecs i of+    SSpec{info} -> +      case hfield as i of+        E expr ->+          E (scastExpr info expr)
+ src/Rel8/Table/Ord.hs view
@@ -0,0 +1,183 @@+{-# language AllowAmbiguousTypes #-}+{-# language DataKinds #-}+{-# language DefaultSignatures #-}+{-# language DisambiguateRecordFields #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeApplications #-}+{-# language TypeFamilies #-}+{-# language TypeOperators #-}+{-# language UndecidableInstances #-}+{-# language UndecidableSuperClasses #-}+{-# language ViewPatterns #-}++module Rel8.Table.Ord+  ( OrdTable( ordTable ), (<:), (<=:), (>:), (>=:), least, greatest+  )+where++-- base+import Data.Functor.Const ( Const( Const ), getConst )+import Data.Kind ( Constraint, Type )+import GHC.Generics ( Rep )+import Prelude hiding ( seq )++-- rel8+import Rel8.Expr ( Expr, Col( E ) )+import Rel8.Expr.Bool ( (||.), (&&.), false, true )+import Rel8.Expr.Eq ( (==.) )+import Rel8.Expr.Ord ( (<.), (>.) )+import Rel8.FCF ( Eval, Exp )+import Rel8.Generic.Record ( Record )+import Rel8.Generic.Table+  ( GGTable, GGColumns, ggtable+  , GAlgebra+  )+import Rel8.Kind.Algebra ( KnownAlgebra )+import Rel8.Schema.Dict ( Dict( Dict ) )+import Rel8.Schema.HTable+  ( HTable, HConstrainTable+  , htabulateA, hfield, hdicts+  )+import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )+import Rel8.Schema.Null (Sql)+import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType, nullifier )+import Rel8.Table ( Columns, toColumns, TColumns )+import Rel8.Table.Bool ( bool )+import Rel8.Table.Eq ( EqTable )+import Rel8.Type.Eq ( DBEq )+import Rel8.Type.Ord ( DBOrd )+++-- | The class of 'Table's that can be ordered. Ordering on tables is defined+-- by their lexicographic ordering of all columns, so this class means "all+-- columns in a 'Table' have an instance of 'DBOrd'".+type OrdTable :: Type -> Constraint+class EqTable a => OrdTable a where+  ordTable :: Columns a (Dict (ConstrainDBType DBOrd))++  default ordTable ::+    ( KnownAlgebra (GAlgebra (Rep (Record a)))+    , Eval (GGTable (GAlgebra (Rep (Record a))) TOrdTable TColumns (Dict (ConstrainDBType DBOrd)) (Rep (Record a)))+    , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))+    )+    => Columns a (Dict (ConstrainDBType DBOrd))+  ordTable =+    ggtable+      @(GAlgebra (Rep (Record a)))+      @TOrdTable+      @TColumns+      @(Rep (Record a))+      table+      nullifier+    where+      table (_ :: proxy x) = ordTable @x+++data TOrdTable :: Type -> Exp Constraint+type instance Eval (TOrdTable a) = OrdTable a+++instance+  ( HTable t+  , f ~ Col Expr+  , HConstrainTable t (ConstrainDBType DBEq)+  , HConstrainTable t (ConstrainDBType DBOrd)+  )+  => OrdTable (t f)+ where+  ordTable = hdicts @(Columns (t f)) @(ConstrainDBType DBOrd)+++instance Sql DBOrd a => OrdTable (Expr a) where+  ordTable = HType Dict+++instance (OrdTable a, OrdTable b) => OrdTable (a, b)+++instance (OrdTable a, OrdTable b, OrdTable c) => OrdTable (a, b, c)+++instance (OrdTable a, OrdTable b, OrdTable c, OrdTable d) => OrdTable (a, b, c, d)+++instance (OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e) =>+  OrdTable (a, b, c, d, e)+++instance+  ( OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e, OrdTable f+  )+  => OrdTable (a, b, c, d, e, f)+++instance+  ( OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e, OrdTable f+  , OrdTable g+  )+  => OrdTable (a, b, c, d, e, f, g)+++-- | Test if one 'Table' sorts before another. Corresponds to comparing all+-- columns with '<'.+(<:) :: forall a. OrdTable a => a -> a -> Expr Bool+(toColumns -> as) <: (toColumns -> bs) =+  foldr @[] go false $ getConst $ htabulateA $ \field ->+    case (hfield as field, hfield bs field) of+      (E a, E b) -> case hfield (ordTable @a) field of+        Dict -> Const [(a <. b, a ==. b)]+  where+    go (lt, eq) a = lt ||. (eq &&. a)+infix 4 <:+++-- | Test if one 'Table' sorts before, or is equal to, another. Corresponds to+-- comparing all columns with '<='.+(<=:) :: forall a. OrdTable a => a -> a -> Expr Bool+(toColumns -> as) <=: (toColumns -> bs) =+  foldr @[] go true $ getConst $ htabulateA $ \field ->+    case (hfield as field, hfield bs field) of+      (E a, E b) -> case hfield (ordTable @a) field of+        Dict -> Const [(a <. b, a ==. b)]+  where+    go (lt, eq) a = lt ||. (eq &&. a)+infix 4 <=:+++-- | Test if one 'Table' sorts after another. Corresponds to comparing all+-- columns with '>'.+(>:) :: forall a. OrdTable a => a -> a -> Expr Bool+(toColumns -> as) >: (toColumns -> bs) =+  foldr @[] go false $ getConst $ htabulateA $ \field ->+    case (hfield as field, hfield bs field) of+      (E a, E b) -> case hfield (ordTable @a) field of+        Dict -> Const [(a >. b, a ==. b)]+  where+    go (gt, eq) a = gt ||. (eq &&. a)+infix 4 >:+++-- | Test if one 'Table' sorts after another. Corresponds to comparing all+-- columns with '>='.+(>=:) :: forall a. OrdTable a => a -> a -> Expr Bool+(toColumns -> as) >=: (toColumns -> bs) =+  foldr @[] go true $ getConst $ htabulateA $ \field ->+    case (hfield as field, hfield bs field) of+      (E a, E b) -> case hfield (ordTable @a) field of+        Dict -> Const [(a >. b, a ==. b)]+  where+    go (gt, eq) a = gt ||. (eq &&. a)+infix 4 >=:+++-- | Given two 'Table's, return the table that sorts before the other.+least :: OrdTable a => a -> a -> a+least a b = bool a b (a <: b)+++-- | Given two 'Table's, return the table that sorts after the other.+greatest :: OrdTable a => a -> a -> a+greatest a b = bool a b (a >: b)
+ src/Rel8/Table/Order.hs view
@@ -0,0 +1,53 @@+{-# language DataKinds #-}+{-# language ScopedTypeVariables #-}+{-# language TypeApplications #-}+{-# language TypeFamilies #-}++module Rel8.Table.Order+  ( ascTable+  , descTable+  )+where++-- base+import Data.Functor.Const ( Const( Const ), getConst )+import Data.Functor.Contravariant ( (>$<), contramap )+import Prelude++-- rel8+import Rel8.Expr ( unE )+import Rel8.Expr.Order ( asc, desc, nullsFirst, nullsLast )+import Rel8.Order ( Order )+import Rel8.Schema.Dict ( Dict( Dict ) )+import Rel8.Schema.HTable (htabulateA, hfield, hspecs)+import Rel8.Schema.Null ( Nullity( Null, NotNull ) )+import Rel8.Schema.Spec ( SSpec( SSpec ) )+import Rel8.Schema.Spec.ConstrainDBType ( dbTypeDict, dbTypeNullity )+import Rel8.Table ( Columns, toColumns )+import Rel8.Table.Ord+++-- | Construct an 'Order' for a 'Table' by sorting all columns into ascending+-- orders (any nullable columns will be sorted with @NULLS FIRST@).+ascTable :: forall a. OrdTable a => Order a+ascTable = contramap toColumns $ getConst $+  htabulateA @(Columns a) $ \field -> case hfield hspecs field of+    SSpec {} -> case hfield (ordTable @a) field of+      dict@Dict -> case dbTypeDict dict of+        Dict -> Const $ unE . (`hfield` field) >$<+          case dbTypeNullity dict of+            Null -> nullsFirst asc+            NotNull -> asc+++-- | Construct an 'Order' for a 'Table' by sorting all columns into descending+-- orders (any nullable columns will be sorted with @NULLS LAST@).+descTable :: forall a. OrdTable a => Order a+descTable = contramap toColumns $ getConst $+  htabulateA @(Columns a) $ \field -> case hfield hspecs field of+    SSpec {} -> case hfield (ordTable @a) field of+      dict@Dict -> case dbTypeDict dict of+        Dict -> Const $ unE . (`hfield` field) >$<+          case dbTypeNullity dict of+            Null -> nullsLast desc+            NotNull -> desc
+ src/Rel8/Table/Recontextualize.hs view
@@ -0,0 +1,90 @@+{-# language DataKinds #-}+{-# language FlexibleInstances #-}+{-# language FunctionalDependencies #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeFamilies #-}+{-# language UndecidableInstances #-}+{-# language UndecidableSuperClasses #-}++module Rel8.Table.Recontextualize+  ( Recontextualize+  )+where++-- base+import Data.Functor.Identity ( Identity )+import Data.Kind ( Constraint, Type )+import Prelude ()++-- rel8+import Rel8.Schema.Context ( Col )+import Rel8.Schema.Context.Label ( Labelable )+import Rel8.Schema.HTable ( HTable )+import qualified Rel8.Schema.Kind as K+import Rel8.Schema.Null ( Sql )+import Rel8.Schema.Result ( Result )+import Rel8.Table ( Table, Congruent )+import Rel8.Type ( DBType )+++-- | @Recontextualize from to a b@ is evidence that the types @a@ and @b@ are+-- related, and that @b@ is the same type as @a@, but after changing the+-- context from the initial context @from@, to the new context @to@.+type Recontextualize :: K.Context -> K.Context -> Type -> Type -> Constraint+class+  ( Table from a+  , Table to b+  , Congruent a b+  , Recontextualize from from a a+  , Recontextualize to to b b+  , Recontextualize to from b a+  ) => Recontextualize from to a b+    | a -> from+    , b -> to+    , a to -> b+    , b from -> a+++instance Sql DBType a => Recontextualize Result Result (Identity a) (Identity a)+++instance HTable t => Recontextualize from to (t (Col from)) (t (Col to))+++instance+  ( Recontextualize from to a1 b1+  , Recontextualize from to a2 b2+  , Labelable from+  , Labelable to+  )+  => Recontextualize from to (a1, a2) (b1, b2)+++instance+  ( Recontextualize from to a1 b1+  , Recontextualize from to a2 b2+  , Recontextualize from to a3 b3+  , Labelable from, Labelable to+  )+  => Recontextualize from to (a1, a2, a3) (b1, b2, b3)+++instance+  ( Recontextualize from to a1 b1+  , Recontextualize from to a2 b2+  , Recontextualize from to a3 b3+  , Recontextualize from to a4 b4+  , Labelable from, Labelable to+  )+  => Recontextualize from to (a1, a2, a3, a4) (b1, b2, b3, b4)+++instance+  ( Recontextualize from to a1 b1+  , Recontextualize from to a2 b2+  , Recontextualize from to a3 b3+  , Recontextualize from to a4 b4+  , Recontextualize from to a5 b5+  , Labelable from, Labelable to+  )+  => Recontextualize from to (a1, a2, a3, a4, a5) (b1, b2, b3, b4, b5)
+ src/Rel8/Table/Rel8able.hs view
@@ -0,0 +1,148 @@+{-# language DataKinds #-}+{-# language FlexibleInstances #-}+{-# language FunctionalDependencies #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeApplications #-}+{-# language TypeFamilies #-}+{-# language UndecidableInstances #-}++{-# options_ghc -fno-warn-orphans #-}++module Rel8.Table.Rel8able+  (+  )+where++-- base+import Data.Kind ( Constraint, Type )+import Data.Type.Equality ( (:~:)( Refl ) )+import Prelude++-- rel8+import Rel8.Expr ( Expr )+import qualified Rel8.Kind.Algebra as K+import Rel8.Kind.Context+  ( SContext( SReify )+  , Reifiable, contextSing+  , sLabelable, sReifiable+  )+import Rel8.Generic.Rel8able+  ( Rel8able, Algebra+  , GColumns, gfromColumns, gtoColumns+  , greify, gunreify+  )+import Rel8.Schema.Context ( Col )+import Rel8.Schema.Context.Label ( Labelable )+import Rel8.Schema.Dict ( Dict( Dict ) )+import qualified Rel8.Schema.Kind as K+import Rel8.Schema.HTable ( HConstrainTable, hdicts )+import Rel8.Schema.Reify ( hreify, hunreify, UnwrapReify )+import Rel8.Schema.Result ( Result )+import Rel8.Table+  ( Table, Columns, Context, Congruent, fromColumns, toColumns+  , Unreify, reify, unreify+  )+import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )+import Rel8.Table.ADT ( ADT( ADT ), ADTable, fromADT, toADT )+import Rel8.Table.Eq ( EqTable, eqTable )+import Rel8.Table.HKD ( HKD )+import Rel8.Table.Ord ( OrdTable, ordTable )+import Rel8.Table.Recontextualize ( Recontextualize )+import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )+import Rel8.Type.Eq ( DBEq )+import Rel8.Type.Ord ( DBOrd )+++instance (Rel8able t, Labelable context, Reifiable context) =>+  Table context (t context)+ where+  type Columns (t context) = GColumns t+  type Context (t context) = context+  type Unreify (t context) = t (UnwrapReify context)++  fromColumns = gunreify . gfromColumns . hreify+  toColumns = hunreify . gtoColumns . greify++  reify Refl = case contextSing @context of+    SReify context -> case sLabelable context of+      Dict -> case sReifiable context of+        Dict -> greify++  unreify Refl = case contextSing @context of+    SReify context -> case sLabelable context of+      Dict -> case sReifiable context of+        Dict -> gunreify+++instance+  ( Rel8able t+  , Labelable from, Reifiable from+  , Labelable to, Reifiable to+  , Congruent (t from) (t to)+  )+  => Recontextualize from to (t from) (t to)+++instance+  ( context ~ Expr+  , Rel8able t+  , HConstrainTable (Columns (t context)) (ConstrainDBType DBEq)+  )+  => EqTable (t context)+ where+  eqTable = hdicts @(Columns (t context)) @(ConstrainDBType DBEq)+++instance+  ( context ~ Expr+  , Rel8able t+  , HConstrainTable (Columns (t context)) (ConstrainDBType DBEq)+  , HConstrainTable (Columns (t context)) (ConstrainDBType DBOrd)+  )+  => OrdTable (t context)+ where+  ordTable = hdicts @(Columns (t context)) @(ConstrainDBType DBOrd)+++type instance FromExprs (t Expr) = FromExprs' t+++instance+  ( x ~ t' Expr+  , result ~ Result+  , ToExprs' (Algebra t) t' t+  )+  => ToExprs x (t result)+ where+  fromResult = fromResult' @(Algebra t) @t'+  toResult = toResult' @(Algebra t) @t'+++type FromExprs' :: K.Rel8able -> Type+type family FromExprs' t where+  FromExprs' (ADT t) = t Result+  FromExprs' (HKD a) = a+  FromExprs' t = t Result+++type ToExprs' :: K.Algebra -> K.Rel8able -> K.Rel8able -> Constraint+class (algebra ~ Algebra t, Rel8able t') =>+  ToExprs' algebra t' t | algebra t -> t'+ where+  fromResult' :: GColumns t' (Col Result) -> t Result+  toResult' :: t Result -> GColumns t' (Col Result)+++instance (Algebra t ~ 'K.Product, Rel8able t, t ~ t') =>+  ToExprs' 'K.Product t' t+ where+  fromResult' = fromColumns+  toResult' = toColumns+++instance (Algebra t ~ 'K.Sum, ADTable t, t' ~ ADT t) =>+  ToExprs' 'K.Sum t' t+ where+  fromResult' = fromADT . ADT+  toResult' = (\(ADT a) -> a) . toADT
+ src/Rel8/Table/Serialize.hs view
@@ -0,0 +1,248 @@+{-# language AllowAmbiguousTypes #-}+{-# language DataKinds #-}+{-# language DefaultSignatures #-}+{-# language DisambiguateRecordFields #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language FunctionalDependencies #-}+{-# language NamedFieldPuns #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeApplications #-}+{-# language TypeFamilies #-}+{-# language TypeOperators #-}+{-# language UndecidableInstances #-}++module Rel8.Table.Serialize+  ( Serializable, lit, parse+  , ToExprs(..), FromExprs+  , TToExprs+  )+where++-- base+import Data.Kind ( Constraint, Type )+import Data.List.NonEmpty ( NonEmpty )+import GHC.Generics ( Generic, Rep, from, to )+import Prelude++-- hasql+import qualified Hasql.Decoders as Hasql++-- rel8+import Rel8.Expr ( Expr, Col( E ) )+import Rel8.Expr.Serialize ( slitExpr, sparseValue )+import Rel8.FCF ( Eval, Exp )+import Rel8.Generic.Record ( Record(..) )+import Rel8.Generic.Table+  ( GGToExprs, GGColumns, ggfromResult, ggtoResult+  , GAlgebra+  )+import Rel8.Kind.Algebra ( KnownAlgebra )+import Rel8.Schema.HTable ( HTable, htabulate, htabulateA, hfield, hspecs )+import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )+import Rel8.Schema.Null ( NotNull, Sql )+import Rel8.Schema.Result ( Col( R ), Result )+import Rel8.Schema.Spec ( SSpec(..), KnownSpec )+import Rel8.Table ( Table, Columns, fromColumns, toColumns, TColumns )+import Rel8.Type ( DBType )++-- semigroupoids+import Data.Functor.Apply ( WrappedApplicative(..) )+++-- | @ToExprs exprs a@ is evidence that the types @exprs@ and @a@ describe+-- essentially the same type, but @exprs@ is in the 'Expr' context, and @a@ is+-- in the 'Result' context.+type ToExprs :: Type -> Type -> Constraint+class Table Expr exprs => ToExprs exprs a where+  fromResult :: Columns exprs (Col Result) -> a+  toResult :: a -> Columns exprs (Col Result)++  default fromResult ::+    ( Generic (Record a)+    , KnownAlgebra (GAlgebra (Rep (Record exprs)))+    , Eval (GGToExprs (GAlgebra (Rep (Record exprs))) TToExprs TColumns (Rep (Record exprs)) (Rep (Record a)))+    , Columns exprs ~ Eval (GGColumns (GAlgebra (Rep (Record exprs))) TColumns (Rep (Record exprs)))+    )+    => Columns exprs (Col Result) -> a+  fromResult =+    unrecord .+    to .+    ggfromResult+      @(GAlgebra (Rep (Record exprs)))+      @TToExprs+      @TColumns+      @(Rep (Record exprs))+      (\(_ :: proxy expr) -> fromResult @expr)++  default toResult ::+    ( Generic (Record a)+    , KnownAlgebra (GAlgebra (Rep (Record exprs)))+    , Eval (GGToExprs (GAlgebra (Rep (Record exprs))) TToExprs TColumns (Rep (Record exprs)) (Rep (Record a)))+    , Columns exprs ~ Eval (GGColumns (GAlgebra (Rep (Record exprs))) TColumns (Rep (Record exprs)))+    )+    => a -> Columns exprs (Col Result)+  toResult =+    ggtoResult+      @(GAlgebra (Rep (Record exprs)))+      @TToExprs+      @TColumns+      @(Rep (Record exprs))+      (\(_ :: proxy expr) -> toResult @expr) .+    from .+    Record+++data TToExprs :: Type -> Type -> Exp Constraint+type instance Eval (TToExprs exprs a) = ToExprs exprs a+++instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs x a where+  fromResult (HType (R a)) = a+  toResult = HType . R+++instance (Sql DBType a, x ~ [a]) => ToExprs (Expr x) [a] where+  fromResult (HType (R a)) = a+  toResult = HType . R+++instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Expr x) (Maybe a)+ where+  fromResult (HType (R a)) = a+  toResult = HType . R+++instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (Expr x) (NonEmpty a)+ where+  fromResult (HType (R a)) = a+  toResult = HType . R+++instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ (exprs1, exprs2)) =>+  ToExprs x (a, b)+++instance+  ( ToExprs exprs1 a+  , ToExprs exprs2 b+  , ToExprs exprs3 c+  , x ~ (exprs1, exprs2, exprs3)+  )+  => ToExprs x (a, b, c)+++instance+  ( ToExprs exprs1 a+  , ToExprs exprs2 b+  , ToExprs exprs3 c+  , ToExprs exprs4 d+  , x ~ (exprs1, exprs2, exprs3, exprs4)+  )+  => ToExprs x (a, b, c, d)+++instance+  ( ToExprs exprs1 a+  , ToExprs exprs2 b+  , ToExprs exprs3 c+  , ToExprs exprs4 d+  , ToExprs exprs5 e+  , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5)+  )+  => ToExprs x (a, b, c, d, e)+++instance+  ( ToExprs exprs1 a+  , ToExprs exprs2 b+  , ToExprs exprs3 c+  , ToExprs exprs4 d+  , ToExprs exprs5 e+  , ToExprs exprs6 f+  , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5, exprs6)+  )+  => ToExprs x (a, b, c, d, e, f)+++instance+  ( ToExprs exprs1 a+  , ToExprs exprs2 b+  , ToExprs exprs3 c+  , ToExprs exprs4 d+  , ToExprs exprs5 e+  , ToExprs exprs6 f+  , ToExprs exprs7 g+  , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5, exprs6, exprs7)+  )+  => ToExprs x (a, b, c, d, e, f, g)+++instance (HTable t, result ~ Col Result, x ~ t (Col Expr)) =>+  ToExprs x (t result)+ where+  fromResult = id+  toResult = id+++instance (KnownSpec spec, x ~ Col Expr spec) =>+  ToExprs x (Col Result spec)+ where+  fromResult = fromColumns+  toResult = toColumns+++-- | The @FromExprs@ type function maps a type in the @Expr@ context to the+-- corresponding type in the @Result@ context.+type FromExprs :: Type -> Type+type family FromExprs a+type instance FromExprs (Expr a) = a+type instance FromExprs (Col Expr spec) = Col Result spec+type instance FromExprs (a, b) = (FromExprs a, FromExprs b)+type instance FromExprs (a, b, c) = (FromExprs a, FromExprs b, FromExprs c)+type instance FromExprs (a, b, c, d) =+  (FromExprs a, FromExprs b, FromExprs c, FromExprs d)+type instance FromExprs (a, b, c, d, e) =+  (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e)+type instance FromExprs (a, b, c, d, e, f) =+  ( FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e+  , FromExprs f+  )+type instance FromExprs (a, b, c, d, e, f, g) =+  ( FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e+  , FromExprs f, FromExprs g+  )+type instance FromExprs (t (Col Expr)) = t (Col Result)+++-- | @Serializable@ witnesses the one-to-one correspondence between the type+-- @sql@, which contains SQL expressions, and the type @haskell@, which+-- contains the Haskell decoding of rows containing @sql@ SQL expressions.+type Serializable :: Type -> Type -> Constraint+class (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a | exprs -> a+instance (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a+instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a+++-- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is+-- capable of lifting single @Expr@s to full tables.+lit :: forall exprs a. Serializable exprs a => a -> exprs+lit = fromColumns . litHTable . toResult @exprs+++parse :: forall exprs a. Serializable exprs a => Hasql.Row a+parse = fromResult @exprs <$> parseHTable+++litHTable :: HTable t => t (Col Result) -> t (Col Expr)+litHTable as = htabulate $ \field ->+  case hfield hspecs field of+    SSpec {nullity, info} -> case hfield as field of+      R value -> E (slitExpr nullity info value)+++parseHTable :: HTable t => Hasql.Row (t (Col Result))+parseHTable = unwrapApplicative $ htabulateA $ \field ->+  WrapApplicative $ case hfield hspecs field of+    SSpec {nullity, info} -> R <$> sparseValue nullity info
+ src/Rel8/Table/Tag.hs view
@@ -0,0 +1,97 @@+{-# language DataKinds #-}+{-# language FlexibleInstances #-}+{-# language GADTs #-}+{-# language InstanceSigs #-}+{-# language NamedFieldPuns #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeApplications #-}+{-# language UndecidableInstances #-}++module Rel8.Table.Tag+  ( Tag(..), Taggable+  , fromAggregate+  , fromExpr+  , fromName+  )+where++-- base+import Control.Applicative ( (<|>), empty )+import Data.Kind ( Constraint, Type )+import Data.Foldable ( fold )+import Data.Monoid ( getFirst )+import Data.Proxy ( Proxy( Proxy ) )+import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )+import Prelude++-- rel8+import Rel8.Aggregate ( Aggregate, Aggregator, foldInputs )+import Rel8.Expr ( Expr )+import Rel8.Expr.Opaleye ( fromPrimExpr )+import Rel8.Schema.Name ( Name( Name ) )+import Rel8.Schema.Null ( Sql )+import Rel8.Type.Monoid ( DBMonoid )+++type Tag :: Symbol -> Type -> Type+data Tag label a = Tag+  { expr :: Expr a+  , aggregator :: Maybe Aggregator+  , name :: Name a+  }+++type Taggable :: Type -> Constraint+class Taggable a where+  tappend :: KnownSymbol label => Tag label a -> Tag label a -> Tag label a+  tempty :: KnownSymbol label => Tag label a+++instance Sql DBMonoid a => Taggable a where+  tappend :: forall label. KnownSymbol label+    => Tag label a -> Tag label a -> Tag label a+  tappend a b = Tag+    { expr = expr a <> expr b+    , aggregator = aggregator a <|> aggregator b+    , name = case (name a, symbolVal (Proxy @label)) of+        (Name x, y)+          | x == y -> name b+          | otherwise -> name a+    }+  {-# INLINABLE tappend #-}++  tempty :: forall label. KnownSymbol label => Tag label a+  tempty = Tag+    { expr = mempty+    , aggregator = empty+    , name = Name (symbolVal (Proxy @label))+    }+  {-# INLINABLE tempty #-}+++instance (KnownSymbol label, Taggable a) => Semigroup (Tag label a) where+  (<>) = tappend+++instance (KnownSymbol label, Taggable a) => Monoid (Tag label a) where+  mempty = tempty+++fromAggregate :: forall a label. (KnownSymbol label, Taggable a)+  => Aggregate a -> Tag label a+fromAggregate = fold . getFirst . foldInputs go+  where+    go aggregator primExpr = pure $ (tempty @a @label)+      { expr = fromPrimExpr primExpr+      , aggregator+      }+++fromExpr :: forall label a. (KnownSymbol label, Taggable a)+  => Expr a -> Tag label a+fromExpr expr = (tempty @a @label) {expr}+++fromName :: forall a label. Taggable a => Name a -> Tag label a+fromName name = (tempty @a @"") {name}
+ src/Rel8/Table/These.hs view
@@ -0,0 +1,341 @@+{-# language DataKinds #-}+{-# language DeriveFunctor #-}+{-# language DerivingStrategies #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language MultiParamTypeClasses #-}+{-# language NamedFieldPuns #-}+{-# language RecordWildCards #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneKindSignatures #-}+{-# language TupleSections #-}+{-# language TypeApplications #-}+{-# language TypeFamilies #-}+{-# language UndecidableInstances #-}++{-# options_ghc -fno-warn-orphans #-}++module Rel8.Table.These+  ( TheseTable(..)+  , theseTable, thisTable, thatTable, thoseTable+  , isThisTable, isThatTable, isThoseTable+  , hasHereTable, hasThereTable+  , justHereTable, justThereTable+  , nameTheseTable+  )+where++-- base+import Control.Applicative ( liftA2 )+import Data.Bifunctor ( Bifunctor, bimap )+import Data.Functor.Identity ( runIdentity )+import Data.Kind ( Type )+import Prelude hiding ( undefined )++-- rel8+import Rel8.Expr ( Expr )+import Rel8.Expr.Bool ( (&&.), not_ )+import Rel8.Expr.Null ( isNonNull )+import Rel8.Schema.Context.Label+  ( Labelable+  , HLabelable, hlabeler, hunlabeler+  )+import Rel8.Schema.Context.Nullify+  ( Nullifiable, ConstrainTag+  , HNullifiable, HConstrainTag+  , hencodeTag, hdecodeTag+  , hnullifier, hunnullifier+  )+import Rel8.Schema.HTable ( HTable )+import Rel8.Schema.HTable.Label ( hlabel, hunlabel )+import Rel8.Schema.HTable.Identity ( HIdentity(..) )+import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )+import Rel8.Schema.HTable.These ( HTheseTable(..) )+import Rel8.Schema.Name ( Name )+import Rel8.Table+  ( Table, Columns, Context, fromColumns, toColumns+  , reify, unreify+  )+import Rel8.Table.Eq ( EqTable, eqTable )+import Rel8.Table.Maybe+  ( MaybeTable(..)+  , maybeTable, justTable, nothingTable+  , isJustTable+  , nameMaybeTable+  )+import Rel8.Table.Ord ( OrdTable, ordTable )+import Rel8.Table.Recontextualize ( Recontextualize )+import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )+import Rel8.Table.Tag ( Tag(..) )+import Rel8.Table.Undefined ( undefined )+import Rel8.Type.Tag ( MaybeTag )++-- semigroupoids+import Data.Functor.Apply ( Apply, (<.>) )+import Data.Functor.Bind ( Bind, (>>-) )++-- these+import Data.These ( These )+++-- | @TheseTable a b@ is a Rel8 table that contains either the table @a@, the+-- table @b@, or both tables @a@ and @b@. You can construct @TheseTable@s using+-- 'thisTable', 'thatTable' and 'thoseTable'. @TheseTable@s can be+-- eliminated/pattern matched using 'theseTable'.+--+-- @TheseTable@ is operationally the same as Haskell's 'These' type, but+-- adapted to work with Rel8.+type TheseTable :: Type -> Type -> Type+data TheseTable a b = TheseTable+  { here :: MaybeTable a+  , there :: MaybeTable b+  }+  deriving stock Functor+++instance Bifunctor TheseTable where+  bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)+++instance (Table Expr a, Semigroup a) => Apply (TheseTable a) where+  fs <.> as = TheseTable+    { here = here fs <> here as+    , there = there fs <.> there as+    }+++instance (Table Expr a, Semigroup a) => Applicative (TheseTable a)+ where+  pure = thatTable+  (<*>) = (<.>)+++instance (Table Expr a, Semigroup a) => Bind (TheseTable a) where+  TheseTable here1 ma >>- f = case ma >>- f' of+    mtb -> TheseTable+      { here = maybeTable here1 ((here1 <>) . fst) mtb+      , there = snd <$> mtb+      }+    where+      f' a = case f a of+        TheseTable here2 mb -> (here2,) <$> mb+++instance (Table Expr a, Semigroup a) => Monad (TheseTable a) where+  (>>=) = (>>-)+++instance (Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>+  Semigroup (TheseTable a b)+ where+  a <> b = TheseTable+    { here = here a <> here b+    , there = there a <> there b+    }+++instance+  ( Table context a, Table context b+  , Labelable context, Nullifiable context, ConstrainTag context MaybeTag+  ) => Table context (TheseTable a b)+ where+  type Columns (TheseTable a b) = HTheseTable (Columns a) (Columns b)+  type Context (TheseTable a b) = Context a++  toColumns = toColumns2 toColumns toColumns+  fromColumns = fromColumns2 fromColumns fromColumns+  reify = liftA2 bimap reify reify+  unreify = liftA2 bimap unreify unreify+++instance+  ( Labelable from, Nullifiable from, ConstrainTag from MaybeTag+  , Labelable to, Nullifiable to, ConstrainTag to MaybeTag+  , Recontextualize from to a1 b1+  , Recontextualize from to a2 b2+  ) =>+  Recontextualize from to (TheseTable a1 a2) (TheseTable b1 b2)+++instance (EqTable a, EqTable b) => EqTable (TheseTable a b) where+  eqTable = toColumns2 id id (thoseTable (eqTable @a) (eqTable @b))+++instance (OrdTable a, OrdTable b) => OrdTable (TheseTable a b) where+  ordTable = toColumns2 id id (thoseTable (ordTable @a) (ordTable @b))+++type instance FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)+++instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable exprs1 exprs2) =>+  ToExprs x (These a b)+ where+  fromResult =+    bimap (fromResult @exprs1) (fromResult @exprs2) .+    fromColumns+  toResult =+    toColumns .+    bimap (toResult @exprs1) (toResult @exprs2)+++toHereTag :: Tag "isJust" a -> Tag "hasHere" a+toHereTag Tag {..} = Tag {..}+++toThereTag :: Tag "isJust" a -> Tag "hasThere" a+toThereTag Tag {..} = Tag {..}+++-- | Test if a 'TheseTable' was constructed with 'thisTable'.+--+-- Corresponds to 'Data.These.Combinators.isThis'.+isThisTable :: TheseTable a b -> Expr Bool+isThisTable a = hasHereTable a &&. not_ (hasThereTable a)+++-- | Test if a 'TheseTable' was constructed with 'thatTable'.+--+-- Corresponds to 'Data.These.Combinators.isThat'.+isThatTable :: TheseTable a b -> Expr Bool+isThatTable a = not_ (hasHereTable a) &&. hasThereTable a+++-- | Test if a 'TheseTable' was constructed with 'thoseTable'.+--+-- Corresponds to 'Data.These.Combinators.isThese'.+isThoseTable :: TheseTable a b -> Expr Bool+isThoseTable a = hasHereTable a &&. hasThereTable a+++-- | Test if the @a@ side of @TheseTable a b@ is present.+--+-- Corresponds to 'Data.These.Combinators.hasHere'.+hasHereTable :: TheseTable a b -> Expr Bool+hasHereTable TheseTable {here} = isJustTable here+++-- | Test if the @b@ table of @TheseTable a b@ is present.+--+-- Corresponds to 'Data.These.Combinators.hasThere'.+hasThereTable :: TheseTable a b -> Expr Bool+hasThereTable TheseTable {there} = isJustTable there+++-- | Attempt to project out the @a@ table of a @TheseTable a b@.+--+-- Corresponds to 'Data.These.Combinators.justHere'.+justHereTable :: TheseTable a b -> MaybeTable a+justHereTable = here+++-- | Attempt to project out the @b@ table of a @TheseTable a b@.+--+-- Corresponds to 'Data.These.Combinators.justThere'.+justThereTable :: TheseTable a b -> MaybeTable b+justThereTable = there+++-- | Construct a @TheseTable@. Corresponds to 'This'.+thisTable :: Table Expr b => a -> TheseTable a b+thisTable a = TheseTable (justTable a) nothingTable+++-- | Construct a @TheseTable@. Corresponds to 'That'.+thatTable :: Table Expr a => b -> TheseTable a b+thatTable b = TheseTable nothingTable (justTable b)+++-- | Construct a @TheseTable@. Corresponds to 'These'.+thoseTable :: a -> b -> TheseTable a b+thoseTable a b = TheseTable (justTable a) (justTable b)+++-- | Pattern match on a 'TheseTable'. Corresponds to 'these'.+theseTable :: Table Expr c+  => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable a b -> c+theseTable f g h TheseTable {here, there} =+  maybeTable+    (maybeTable undefined f here)+    (\b -> maybeTable (g b) (`h` b) here)+    there+++-- | Construct a 'TheseTable' in the 'Name' context. This can be useful if you+-- have a 'TheseTable' that you are storing in a table and need to construct a+-- 'TableSchema'.+nameTheseTable :: ()+  => Name (Maybe MaybeTag)+     -- ^ The name of the column to track the presence of the @a@ table.+  -> Name (Maybe MaybeTag)+     -- ^ The name of the column to track the presence of the @b@ table.+  -> a+     -- ^ Names of the columns in the @a@ table.+  -> b+     -- ^ Names of the columns in the @b@ table.+  -> TheseTable a b+nameTheseTable here there a b =+  TheseTable+    { here = nameMaybeTable here a+    , there = nameMaybeTable there b+    }+++toColumns2 ::+  ( HTable t+  , HTable u+  , HConstrainTag context MaybeTag+  , HLabelable context+  , HNullifiable context+  )+  => (a -> t context)+  -> (b -> u context)+  -> TheseTable a b+  -> HTheseTable t u context+toColumns2 f g TheseTable {here, there} = HTheseTable+  { hhereTag = HIdentity $ hencodeTag (toHereTag (tag here))+  , hhere =+      hlabel hlabeler $ hnullify (hnullifier (tag here) isNonNull) $ f (just here)+  , hthereTag = HIdentity $ hencodeTag (toThereTag (tag there))+  , hthere =+      hlabel hlabeler $ hnullify (hnullifier (tag there) isNonNull) $ g (just there)+  }+++fromColumns2 ::+  ( HTable t+  , HTable u+  , HConstrainTag context MaybeTag+  , HLabelable context+  , HNullifiable context+  )+  => (t context -> a)+  -> (u context -> b)+  -> HTheseTable t u context+  -> TheseTable a b+fromColumns2 f g HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable+  { here =+      let+        tag = hdecodeTag $ unHIdentity hhereTag+      in+        MaybeTable+          { tag+          , just = f $+              runIdentity $+              hunnullify (\a -> pure . hunnullifier a) $+              hunlabel hunlabeler+              hhere+          }+  , there =+      let+        tag = hdecodeTag $ unHIdentity hthereTag+      in+        MaybeTable+          { tag+          , just = g $+              runIdentity $+              hunnullify (\a -> pure . hunnullifier a) $+              hunlabel hunlabeler+              hthere+          }+  }
+ src/Rel8/Table/Undefined.hs view
@@ -0,0 +1,26 @@+{-# language FlexibleContexts #-}+{-# language NamedFieldPuns #-}+{-# language TypeFamilies #-}++module Rel8.Table.Undefined+  ( undefined+  )+where++-- base+import Prelude hiding ( undefined )++-- rel8+import Rel8.Expr ( Expr, Col( E ) )+import Rel8.Expr.Null ( snull, unsafeUnnullify )+import Rel8.Schema.HTable ( htabulate, hfield, hspecs )+import Rel8.Schema.Null ( Nullity( Null, NotNull ) )+import Rel8.Schema.Spec ( SSpec(..) )+import Rel8.Table ( Table, fromColumns )+++undefined :: Table Expr a => a+undefined = fromColumns $ htabulate $ \field -> case hfield hspecs field of+  SSpec {nullity, info} -> case nullity of+    Null -> E (snull info)+    NotNull -> E (unsafeUnnullify (snull info))
+ src/Rel8/Table/Unreify.hs view
@@ -0,0 +1,102 @@+{-# language DataKinds #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language GADTs #-}+{-# language LambdaCase #-}+{-# language MultiParamTypeClasses #-}+{-# language QuantifiedConstraints #-}+{-# language RankNTypes #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeFamilies #-}+{-# language UndecidableInstances #-}++-- | This module implements some machinery for implementing methods of the+-- 'Table' class for a particular special (but important) class of polymorphic+-- @Table@ types.+--+-- This special case is characterised by a @newtype@ wrapper around a bare+-- 'HTable' which is constructed by applying a type family to the polymorphic+-- type variable.+--+-- Examples of this class of @Table@ include @ListTable@ and @NonEmptyTable@.+--+-- The tricky part about implementing @Table@ for these types is 'reify' and+-- 'unreify'. There is no guarantee in general that @'Unreify' a@ is itself+-- a @Table@, let alone a @Table@ with the same 'Columns' as @a@+-- (e.g., @Unreify (AColumn Result Bool) = Bool@, and @Bool@ is not a+-- @Table@)++module Rel8.Table.Unreify+  ( Unreifiable, Unreifiability(..), unreifiability+  , Unreifies+  )+where++-- base+import Data.Kind ( Constraint, Type )+import Prelude ()++-- rel8+import Rel8.Aggregate ( Aggregate )+import Rel8.Expr ( Expr )+import Rel8.Kind.Context ( SContext(..), Reifiable, sReifiable )+import Rel8.Schema.Dict ( Dict( Dict ) )+import qualified Rel8.Schema.Kind as K+import Rel8.Schema.Name ( Name )+import Rel8.Schema.Reify ( Reify )+import Rel8.Schema.Result ( Result )+import Rel8.Table ( Table, Context, Congruent, Unreify )+++type Unreifies :: K.Context -> Type -> Constraint+type family Unreifies context a where+  Unreifies (Reify context) a = Unreifier context a+  Unreifies _ _ = ()+++type Unreifiable :: Type -> Constraint+class+  ( Context a ~ Reify Aggregate => Unreifier Aggregate a+  , Context a ~ Reify Expr => Unreifier Expr a+  , Context a ~ Reify Name => Unreifier Name a+  , (forall ctx. (Context a ~ Reify (Reify ctx), Reifiable ctx) => Unreifier (Reify ctx) a)+  )+  => Unreifiable a+instance+  ( Context a ~ Reify Aggregate => Unreifier Aggregate a+  , Context a ~ Reify Expr => Unreifier Expr a+  , Context a ~ Reify Name => Unreifier Name a+  , (forall ctx. (Context a ~ Reify (Reify ctx), Reifiable ctx) => Unreifier (Reify ctx) a)+  )+  => Unreifiable a+++type Unreifier :: K.Context -> Type -> Constraint+class+  ( Table context (Unreify a)+  , Congruent a (Unreify a)+  )+  => Unreifier context a+instance+  ( Table context (Unreify a)+  , Congruent a (Unreify a)+  )+  => Unreifier context a+++type Unreifiability :: K.Context -> Type -> Type+data Unreifiability context a where+  UResult :: Unreifiability Result a+  Unreifiability :: Unreifier context a+    => SContext context -> Unreifiability context a+++unreifiability :: (Context a ~ Reify context, Unreifiable a)+  => SContext context -> Unreifiability context a+unreifiability = \case+  SAggregate -> Unreifiability SAggregate+  SExpr -> Unreifiability SExpr+  SName -> Unreifiability SName+  SResult -> UResult+  SReify context -> case sReifiable context of+    Dict -> Unreifiability (SReify context)
+ src/Rel8/Type.hs view
@@ -0,0 +1,287 @@+{-# language FlexibleInstances #-}+{-# language MonoLocalBinds #-}+{-# language MultiWayIf #-}+{-# language StandaloneKindSignatures #-}+{-# language UndecidableInstances #-}++module Rel8.Type+  ( DBType (typeInformation)+  )+where++-- aeson+import Data.Aeson ( Value )+import qualified Data.Aeson as Aeson++-- base+import Data.Int ( Int16, Int32, Int64 )+import Data.List.NonEmpty ( NonEmpty )+import Data.Kind ( Constraint, Type )+import Prelude++-- bytestring+import Data.ByteString ( ByteString )+import qualified Data.ByteString.Lazy as Lazy ( ByteString )+import qualified Data.ByteString.Lazy as ByteString ( fromStrict, toStrict )++-- case-insensitive+import Data.CaseInsensitive ( CI )+import qualified Data.CaseInsensitive as CI++-- hasql+import qualified Hasql.Decoders as Hasql++-- opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye+import qualified Opaleye.Internal.HaskellDB.Sql.Default as Opaleye ( quote )++-- rel8+import Rel8.Schema.Null ( NotNull, Sql, nullable )+import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )+import Rel8.Type.Information ( TypeInformation(..), mapTypeInformation )++-- scientific+import Data.Scientific ( Scientific )++-- text+import Data.Text ( Text )+import qualified Data.Text as Text+import qualified Data.Text.Lazy as Lazy ( Text, unpack )+import qualified Data.Text.Lazy as Text ( fromStrict, toStrict )+import qualified Data.Text.Lazy.Encoding as Lazy ( decodeUtf8 )++-- time+import Data.Time.Calendar ( Day )+import Data.Time.Clock ( UTCTime )+import Data.Time.LocalTime+  ( CalendarDiffTime( CalendarDiffTime )+  , LocalTime+  , TimeOfDay+  )+import Data.Time.Format ( formatTime, defaultTimeLocale )++-- uuid+import Data.UUID ( UUID )+import qualified Data.UUID as UUID+++-- | Haskell types that can be represented as expressions in a database. There+-- should be an instance of @DBType@ for all column types in your database+-- schema (e.g., @int@, @timestamptz@, etc).+-- +-- Rel8 comes with stock instances for most default types in PostgreSQL, so you+-- should only need to derive instances of this class for custom database+-- types, such as types defined in PostgreSQL extensions, or custom domain+-- types.+type DBType :: Type -> Constraint+class NotNull a => DBType a where+  typeInformation :: TypeInformation a+++-- | Corresponds to @bool@+instance DBType Bool where+  typeInformation = TypeInformation+    { encode = Opaleye.ConstExpr . Opaleye.BoolLit+    , decode = Hasql.bool+    , typeName = "bool"+    }+++-- | Corresponds to @char@+instance DBType Char where+  typeInformation = TypeInformation+    { encode = Opaleye.ConstExpr . Opaleye.StringLit . pure+    , decode = Hasql.char+    , typeName = "char"+    }+++-- | Corresponds to @int2@+instance DBType Int16 where+  typeInformation = TypeInformation+    { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger+    , decode = Hasql.int2+    , typeName = "int2"+    }+++-- | Corresponds to @int4@+instance DBType Int32 where+  typeInformation = TypeInformation+    { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger+    , decode = Hasql.int4+    , typeName = "int4"+    }+++-- | Corresponds to @int8@+instance DBType Int64 where+  typeInformation = TypeInformation+    { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger+    , decode = Hasql.int8+    , typeName = "int8"+    }+++-- | Corresponds to @float4@+instance DBType Float where+  typeInformation = TypeInformation+    { encode = \x -> Opaleye.ConstExpr+        if | x == (1 /0) -> Opaleye.OtherLit "'Infinity'"+           | isNaN x     -> Opaleye.OtherLit "'NaN'"+           | x == (-1/0) -> Opaleye.OtherLit "'-Infinity'"+           | otherwise   -> Opaleye.NumericLit $ realToFrac x+    , decode = Hasql.float4+    , typeName = "float4"+    }+++-- | Corresponds to @float8@+instance DBType Double where+  typeInformation = TypeInformation+    { encode = \x -> Opaleye.ConstExpr+        if | x == (1 /0) -> Opaleye.OtherLit "'Infinity'"+           | isNaN x     -> Opaleye.OtherLit "'NaN'"+           | x == (-1/0) -> Opaleye.OtherLit "'-Infinity'"+           | otherwise   -> Opaleye.NumericLit $ realToFrac x+    , decode = Hasql.float8+    , typeName = "float8"+    }+++-- | Corresponds to @numeric@+instance DBType Scientific where+  typeInformation = TypeInformation+    { encode = Opaleye.ConstExpr . Opaleye.NumericLit+    , decode = Hasql.numeric+    , typeName = "numeric"+    }+++-- | Corresponds to @timestamptz@+instance DBType UTCTime where+  typeInformation = TypeInformation+    { encode =+        Opaleye.ConstExpr . Opaleye.OtherLit .+        formatTime defaultTimeLocale "'%FT%T%QZ'"+    , decode = Hasql.timestamptz+    , typeName = "timestamptz"+    }+++-- | Corresponds to @date@+instance DBType Day where+  typeInformation = TypeInformation+    { encode =+        Opaleye.ConstExpr . Opaleye.OtherLit .+        formatTime defaultTimeLocale "'%F'"+    , decode = Hasql.date+    , typeName = "date"+    }+++-- | Corresponds to @timestamp@+instance DBType LocalTime where+  typeInformation = TypeInformation+    { encode =+        Opaleye.ConstExpr . Opaleye.OtherLit .+        formatTime defaultTimeLocale "'%FT%T%Q'"+    , decode = Hasql.timestamp+    , typeName = "timestamp"+    }+++-- | Corresponds to @time@+instance DBType TimeOfDay where+  typeInformation = TypeInformation+    { encode =+        Opaleye.ConstExpr . Opaleye.OtherLit .+        formatTime defaultTimeLocale "'%T%Q'"+    , decode = Hasql.time+    , typeName = "time"+    }+++-- | Corresponds to @interval@+instance DBType CalendarDiffTime where+  typeInformation = TypeInformation+    { encode =+        Opaleye.ConstExpr . Opaleye.OtherLit .+        formatTime defaultTimeLocale "'%bmon %0Es'"+    , decode = CalendarDiffTime 0 . realToFrac <$> Hasql.interval+    , typeName = "interval"+    }+++-- | Corresponds to @text@+instance DBType Text where+  typeInformation = TypeInformation+    { encode = Opaleye.ConstExpr . Opaleye.StringLit . Text.unpack+    , decode = Hasql.text+    , typeName = "text"+    }+++-- | Corresponds to @text@+instance DBType Lazy.Text where+  typeInformation =+    mapTypeInformation Text.fromStrict Text.toStrict typeInformation+++-- | Corresponds to @citext@+instance DBType (CI Text) where+  typeInformation = mapTypeInformation CI.mk CI.original typeInformation+    { typeName = "citext"+    }+++-- | Corresponds to @citext@+instance DBType (CI Lazy.Text) where+  typeInformation = mapTypeInformation CI.mk CI.original typeInformation+    { typeName = "citext"+    }+++-- | Corresponds to @bytea@+instance DBType ByteString where+  typeInformation = TypeInformation+    { encode = Opaleye.ConstExpr . Opaleye.ByteStringLit+    , decode = Hasql.bytea+    , typeName = "bytea"+    }+++-- | Corresponds to @bytea@+instance DBType Lazy.ByteString where+  typeInformation =+    mapTypeInformation ByteString.fromStrict ByteString.toStrict+      typeInformation+++-- | Corresponds to @uuid@+instance DBType UUID where+  typeInformation = TypeInformation+    { encode = Opaleye.ConstExpr . Opaleye.StringLit . UUID.toString+    , decode = Hasql.uuid+    , typeName = "uuid"+    }+++-- | Corresponds to @jsonb@+instance DBType Value where+  typeInformation = TypeInformation+    { encode =+        Opaleye.ConstExpr . Opaleye.OtherLit .+        Opaleye.quote .+        Lazy.unpack . Lazy.decodeUtf8 . Aeson.encode+    , decode = Hasql.jsonb+    , typeName = "jsonb"+    }+++instance Sql DBType a => DBType [a] where+  typeInformation = listTypeInformation nullable typeInformation+++instance Sql DBType a => DBType (NonEmpty a) where+  typeInformation = nonEmptyTypeInformation nullable typeInformation
+ src/Rel8/Type/Array.hs view
@@ -0,0 +1,100 @@+{-# language GADTs #-}+{-# language LambdaCase #-}+{-# language NamedFieldPuns #-}+{-# language OverloadedStrings #-}+{-# language ViewPatterns #-}++module Rel8.Type.Array+  ( array, encodeArrayElement, extractArrayElement+  , listTypeInformation+  , nonEmptyTypeInformation+  )+where++-- base+import Data.Foldable ( toList )+import Data.List.NonEmpty ( NonEmpty, nonEmpty )+import Prelude hiding ( null, repeat, zipWith )++-- hasql+import qualified Hasql.Decoders as Hasql++-- opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye++-- rel8+import Rel8.Schema.Null ( Unnullify, Nullity( Null, NotNull ) )+import Rel8.Type.Information ( TypeInformation(..), parseTypeInformation )+++array :: Foldable f+  => TypeInformation a -> f Opaleye.PrimExpr -> Opaleye.PrimExpr+array info =+  Opaleye.CastExpr (arrayType info <> "[]") .+  Opaleye.ArrayExpr . map (encodeArrayElement info) . toList+{-# INLINABLE array #-}+++listTypeInformation :: ()+  => Nullity a+  -> TypeInformation (Unnullify a)+  -> TypeInformation [a]+listTypeInformation nullity info@TypeInformation {encode, decode} =+  TypeInformation+    { decode = case nullity of+        Null ->+          Hasql.listArray (decodeArrayElement info (Hasql.nullable decode))+        NotNull ->+          Hasql.listArray (decodeArrayElement info (Hasql.nonNullable decode))+    , encode = case nullity of+        Null ->+          Opaleye.ArrayExpr .+          fmap (encodeArrayElement info . maybe null encode)+        NotNull ->+          Opaleye.ArrayExpr .+          fmap (encodeArrayElement info . encode)+    , typeName = arrayType info <> "[]"+    }+  where+    null = Opaleye.ConstExpr Opaleye.NullLit+++nonEmptyTypeInformation :: ()+  => Nullity a+  -> TypeInformation (Unnullify a)+  -> TypeInformation (NonEmpty a)+nonEmptyTypeInformation nullity =+  parseTypeInformation parse toList . listTypeInformation nullity+  where+    parse = maybe (Left message) Right . nonEmpty+    message = "failed to decode NonEmptyList: got empty list"+++isArray :: TypeInformation a -> Bool+isArray = \case+  (reverse . typeName -> ']' : '[' : _) -> True+  _ -> False+++arrayType :: TypeInformation a -> String+arrayType info+  | isArray info = "record"+  | otherwise = typeName info+++decodeArrayElement :: TypeInformation a -> Hasql.NullableOrNot Hasql.Value x -> Hasql.NullableOrNot Hasql.Value x+decodeArrayElement info+  | isArray info = Hasql.nonNullable . Hasql.composite . Hasql.field+  | otherwise = id+++encodeArrayElement :: TypeInformation a -> Opaleye.PrimExpr -> Opaleye.PrimExpr+encodeArrayElement info+  | isArray info = Opaleye.UnExpr (Opaleye.UnOpOther "ROW")+  | otherwise = id+++extractArrayElement :: TypeInformation a -> Opaleye.PrimExpr -> Opaleye.PrimExpr+extractArrayElement info+  | isArray info = flip Opaleye.CompositeExpr "f1"+  | otherwise = id
+ src/Rel8/Type/Composite.hs view
@@ -0,0 +1,134 @@+{-# language AllowAmbiguousTypes #-}+{-# language BlockArguments #-}+{-# language DataKinds #-}+{-# language FlexibleContexts #-}+{-# language GADTs #-}+{-# language NamedFieldPuns #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeApplications #-}+{-# language UndecidableInstances #-}+{-# language UndecidableSuperClasses #-}+{-# language ViewPatterns #-}++module Rel8.Type.Composite+  ( Composite( Composite )+  , DBComposite( compositeFields, compositeTypeName )+  , compose, decompose+  )+where++-- base+import Data.Functor.Const ( Const( Const ), getConst )+import Data.Kind ( Constraint, Type )+import Prelude++-- hasql+import qualified Hasql.Decoders as Hasql++-- opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye++-- rel8+import Rel8.Expr ( Col( E ), Expr )+import Rel8.Expr.Opaleye ( castExpr, fromPrimExpr, toPrimExpr )+import Rel8.Schema.HTable ( hfield, hspecs, htabulate, htabulateA )+import Rel8.Schema.Name ( Col( N ), Name( Name ) )+import Rel8.Schema.Null ( Nullity( Null, NotNull ) )+import Rel8.Schema.Result ( Col( R ), Result )+import Rel8.Schema.Spec ( SSpec( SSpec, nullity, info ) )+import Rel8.Table ( Table, fromColumns, toColumns )+import Rel8.Table.Eq ( EqTable )+import Rel8.Table.HKD ( HKD, HKDable, fromHKD, toHKD )+import Rel8.Table.Ord ( OrdTable )+import Rel8.Table.Rel8able ()+import Rel8.Table.Serialize ( lit )+import Rel8.Type ( DBType, typeInformation )+import Rel8.Type.Eq ( DBEq )+import Rel8.Type.Information ( TypeInformation(..) )+import Rel8.Type.Ord ( DBOrd, DBMax, DBMin )++-- semigroupoids+import Data.Functor.Apply ( WrappedApplicative(..) )+++-- | A deriving-via helper type for column types that store a Haskell product+-- type in a single Postgres column using a Postgres composite type.+--+-- Note that this must map to a specific extant type in your database's schema+-- (created with @CREATE TYPE@). Use 'DBComposite' to specify the name of this+-- Postgres type and the names of the individual fields (for projecting with+-- 'decompose').+type Composite :: Type -> Type+newtype Composite a = Composite+  { unComposite :: a+  }+++instance DBComposite a => DBType (Composite a) where+  typeInformation = TypeInformation+    { decode = Hasql.composite (Composite . fromHKD <$> decoder)+    , encode = encoder . lit . toColumns . toHKD . unComposite+    , typeName = compositeTypeName @a+    }+++instance (DBComposite a, EqTable (HKD a Expr)) => DBEq (Composite a)+++instance (DBComposite a, OrdTable (HKD a Expr)) => DBOrd (Composite a)+++instance (DBComposite a, OrdTable (HKD a Expr)) => DBMax (Composite a)+++instance (DBComposite a, OrdTable (HKD a Expr)) => DBMin (Composite a)+++-- | 'DBComposite' is used to associate composite type metadata with a Haskell+-- type.+type DBComposite :: Type -> Constraint+class (DBType a, HKDable a) => DBComposite a where+  -- | The names of all fields in the composite type that @a@ maps to.+  compositeFields :: HKD a Name++  -- | The name of the composite type that @a@ maps to.+  compositeTypeName :: String+++-- | Collapse a 'HKD' into a PostgreSQL composite type.+--+-- 'HKD' values are represented in queries by having a column for each field in+-- the corresponding Haskell type. 'compose' collapses these columns into a+-- single column expression, by combining them into a PostgreSQL composite+-- type.+compose :: DBComposite a => HKD a Expr -> Expr a+compose = castExpr . fromPrimExpr . encoder+++-- | Expand a composite type into a 'HKD'.+--+-- 'decompose' is the inverse of 'compose'.+decompose :: forall a. DBComposite a => Expr a -> HKD a Expr+decompose (toPrimExpr -> a) = fromColumns $ htabulate \field ->+  case hfield names field of+    N (Name name) -> case hfield hspecs field of+      SSpec {} -> E $ fromPrimExpr $ Opaleye.CompositeExpr a name+  where+    names = toColumns (compositeFields @a)+++decoder :: Table Result a => Hasql.Composite a+decoder = fmap fromColumns $ unwrapApplicative $ htabulateA \field ->+  case hfield hspecs field of+    SSpec {nullity, info} -> WrapApplicative $ R <$>+      case nullity of+        Null -> Hasql.field $ Hasql.nullable $ decode info+        NotNull -> Hasql.field $ Hasql.nonNullable $ decode info+++encoder :: Table Expr a => a -> Opaleye.PrimExpr+encoder (toColumns -> a) = Opaleye.FunExpr "ROW" exprs+  where+    exprs = getConst $ htabulateA \field -> case hfield a field of+      E (toPrimExpr -> expr) -> Const [expr]
+ src/Rel8/Type/Enum.hs view
@@ -0,0 +1,138 @@+{-# language AllowAmbiguousTypes #-}+{-# language DataKinds #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language LambdaCase #-}+{-# language RankNTypes #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeApplications #-}+{-# language TypeFamilies #-}+{-# language TypeOperators #-}+{-# language UndecidableInstances #-}++module Rel8.Type.Enum+  ( Enum( Enum )+  , DBEnum( enumValue, enumTypeName )+  , Enumable+  )+where++-- base+import Control.Applicative ( (<|>) )+import Control.Arrow ( (&&&) )+import Data.Kind ( Constraint, Type )+import Data.Proxy ( Proxy( Proxy ) )+import GHC.Generics+  ( Generic, Rep, from, to+  , (:+:)( L1, R1 ), M1( M1 ), U1( U1 )+  , D, C, Meta( MetaCons )+  )+import GHC.TypeLits ( KnownSymbol, symbolVal )+import Prelude hiding ( Enum )++-- hasql+import qualified Hasql.Decoders as Hasql++-- opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye++-- rel8+import Rel8.Type ( DBType, typeInformation )+import Rel8.Type.Eq ( DBEq )+import Rel8.Type.Information ( TypeInformation(..) )+import Rel8.Type.Ord ( DBOrd, DBMax, DBMin )++-- text+import Data.Text ( pack )+++-- | A deriving-via helper type for column types that store an \"enum\" type+-- (in Haskell terms, a sum type where all constructors are nullary) using a+-- Postgres @enum@ type.+--+-- Note that this should map to a specific type in your database's schema+-- (explicitly created with @CREATE TYPE ... AS ENUM@). Use 'DBEnum' to+-- specify the name of this Postgres type and the names of the individual+-- values. If left unspecified, the names of the values of the Postgres+-- @enum@ are assumed to match exactly exactly the names of the constructors+-- of the Haskell type (up to and including case sensitivity).+type Enum :: Type -> Type+newtype Enum a = Enum+  { unEnum :: a+  }+++instance DBEnum a => DBType (Enum a) where+  typeInformation = TypeInformation+    { decode =+        Hasql.enum $+        flip lookup $+        map ((pack . enumValue &&& Enum) . to) $+        genumerate @(Rep a)+    , encode =+        Opaleye.ConstExpr .+        Opaleye.StringLit .+        enumValue @a .+        unEnum+    , typeName = enumTypeName @a+    }+++instance DBEnum a => DBEq (Enum a)+++instance DBEnum a => DBOrd (Enum a)+++instance DBEnum a => DBMax (Enum a)+++instance DBEnum a => DBMin (Enum a)+++-- | @DBEnum@ contains the necessary metadata to describe a PostgreSQL @enum@ type.+type DBEnum :: Type -> Constraint+class (DBType a, Enumable a) => DBEnum a where+  -- | Map Haskell values to the corresponding element of the @enum@ type. The+  -- default implementation of this method will use the exact name of the+  -- Haskell constructors.+  enumValue :: a -> String+  enumValue = gshow @(Rep a) . from++  -- | The name of the PostgreSQL @enum@ type that @a@ maps to.+  enumTypeName :: String+++-- | Types that are sum types, where each constructor is unary (that is, has no+-- fields).+class (Generic a, GEnumable (Rep a)) => Enumable a+instance (Generic a, GEnumable (Rep a)) => Enumable a+++type GEnumable :: (Type -> Type) -> Constraint+class GEnumable rep where+  genumerate :: [rep x]+  gshow :: rep x -> String+++instance GEnumable rep => GEnumable (M1 D meta rep) where+  genumerate = M1 <$> genumerate+  gshow (M1 rep) = gshow rep+++instance (GEnumable a, GEnumable b) => GEnumable (a :+: b) where+  genumerate = L1 <$> genumerate <|> R1 <$> genumerate+  gshow = \case+    L1 a -> gshow a+    R1 a -> gshow a+++instance+  ( meta ~ 'MetaCons name _fixity _isRecord+  , KnownSymbol name+  )+  => GEnumable (M1 C meta U1)+ where+  genumerate = [M1 U1]+  gshow (M1 U1) = symbolVal (Proxy @name)
+ src/Rel8/Type/Eq.hs view
@@ -0,0 +1,78 @@+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language MonoLocalBinds #-}+{-# language MultiParamTypeClasses #-}+{-# language StandaloneKindSignatures #-}+{-# language UndecidableInstances #-}++module Rel8.Type.Eq+  ( DBEq+  )+where++-- aeson+import Data.Aeson ( Value )++-- base+import Data.List.NonEmpty ( NonEmpty )+import Data.Int ( Int16, Int32, Int64 )+import Data.Kind ( Constraint, Type )+import Prelude++-- bytestring+import Data.ByteString ( ByteString )+import qualified Data.ByteString.Lazy as Lazy ( ByteString )++-- case-insensitive+import Data.CaseInsensitive ( CI )++-- rel8+import Rel8.Schema.Null ( Sql )+import Rel8.Type ( DBType )++-- scientific+import Data.Scientific ( Scientific )++-- text+import Data.Text ( Text )+import qualified Data.Text.Lazy as Lazy ( Text )++-- time+import Data.Time.Calendar ( Day )+import Data.Time.Clock ( UTCTime )+import Data.Time.LocalTime ( CalendarDiffTime, LocalTime, TimeOfDay )++-- uuid+import Data.UUID ( UUID )+++-- | Database types that can be compared for equality in queries. If a type is+-- an instance of 'DBEq', it means we can compare expressions for equality+-- using the SQL @=@ operator.+type DBEq :: Type -> Constraint+class DBType a => DBEq a+++instance DBEq Bool+instance DBEq Char+instance DBEq Int16+instance DBEq Int32+instance DBEq Int64+instance DBEq Float+instance DBEq Double+instance DBEq Scientific+instance DBEq UTCTime+instance DBEq Day+instance DBEq LocalTime+instance DBEq TimeOfDay+instance DBEq CalendarDiffTime+instance DBEq Text+instance DBEq Lazy.Text+instance DBEq (CI Text)+instance DBEq (CI Lazy.Text)+instance DBEq ByteString+instance DBEq Lazy.ByteString+instance DBEq UUID+instance DBEq Value+instance Sql DBEq a => DBEq [a]+instance Sql DBEq a => DBEq (NonEmpty a)
+ src/Rel8/Type/Information.hs view
@@ -0,0 +1,67 @@+{-# language GADTs #-}+{-# language NamedFieldPuns #-}+{-# language StandaloneKindSignatures #-}++module Rel8.Type.Information+  ( TypeInformation(..)+  , mapTypeInformation+  , parseTypeInformation+  )+where++-- base+import Data.Bifunctor ( first )+import Data.Kind ( Type )+import Prelude++-- hasql+import qualified Hasql.Decoders as Hasql++-- opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye++-- text+import qualified Data.Text as Text+++-- | @TypeInformation@ describes how to encode and decode a Haskell type to and+-- from database queries. The @typeName@ is the name of the type in the+-- database, which is used to accurately type literals. +type TypeInformation :: Type -> Type+data TypeInformation a = TypeInformation+  { encode :: a -> Opaleye.PrimExpr+    -- ^ How to encode a single Haskell value as a SQL expression.+  , decode :: Hasql.Value a+    -- ^ How to deserialize a single result back to Haskell.+  , typeName :: String+    -- ^ The name of the SQL type.+  }+++-- | Simultaneously map over how a type is both encoded and decoded, while+-- retaining the name of the type. This operation is useful if you want to+-- essentially @newtype@ another 'Rel8.DBType'.+-- +-- The mapping is required to be total. If you have a partial mapping, see+-- 'parseTypeInformation'.+mapTypeInformation :: ()+  => (a -> b) -> (b -> a)+  -> TypeInformation a -> TypeInformation b+mapTypeInformation = parseTypeInformation . fmap pure+++-- | Apply a parser to 'TypeInformation'.+-- +-- This can be used if the data stored in the database should only be subset of+-- a given 'TypeInformation'. The parser is applied when deserializing rows+-- returned - the encoder assumes that the input data is already in the+-- appropriate form.+parseTypeInformation :: ()+  => (a -> Either String b) -> (b -> a)+  -> TypeInformation a -> TypeInformation b+parseTypeInformation to from TypeInformation {encode, decode, typeName} =+  TypeInformation+    { encode = encode . from+    , decode = Hasql.refine (first Text.pack . to) decode+    , typeName+    }
+ src/Rel8/Type/JSONBEncoded.hs view
@@ -0,0 +1,31 @@+module Rel8.Type.JSONBEncoded ( JSONBEncoded(..) ) where++-- aeson+import Data.Aeson ( FromJSON, ToJSON, parseJSON, toJSON )+import Data.Aeson.Types ( parseEither )++-- base+import Data.Bifunctor ( first )+import Prelude++-- hasql+import qualified Hasql.Decoders as Hasql++-- rel8+import Rel8.Type ( DBType(..) )+import Rel8.Type.Information ( TypeInformation(..) )++-- text+import Data.Text ( pack )+++-- | Like 'Rel8.JSONEncoded', but works for @jsonb@ columns.+newtype JSONBEncoded a = JSONBEncoded { fromJSONBEncoded :: a }+++instance (FromJSON a, ToJSON a) => DBType (JSONBEncoded a) where+  typeInformation = TypeInformation+    { encode = encode typeInformation . toJSON . fromJSONBEncoded+    , decode = Hasql.refine (first pack . fmap JSONBEncoded . parseEither parseJSON) Hasql.jsonb+    , typeName = "jsonb"+    }
+ src/Rel8/Type/JSONEncoded.hs view
@@ -0,0 +1,25 @@+module Rel8.Type.JSONEncoded ( JSONEncoded(..) ) where++-- aeson+import Data.Aeson ( FromJSON, ToJSON, parseJSON, toJSON )+import Data.Aeson.Types ( parseEither )++-- base+import Prelude++-- rel8+import Rel8.Type ( DBType(..) )+import Rel8.Type.Information ( parseTypeInformation )+++-- | A deriving-via helper type for column types that store a Haskell value+-- using a JSON encoding described by @aeson@'s 'ToJSON' and 'FromJSON' type+-- classes.+newtype JSONEncoded a = JSONEncoded { fromJSONEncoded :: a }+++instance (FromJSON a, ToJSON a) => DBType (JSONEncoded a) where+  typeInformation = parseTypeInformation f g typeInformation+    where+      f = fmap JSONEncoded . parseEither parseJSON+      g = toJSON . fromJSONEncoded
+ src/Rel8/Type/Monoid.hs view
@@ -0,0 +1,79 @@+{-# language DataKinds #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language MultiParamTypeClasses #-}+{-# language OverloadedStrings #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeFamilies #-}+{-# language UndecidableInstances #-}++module Rel8.Type.Monoid+  ( DBMonoid( memptyExpr )+  )+where++-- base+import Data.Kind ( Constraint, Type )+import Prelude hiding ( null )++-- bytestring+import Data.ByteString ( ByteString )+import qualified Data.ByteString.Lazy as Lazy ( ByteString )++-- case-insensitive+import Data.CaseInsensitive ( CI )++-- rel8+import {-# SOURCE #-} Rel8.Expr ( Expr )+import Rel8.Expr.Array ( sempty )+import Rel8.Expr.Serialize ( litExpr )+import Rel8.Schema.Null ( Sql )+import Rel8.Type ( DBType, typeInformation )+import Rel8.Type.Semigroup ( DBSemigroup )++-- text+import Data.Text ( Text )+import qualified Data.Text.Lazy as Lazy ( Text )++-- time+import Data.Time.LocalTime ( CalendarDiffTime( CalendarDiffTime ) )+++-- | The class of 'Rel8.DBType's that form a semigroup. This class is purely a+-- Rel8 concept, and exists to mirror the 'Monoid' class.+type DBMonoid :: Type -> Constraint+class DBSemigroup a => DBMonoid a where+  -- The identity for '<>.'+  memptyExpr :: Expr a+++instance Sql DBType a => DBMonoid [a] where+  memptyExpr = sempty typeInformation+++instance DBMonoid CalendarDiffTime where+  memptyExpr = litExpr (CalendarDiffTime 0 0)+++instance DBMonoid Text where+  memptyExpr = litExpr ""+++instance DBMonoid Lazy.Text where+  memptyExpr = litExpr ""+++instance DBMonoid (CI Text) where+  memptyExpr = litExpr ""+++instance DBMonoid (CI Lazy.Text) where+  memptyExpr = litExpr ""+++instance DBMonoid ByteString where+  memptyExpr = litExpr ""+++instance DBMonoid Lazy.ByteString where+  memptyExpr = litExpr ""
+ src/Rel8/Type/Num.hs view
@@ -0,0 +1,58 @@+{-# language DataKinds #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language MultiParamTypeClasses #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeFamilies #-}+{-# language UndecidableInstances #-}++module Rel8.Type.Num+  ( DBNum, DBIntegral, DBFractional, DBFloating+  )+where++-- base+import Data.Int ( Int16, Int32, Int64 )+import Data.Kind ( Constraint, Type )+import Prelude++-- rel8+import Rel8.Type ( DBType )++-- scientific+import Data.Scientific ( Scientific )+++-- | The class of database types that support the @+@, @*@, @-@ operators, and+-- the @abs@, @negate@, @sign@ functions.+type DBNum :: Type -> Constraint+class DBType a => DBNum a+instance DBNum Int16+instance DBNum Int32+instance DBNum Int64+instance DBNum Float+instance DBNum Double+instance DBNum Scientific+++-- | The class of database types that can be coerced to from integral+-- expressions. This is a Rel8 concept, and allows us to provide+-- 'fromIntegral'.+type DBIntegral :: Type -> Constraint+class DBNum a => DBIntegral a+instance DBIntegral Int16+instance DBIntegral Int32+instance DBIntegral Int64+++-- | The class of database types that support the @/@ operator.+class DBNum a => DBFractional a+instance DBFractional Float+instance DBFractional Double+instance DBFractional Scientific+++-- | The class of database types that support the @/@ operator.+class DBFractional a => DBFloating a+instance DBFloating Float+instance DBFloating Double
+ src/Rel8/Type/Ord.hs view
@@ -0,0 +1,124 @@+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language MonoLocalBinds #-}+{-# language MultiParamTypeClasses #-}+{-# language StandaloneKindSignatures #-}+{-# language UndecidableInstances #-}++module Rel8.Type.Ord+  ( DBOrd+  , DBMax, DBMin+  )+where++-- base+import Data.Int ( Int16, Int32, Int64 )+import Data.Kind ( Constraint, Type )+import Data.List.NonEmpty ( NonEmpty )+import Prelude++-- bytestring+import Data.ByteString ( ByteString )+import qualified Data.ByteString.Lazy as Lazy ( ByteString )++-- case-insensitive+import Data.CaseInsensitive ( CI )++-- rel8+import Rel8.Schema.Null ( Sql )+import Rel8.Type.Eq ( DBEq )++-- scientific+import Data.Scientific ( Scientific )++-- text+import Data.Text ( Text )+import qualified Data.Text.Lazy as Lazy ( Text )++-- time+import Data.Time.Calendar ( Day )+import Data.Time.Clock ( UTCTime )+import Data.Time.LocalTime ( CalendarDiffTime, LocalTime, TimeOfDay )++-- uuid+import Data.UUID ( UUID )+++-- | The class of database types that support the @<@, @<=@, @>@ and @>=@+-- operators.+type DBOrd :: Type -> Constraint+class DBEq a => DBOrd a+instance DBOrd Bool+instance DBOrd Char+instance DBOrd Int16+instance DBOrd Int32+instance DBOrd Int64+instance DBOrd Float+instance DBOrd Double+instance DBOrd Scientific+instance DBOrd UTCTime+instance DBOrd Day+instance DBOrd LocalTime+instance DBOrd TimeOfDay+instance DBOrd CalendarDiffTime+instance DBOrd Text+instance DBOrd Lazy.Text+instance DBOrd (CI Text)+instance DBOrd (CI Lazy.Text)+instance DBOrd ByteString+instance DBOrd Lazy.ByteString+instance DBOrd UUID+instance Sql DBOrd a => DBOrd [a]+instance Sql DBOrd a => DBOrd (NonEmpty a)+++-- | The class of database types that support the @max@ aggregation function.+type DBMax :: Type -> Constraint+class DBOrd a => DBMax a+instance DBMax Bool+instance DBMax Char+instance DBMax Int16+instance DBMax Int32+instance DBMax Int64+instance DBMax Float+instance DBMax Double+instance DBMax Scientific+instance DBMax UTCTime+instance DBMax Day+instance DBMax LocalTime+instance DBMax TimeOfDay+instance DBMax CalendarDiffTime+instance DBMax Text+instance DBMax Lazy.Text+instance DBMax (CI Text)+instance DBMax (CI Lazy.Text)+instance DBMax ByteString+instance DBMax Lazy.ByteString+instance Sql DBMax a => DBMax [a]+instance Sql DBMax a => DBMax (NonEmpty a)+++-- | The class of database types that support the @min@ aggregation function.+type DBMin :: Type -> Constraint+class DBOrd a => DBMin a+instance DBMin Bool+instance DBMin Char+instance DBMin Int16+instance DBMin Int32+instance DBMin Int64+instance DBMin Float+instance DBMin Double+instance DBMin Scientific+instance DBMin UTCTime+instance DBMin Day+instance DBMin LocalTime+instance DBMin TimeOfDay+instance DBMin CalendarDiffTime+instance DBMin Text+instance DBMin Lazy.Text+instance DBMin (CI Text)+instance DBMin (CI Lazy.Text)+instance DBMin ByteString+instance DBMin Lazy.ByteString+instance Sql DBMin a => DBMin [a]+instance Sql DBMin a => DBMin (NonEmpty a)
+ src/Rel8/Type/ReadShow.hs view
@@ -0,0 +1,32 @@+{-# language ScopedTypeVariables #-}+{-# language TypeApplications #-}+{-# language ViewPatterns #-}++module Rel8.Type.ReadShow ( ReadShow(..) ) where++-- base+import Data.Proxy ( Proxy( Proxy ) )+import Data.Typeable ( Typeable, typeRep )+import Prelude +import Text.Read ( readMaybe )++-- rel8+import Rel8.Type ( DBType( typeInformation ) )+import Rel8.Type.Information ( parseTypeInformation )++-- text+import qualified Data.Text as Text+++-- | A deriving-via helper type for column types that store a Haskell value+-- using a Haskell's 'Read' and 'Show' type classes.+newtype ReadShow a = ReadShow { fromReadShow :: a }+++instance (Read a, Show a, Typeable a) => DBType (ReadShow a) where+  typeInformation = parseTypeInformation parser printer typeInformation+    where+      parser (Text.unpack -> t) = case readMaybe t of+        Just ok -> Right $ ReadShow ok+        Nothing -> Left $ "Could not read " <> t <> " as a " <> show (typeRep (Proxy @a))+      printer = Text.pack . show . fromReadShow
+ src/Rel8/Type/Semigroup.hs view
@@ -0,0 +1,87 @@+{-# language BlockArguments #-}+{-# language DataKinds #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language MultiParamTypeClasses #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeFamilies #-}+{-# language UndecidableInstances #-}++module Rel8.Type.Semigroup+  ( DBSemigroup( (<>.))+  )+where++-- base+import Data.Kind ( Constraint, Type )+import Data.List.NonEmpty ( NonEmpty )+import Prelude ()++-- bytestring+import Data.ByteString ( ByteString )+import qualified Data.ByteString.Lazy as Lazy ( ByteString )++-- case-insensitive+import Data.CaseInsensitive ( CI )++-- opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye++-- rel8+import {-# SOURCE #-} Rel8.Expr ( Expr )+import Rel8.Expr.Array ( sappend, sappend1 )+import Rel8.Expr.Opaleye ( zipPrimExprsWith )+import Rel8.Schema.Null ( Sql )+import Rel8.Type ( DBType )++-- text+import Data.Text ( Text )+import qualified Data.Text.Lazy as Lazy ( Text )++-- time+import Data.Time.LocalTime ( CalendarDiffTime )+++-- | The class of 'Rel8.DBType's that form a semigroup. This class is purely a+-- Rel8 concept, and exists to mirror the 'Semigroup' class.+type DBSemigroup :: Type -> Constraint+class DBType a => DBSemigroup a where+  -- | An associative operation.+  (<>.) :: Expr a -> Expr a -> Expr a+  infixr 6 <>.+++instance Sql DBType a => DBSemigroup [a] where+  (<>.) = sappend+++instance Sql DBType a => DBSemigroup (NonEmpty a) where+  (<>.) = sappend1+++instance DBSemigroup CalendarDiffTime where+  (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:+))+++instance DBSemigroup Text where+  (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))+++instance DBSemigroup Lazy.Text where+  (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))+++instance DBSemigroup (CI Text) where+  (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))+++instance DBSemigroup (CI Lazy.Text) where+  (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))+++instance DBSemigroup ByteString where+  (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))+++instance DBSemigroup Lazy.ByteString where+  (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))
+ src/Rel8/Type/String.hs view
@@ -0,0 +1,40 @@+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language MultiParamTypeClasses #-}+{-# language StandaloneKindSignatures #-}+{-# language UndecidableInstances #-}++module Rel8.Type.String+  ( DBString+  )+where++-- base+import Data.Kind ( Constraint, Type )+import Prelude ()++-- bytestring+import Data.ByteString ( ByteString )+import qualified Data.ByteString.Lazy as Lazy ( ByteString )++-- case-insensitive+import Data.CaseInsensitive ( CI )++-- rel8+import Rel8.Type ( DBType )++-- text+import Data.Text ( Text )+import qualified Data.Text.Lazy as Lazy ( Text )+++-- | The class of data types that support the @string_agg()@ aggregation+-- function.+type DBString :: Type -> Constraint+class DBType a => DBString a+instance DBString Text+instance DBString Lazy.Text+instance DBString (CI Text)+instance DBString (CI Lazy.Text)+instance DBString ByteString+instance DBString Lazy.ByteString
+ src/Rel8/Type/Sum.hs view
@@ -0,0 +1,38 @@+{-# language DataKinds #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language MultiParamTypeClasses #-}+{-# language TypeFamilies #-}+{-# language StandaloneKindSignatures #-}+{-# language UndecidableInstances #-}++module Rel8.Type.Sum+  ( DBSum+  )+where++-- base+import Data.Int ( Int16, Int32, Int64 )+import Data.Kind ( Constraint, Type )+import Prelude++-- rel8+import Rel8.Type ( DBType )++-- scientific+import Data.Scientific ( Scientific )++-- time+import Data.Time.LocalTime ( CalendarDiffTime )+++-- | The class of database types that support the @sum()@ aggregation function.+type DBSum :: Type -> Constraint+class DBType a => DBSum a+instance DBSum Int16+instance DBSum Int32+instance DBSum Int64+instance DBSum Float+instance DBSum Double+instance DBSum Scientific+instance DBSum CalendarDiffTime
+ src/Rel8/Type/Tag.hs view
@@ -0,0 +1,97 @@+{-# language DataKinds #-}+{-# language DeriveAnyClass #-}+{-# language DerivingVia #-}+{-# language GeneralizedNewtypeDeriving #-}+{-# language StandaloneKindSignatures #-}++module Rel8.Type.Tag+  ( EitherTag( IsLeft, IsRight ), isLeft, isRight+  , MaybeTag( IsJust )+  , Tag( Tag )+  )+where++-- base+import Data.Bool ( bool )+import Data.Kind ( Type )+import Data.Semigroup ( Min( Min ) )+import Prelude++-- opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye++-- rel8+import {-# SOURCE #-} Rel8.Expr ( Expr )+import Rel8.Expr.Eq ( (==.) )+import Rel8.Expr.Opaleye ( zipPrimExprsWith )+import Rel8.Expr.Serialize ( litExpr )+import Rel8.Type.Eq ( DBEq )+import Rel8.Type ( DBType, typeInformation )+import Rel8.Type.Information ( mapTypeInformation, parseTypeInformation )+import Rel8.Type.Monoid ( DBMonoid, memptyExpr )+import Rel8.Type.Ord ( DBOrd )+import Rel8.Type.Semigroup ( DBSemigroup, (<>.) )++-- text+import Data.Text ( Text )+++type EitherTag :: Type+data EitherTag = IsLeft | IsRight+  deriving stock (Eq, Ord, Read, Show, Enum, Bounded)+  deriving (Semigroup, Monoid) via (Min EitherTag)+  deriving anyclass (DBEq, DBOrd)+++instance DBType EitherTag where+  typeInformation = mapTypeInformation to from typeInformation+    where+      to = bool IsLeft IsRight+      from IsLeft = False+      from IsRight = True+++instance DBSemigroup EitherTag where+  (<>.) = zipPrimExprsWith (Opaleye.BinExpr Opaleye.OpAnd)+++instance DBMonoid EitherTag where+  memptyExpr = litExpr mempty+++isLeft :: Expr EitherTag -> Expr Bool+isLeft = (litExpr IsLeft ==.)+++isRight :: Expr EitherTag -> Expr Bool+isRight = (litExpr IsRight ==.)+++type MaybeTag :: Type+data MaybeTag = IsJust+  deriving stock (Eq, Ord, Read, Show, Enum, Bounded)+  deriving (Semigroup, Monoid) via (Min MaybeTag)+  deriving anyclass (DBEq, DBOrd)+++instance DBType MaybeTag where+  typeInformation = parseTypeInformation to from typeInformation+    where+      to False = Left "MaybeTag can't be false"+      to True = Right IsJust+      from _ = True+++instance DBSemigroup MaybeTag where+  (<>.) = zipPrimExprsWith (Opaleye.BinExpr Opaleye.OpAnd)+++instance DBMonoid MaybeTag where+  memptyExpr = litExpr mempty+++newtype Tag = Tag Text+  deriving newtype+    ( Eq, Ord, Read, Show+    , DBType, DBEq, DBOrd+    )
+ tests/Main.hs view
@@ -0,0 +1,730 @@+{-# language BlockArguments #-}+{-# language DataKinds #-}+{-# language DeriveAnyClass #-}+{-# language DeriveGeneric #-}+{-# language DerivingStrategies #-}+{-# language DisambiguateRecordFields #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language GADTs #-}+{-# language NamedFieldPuns #-}+{-# language OverloadedStrings #-}+{-# language RecordWildCards #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneDeriving #-}+{-# language TypeApplications #-}++{-# options_ghc -fno-warn-redundant-constraints #-}++module Main+  ( main+  )+where++-- base+import Control.Applicative ( liftA2, liftA3 )+import Control.Monad (void)+import Control.Monad.IO.Class ( MonadIO, liftIO )+import Data.Bifunctor ( bimap )+import Data.Foldable ( for_ )+import Data.Int ( Int32, Int64 )+import Data.List ( nub, sort )+import Data.Maybe ( catMaybes )+import Data.String ( fromString )+import Data.Word (Word32)+import GHC.Generics ( Generic )++-- bytestring+import qualified Data.ByteString.Lazy++-- case-insensitive+import Data.CaseInsensitive (mk)++-- containers+import qualified Data.Map.Strict as Map++-- hasql+import Hasql.Connection ( Connection,  acquire, release )+import Hasql.Session ( sql, run )++-- hedgehog+import Hedgehog ( property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen )+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++-- lifted-base+import Control.Exception.Lifted ( bracket, throwIO, bracket_ )++-- monad-control+import Control.Monad.Trans.Control ( MonadBaseControl )++-- rel8+import Rel8 ( Result )+import qualified Rel8++-- scientific+import Data.Scientific ( Scientific )++-- tasty+import Test.Tasty++-- tasty-hedgehog+import Test.Tasty.Hedgehog ( testProperty )++-- text+import Data.Text (Text, pack)+import qualified Data.Text.Lazy++-- time+import Data.Time++-- tmp-postgres+import qualified Database.Postgres.Temp as TmpPostgres++-- uuid+import qualified Data.UUID+++main :: IO ()+main = defaultMain tests+++tests :: TestTree+tests =+  withResource startTestDatabase stopTestDatabase \getTestDatabase ->+  testGroup "rel8"+    [ testSelectTestTable getTestDatabase+    , testWhere_ getTestDatabase+    , testFilter getTestDatabase+    , testLimit getTestDatabase+    , testUnion getTestDatabase+    , testDistinct getTestDatabase+    , testExists getTestDatabase+    , testOptional getTestDatabase+    , testAnd getTestDatabase+    , testOr getTestDatabase+    , testNot getTestDatabase+    , testBool getTestDatabase+    , testAp getTestDatabase+    , testDBType getTestDatabase+    , testDBEq getTestDatabase+    , testTableEquality getTestDatabase+    , testFromString getTestDatabase+    , testCatMaybeTable getTestDatabase+    , testCatMaybe getTestDatabase+    , testMaybeTable getTestDatabase+    , testNestedTables getTestDatabase+    , testMaybeTableApplicative getTestDatabase+    , testLogicalFixities getTestDatabase+    , testUpdate getTestDatabase+    , testDelete getTestDatabase+    , testSelectNestedPairs getTestDatabase+    , testSelectArray getTestDatabase+    , testNestedMaybeTable getTestDatabase+    ]++  where++    startTestDatabase = do+      db <- TmpPostgres.start >>= either throwIO return++      bracket (either (error . show) return =<< acquire (TmpPostgres.toConnectionString db)) release \conn -> void do+        flip run conn do+          sql "CREATE EXTENSION citext"+          sql "CREATE TABLE test_table ( column1 text not null, column2 bool not null )"++      return db++    stopTestDatabase = TmpPostgres.stop+++databasePropertyTest+  :: TestName+  -> (((Connection -> TestT IO ()) -> PropertyT IO ()) -> PropertyT IO ())+  -> IO TmpPostgres.DB -> TestTree+databasePropertyTest testName f getTestDatabase =+  withResource connect release $ \c ->+  testProperty testName $ property do+    connection <- liftIO c+    f \g -> test $ rollingBack connection $ g connection++  where++    connect = either (error . show) return =<< acquire . TmpPostgres.toConnectionString =<< getTestDatabase+++data TestTable f = TestTable+  { testTableColumn1 :: Rel8.Column f Text+  , testTableColumn2 :: Rel8.Column f Bool+  }+  deriving stock Generic+  deriving anyclass Rel8.Rel8able+++deriving stock instance Eq (TestTable Result)+deriving stock instance Ord (TestTable Result)+deriving stock instance Show (TestTable Result)+++testTableSchema :: Rel8.TableSchema (TestTable Rel8.Name)+testTableSchema =+  Rel8.TableSchema+    { name = "test_table"+    , schema = Nothing+    , columns = TestTable+        { testTableColumn1 = "column1"+        , testTableColumn2 = "column2"+        }+    }+++testSelectTestTable :: IO TmpPostgres.DB -> TestTree+testSelectTestTable = databasePropertyTest "Can SELECT TestTable" \transaction -> do+  rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable++  transaction \connection -> do+    void do+      liftIO $ Rel8.insert connection+        Rel8.Insert+          { into = testTableSchema+          , rows = map Rel8.lit rows+          , onConflict = Rel8.DoNothing+          , returning = Rel8.NumberOfRowsAffected+          }++    selected <- liftIO $ Rel8.select connection do+      Rel8.each testTableSchema++    sort selected === sort rows++    cover 1 "Empty" $ null rows+    cover 1 "Singleton" $ null $ drop 1 rows+    cover 1 ">1 row" $ not $ null $ drop 1 rows+++testWhere_ :: IO TmpPostgres.DB -> TestTree+testWhere_ = databasePropertyTest "WHERE (Rel8.where_)" \transaction -> do+  rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable++  magicBool <- forAll Gen.bool++  let expected = filter (\t -> testTableColumn2 t == magicBool) rows++  transaction \connection -> do+    selected <- liftIO $ Rel8.select connection do+      t <- Rel8.values $ Rel8.lit <$> rows+      Rel8.where_ $ testTableColumn2 t Rel8.==. Rel8.lit magicBool+      return t++    sort selected === sort expected++    cover 1 "No results" $ null expected+    cover 1 "Some results" $ not $ null expected+    cover 1 "All results" $ expected == rows+++testFilter :: IO TmpPostgres.DB -> TestTree+testFilter = databasePropertyTest "filter" \transaction -> do+  rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable++  transaction \connection -> do+    let expected = filter testTableColumn2 rows++    selected <- liftIO $ Rel8.select connection+      $ Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows)++    sort selected === sort expected++    cover 1 "No results" $ null expected+    cover 1 "Some results" $ not $ null expected+    cover 1 "All results" $ expected == rows+++testLimit :: IO TmpPostgres.DB -> TestTree+testLimit = databasePropertyTest "LIMIT (Rel8.limit)" \transaction -> do+  rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable++  n <- forAll $ Gen.integral (Range.linear 0 10)++  transaction \connection -> do+    selected <- liftIO $ Rel8.select connection do+      Rel8.limit n $ Rel8.values (Rel8.lit <$> rows)++    diff (length selected) (<=) (fromIntegral n)++    for_ selected \row ->+      diff row elem rows++    cover 1 "n == 0" $ n == 0+    cover 1 "n < length rows" $ fromIntegral n < length rows+    cover 1 "n == length rows" $ fromIntegral n == length rows+    cover 1 "n >= length rows" $ fromIntegral n >= length rows+++testUnion :: IO TmpPostgres.DB -> TestTree+testUnion = databasePropertyTest "UNION (Rel8.union)" \transaction -> evalM do+  left <- forAll $ Gen.list (Range.linear 0 10) genTestTable+  right <- forAll $ Gen.list (Range.linear 0 10) genTestTable++  transaction \connection -> do+    selected <- liftIO $ Rel8.select connection do+      Rel8.values (Rel8.lit <$> nub left) `Rel8.union` Rel8.values (Rel8.lit <$> nub right)++    sort selected === sort (nub (left ++ right))+++testDistinct :: IO TmpPostgres.DB -> TestTree+testDistinct = databasePropertyTest "DISTINCT (Rel8.distinct)" \transaction -> do+  rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable++  transaction \connection -> do+    selected <- liftIO $ Rel8.select connection $ Rel8.distinct do+      Rel8.values (Rel8.lit <$> rows)++    sort selected === nub (sort rows)++    cover 1 "Empty" $ null rows+    cover 1 "Duplicates" $ not (null rows) && rows /= nub rows+    cover 1 "No duplicates" $ not (null rows) && rows == nub rows+++testExists :: IO TmpPostgres.DB -> TestTree+testExists = databasePropertyTest "EXISTS (Rel8.exists)" \transaction -> do+  rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable++  transaction \connection -> do+    exists <- liftIO $ Rel8.select connection $ Rel8.exists $ Rel8.values $ Rel8.lit <$> rows++    case rows of+      [] -> exists === [False]+      _ -> exists === [True]+++testOptional :: IO TmpPostgres.DB -> TestTree+testOptional = databasePropertyTest "Rel8.optional" \transaction -> do+  rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable++  transaction \connection -> do+    selected <- liftIO $ Rel8.select connection do+      Rel8.optional $ Rel8.values (Rel8.lit <$> rows)++    case rows of+      [] -> selected === [Nothing]+      _  -> sort selected === fmap Just (sort rows)+++testAnd :: IO TmpPostgres.DB -> TestTree+testAnd = databasePropertyTest "AND (&&.)" \transaction -> do+  (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool++  transaction \connection -> do+    [result] <- liftIO $ Rel8.select connection $ pure $+      Rel8.lit x Rel8.&&. Rel8.lit y++    result === (x && y)+++testOr :: IO TmpPostgres.DB -> TestTree+testOr = databasePropertyTest "OR (||.)" \transaction -> do+  (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool++  transaction \connection -> do+    [result] <- liftIO $ Rel8.select connection $ pure $+      Rel8.lit x Rel8.||. Rel8.lit y++    result === (x || y)+++testLogicalFixities :: IO TmpPostgres.DB -> TestTree+testLogicalFixities = databasePropertyTest "Logical operator fixities" \transaction -> do+  (u, v, w, x) <- forAll $ (,,,) <$> Gen.bool <*> Gen.bool <*> Gen.bool <*> Gen.bool++  transaction \connection -> do+    [result] <- liftIO $ Rel8.select connection $ pure $+      Rel8.lit u Rel8.||. Rel8.lit v Rel8.&&. Rel8.lit w Rel8.==. Rel8.lit x++    result === (u || v && w == x)+++testNot :: IO TmpPostgres.DB -> TestTree+testNot = databasePropertyTest "NOT (not_)" \transaction -> do+  x <- forAll Gen.bool++  transaction \connection -> do+    [result] <- liftIO $ Rel8.select connection $ pure $+      Rel8.not_ $ Rel8.lit x++    result === not x+++testBool :: IO TmpPostgres.DB -> TestTree+testBool = databasePropertyTest "ifThenElse_" \transaction -> do+  (x, y, z) <- forAll $ liftA3 (,,) Gen.bool Gen.bool Gen.bool++  transaction \connection -> do+    [result] <- liftIO $ Rel8.select connection $ pure $+      Rel8.bool (Rel8.lit z) (Rel8.lit y) (Rel8.lit x)++    result === if x then y else z+++testAp :: IO TmpPostgres.DB -> TestTree+testAp = databasePropertyTest "Cartesian product (<*>)" \transaction -> do+  (rows1, rows2) <- forAll $+    liftA2 (,)+      (Gen.list (Range.linear 1 10) genTestTable)+      (Gen.list (Range.linear 1 10) genTestTable)++  transaction \connection -> do+    result <- liftIO $ Rel8.select connection $ do+      liftA2 (,) (Rel8.values (Rel8.lit <$> rows1)) (Rel8.values (Rel8.lit <$> rows2))++    sort result === sort (liftA2 (,) rows1 rows2)+++testDBType :: IO TmpPostgres.DB -> TestTree+testDBType getTestDatabase = testGroup "DBType instances"+  [ dbTypeTest "Bool" Gen.bool+  , dbTypeTest "ByteString" $ Gen.bytes (Range.linear 0 128)+  , dbTypeTest "CI Lazy Text" $ mk . Data.Text.Lazy.fromStrict <$> Gen.text (Range.linear 0 10) Gen.unicode+  , dbTypeTest "CI Text" $ mk <$> Gen.text (Range.linear 0 10) Gen.unicode+  , dbTypeTest "Day" genDay+  , dbTypeTest "Double" $ (/10) . fromIntegral @Int @Double <$> Gen.integral (Range.linear (-100) 100)+  , dbTypeTest "Float" $ (/10) . fromIntegral @Int @Float <$> Gen.integral (Range.linear (-100) 100)+  , dbTypeTest "Int32" $ Gen.integral @_ @Int32 Range.linearBounded+  , dbTypeTest "Int64" $ Gen.integral @_ @Int64 Range.linearBounded+  , dbTypeTest "Lazy ByteString" $ Data.ByteString.Lazy.fromStrict <$> Gen.bytes (Range.linear 0 128)+  , dbTypeTest "Lazy Text" $ Data.Text.Lazy.fromStrict <$> Gen.text (Range.linear 0 10) Gen.unicode+  , dbTypeTest "LocalTime" genLocalTime+  , dbTypeTest "Scientific" $ (/10) . fromIntegral @Int @Scientific <$> Gen.integral (Range.linear (-100) 100)+  , dbTypeTest "Text" $ Gen.text (Range.linear 0 10) Gen.unicode+  , dbTypeTest "TimeOfDay" genTimeOfDay+  , dbTypeTest "UTCTime" $ UTCTime <$> genDay <*> genDiffTime+  , dbTypeTest "UUID" $ Data.UUID.fromWords <$> genWord32 <*> genWord32 <*> genWord32 <*> genWord32+  ]++  where+    dbTypeTest :: (Eq a, Show a, Rel8.DBType a) => TestName -> Gen a -> TestTree+    dbTypeTest name generator = testGroup name+      [ databasePropertyTest name (t (==) generator) getTestDatabase+      , databasePropertyTest ("Maybe " <> name) (t (==) (Gen.maybe generator)) getTestDatabase+      ]++    t :: forall a b. (Show a, Rel8.Sql Rel8.DBType a)+      => (a -> a -> Bool)+      -> Gen a+      -> ((Connection -> TestT IO ()) -> PropertyT IO b)+      -> PropertyT IO b+    t eq generator transaction = do+      x <- forAll generator++      transaction \connection -> do+        [res] <- liftIO $ Rel8.select connection $ pure (Rel8.litExpr x)+        diff res eq x++    genDay :: Gen Day+    genDay = do+      year <- Gen.integral (Range.linear 1970 3000)+      month <- Gen.integral (Range.linear 1 12)+      day <- Gen.integral (Range.linear 1 31)+      Gen.just $ pure $ fromGregorianValid year month day++    genDiffTime :: Gen DiffTime+    genDiffTime = secondsToDiffTime <$> Gen.integral (Range.linear 0 86401)++    genTimeOfDay :: Gen TimeOfDay+    genTimeOfDay = do+      hour <- Gen.integral (Range.linear 0 23)+      minute <- Gen.integral (Range.linear 0 59)+      sec <- fromIntegral @Int <$> Gen.integral (Range.linear 0 59)+      Gen.just $ pure $ makeTimeOfDayValid hour minute sec++    genLocalTime = LocalTime <$> genDay <*> genTimeOfDay++    genWord32 :: Gen Word32+    genWord32 = Gen.integral Range.linearBounded+++testDBEq :: IO TmpPostgres.DB -> TestTree+testDBEq getTestDatabase = testGroup "DBEq instances"+  [ dbEqTest "Bool" Gen.bool+  , dbEqTest "Int32" $ Gen.integral @_ @Int32 Range.linearBounded+  , dbEqTest "Int64" $ Gen.integral @_ @Int64 Range.linearBounded+  , dbEqTest "Text" $ Gen.text (Range.linear 0 10) Gen.unicode+  ]++  where+    dbEqTest :: (Eq a, Show a, Rel8.DBEq a) => TestName -> Gen a -> TestTree+    dbEqTest name generator = testGroup name+      [ databasePropertyTest name (t generator) getTestDatabase+      , databasePropertyTest ("Maybe " <> name) (t (Gen.maybe generator)) getTestDatabase+      ]++    t :: forall a. (Eq a, Show a, Rel8.Sql Rel8.DBEq a)+      => Gen a+      -> ((Connection -> TestT IO ()) -> PropertyT IO ())+      -> PropertyT IO ()+    t generator transaction = do+      (x, y) <- forAll (liftA2 (,) generator generator)++      transaction \connection -> do+        [res] <- liftIO $ Rel8.select connection $ pure $ Rel8.litExpr x Rel8.==. Rel8.litExpr y+        res === (x == y)++        cover 1 "Equal" $ x == y+        cover 1 "Not Equal" $ x /= y+++testTableEquality :: IO TmpPostgres.DB -> TestTree+testTableEquality = databasePropertyTest "TestTable equality" \transaction -> do+   (x, y) <- forAll $ liftA2 (,) genTestTable genTestTable++   transaction \connection -> do+     [eq] <- liftIO $ Rel8.select connection do+       pure $ Rel8.lit x Rel8.==: Rel8.lit y++     eq === (x == y)++     cover 1 "Equal" $ x == y+     cover 1 "Not Equal" $ x /= y+++testFromString :: IO TmpPostgres.DB -> TestTree+testFromString = databasePropertyTest "FromString" \transaction -> do+  str <- forAll $ Gen.list (Range.linear 0 10) Gen.unicode++  transaction \connection -> do+    [result] <- liftIO $ Rel8.select connection $ pure $ fromString str+    result === pack str+++testCatMaybeTable :: IO TmpPostgres.DB -> TestTree+testCatMaybeTable = databasePropertyTest "catMaybeTable" \transaction -> do+  rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable++  transaction \connection -> do+    selected <- liftIO $ Rel8.select connection do+      testTable <- Rel8.values $ Rel8.lit <$> rows+      Rel8.catMaybeTable $ Rel8.bool Rel8.nothingTable (pure testTable) (testTableColumn2 testTable)++    sort selected === sort (filter testTableColumn2 rows)+++testCatMaybe :: IO TmpPostgres.DB -> TestTree+testCatMaybe = databasePropertyTest "catMaybe" \transaction -> evalM do+  rows <- forAll $ Gen.list (Range.linear 0 10) $ Gen.maybe Gen.bool++  transaction \connection -> do+    selected <- evalM $ liftIO $ Rel8.select connection do+      Rel8.catNull =<< Rel8.values (map Rel8.lit rows)++    sort selected === sort (catMaybes rows)+++testMaybeTable :: IO TmpPostgres.DB -> TestTree+testMaybeTable = databasePropertyTest "maybeTable" \transaction -> evalM do+  (rows, def) <- forAll $ liftA2 (,) (Gen.list (Range.linear 0 10) genTestTable) genTestTable++  transaction \connection -> do+    selected <- liftIO $ Rel8.select connection $+      Rel8.maybeTable (Rel8.lit def) id <$> Rel8.optional (Rel8.values (Rel8.lit <$> rows))++    case rows of+      [] -> selected === [def]+      _ -> sort selected === sort rows+++data TwoTestTables f =+  TwoTestTables+    { testTable1 :: TestTable f+    , testTable2 :: TestTable f+    }+  deriving stock Generic+  deriving anyclass Rel8.Rel8able+++deriving stock instance Eq (TwoTestTables Result)+deriving stock instance Ord (TwoTestTables Result)+deriving stock instance Show (TwoTestTables Result)+++testNestedTables :: IO TmpPostgres.DB -> TestTree+testNestedTables = databasePropertyTest "Nested TestTables" \transaction -> evalM do+  rows <- forAll do+    Gen.list (Range.linear 0 10) $+      liftA2 TwoTestTables genTestTable genTestTable++  transaction \connection -> do+    selected <- liftIO $ Rel8.select connection do+      Rel8.values (Rel8.lit <$> rows)++    sort selected === sort rows+++testMaybeTableApplicative :: IO TmpPostgres.DB -> TestTree+testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction -> evalM do+  rows1 <- genRows+  rows2 <- genRows++  transaction \connection -> do+    selected <- liftIO $ Rel8.select connection do+      as <- Rel8.optional (Rel8.values (Rel8.lit <$> rows1))+      bs <- Rel8.optional (Rel8.values (Rel8.lit <$> rows2))+      pure $ liftA2 (,) as bs++    case (rows1, rows2) of+      ([], []) -> selected === [Nothing]+      ([], bs) -> selected === (Nothing <$ bs)+      (as, []) -> selected === (Nothing <$ as)+      (as, bs) -> sort selected === sort (Just <$> liftA2 (,) as bs)+  where+    genRows :: PropertyT IO [TestTable Result]+    genRows = forAll do+      Gen.list (Range.linear 0 10) $ liftA2 TestTable (Gen.text (Range.linear 0 10) Gen.unicode) (pure True)++rollingBack+  :: (MonadBaseControl IO m, MonadIO m)+  => Connection -> m a -> m a+rollingBack connection =+  bracket_+    (liftIO (run (sql "BEGIN") connection))+    (liftIO (run (sql "ROLLBACK") connection))+++genTestTable :: Gen (TestTable Result)+genTestTable = do+  testTableColumn1 <- Gen.text (Range.linear 0 5) Gen.alphaNum+  testTableColumn2 <- Gen.bool+  return TestTable{..}+++testUpdate :: IO TmpPostgres.DB -> TestTree+testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do+  rows <- forAll $ Gen.map (Range.linear 0 5) $ liftA2 (,) genTestTable genTestTable++  transaction \connection -> do+    void $ liftIO $ Rel8.insert connection+      Rel8.Insert+        { into = testTableSchema+        , rows = map Rel8.lit $ Map.keys rows+        , onConflict = Rel8.DoNothing+        , returning = Rel8.NumberOfRowsAffected+        }++    void $ liftIO $ Rel8.update connection+      Rel8.Update+        { target = testTableSchema+        , set = \r ->+            let updates = map (bimap Rel8.lit Rel8.lit) $ Map.toList rows+            in+            foldl+              ( \e (x, y) ->+                  Rel8.bool+                    e+                    y+                    ( testTableColumn1 r Rel8.==. testTableColumn1 x Rel8.&&.+                      testTableColumn2 r Rel8.==. testTableColumn2 x+                    )+              )+              r+              updates+        , updateWhere = \_ -> Rel8.lit True+        , returning = Rel8.NumberOfRowsAffected+        }++    selected <- liftIO $ Rel8.select connection do+      Rel8.each testTableSchema++    sort selected === sort (Map.elems rows)++    cover 1 "Empty" $ null rows+    cover 1 "Singleton" $ null $ drop 1 $ Map.keys rows+    cover 1 ">1 row" $ not $ null $ drop 1 $ Map.keys rows+++testDelete :: IO TmpPostgres.DB -> TestTree+testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do+  rows <- forAll $ Gen.list (Range.linear 0 5) genTestTable++  transaction \connection -> do+    void $ liftIO $ Rel8.insert connection+      Rel8.Insert+        { into = testTableSchema+        , rows = map Rel8.lit rows+        , onConflict = Rel8.DoNothing+        , returning = Rel8.NumberOfRowsAffected+        }++    deleted <-+      liftIO $ Rel8.delete connection+        Rel8.Delete+          { from = testTableSchema+          , deleteWhere = testTableColumn2+          , returning = Rel8.Projection id+          }++    selected <- liftIO $ Rel8.select connection do+      Rel8.each testTableSchema++    sort (deleted <> selected) === sort rows+++newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) }+  deriving stock Generic+  deriving anyclass Rel8.Rel8able++deriving stock instance Eq (HKNestedPair Result)+deriving stock instance Ord (HKNestedPair Result)+deriving stock instance Show (HKNestedPair Result)+++testSelectNestedPairs :: IO TmpPostgres.DB -> TestTree+testSelectNestedPairs = databasePropertyTest "Can SELECT nested pairs" \transaction -> do+  rows <- forAll $ Gen.list (Range.linear 0 10) $ HKNestedPair <$> liftA2 (,) genTestTable genTestTable++  transaction \connection -> do+    selected <- liftIO $ Rel8.select connection do+      Rel8.values $ map Rel8.lit rows++    sort selected === sort rows+++testSelectArray :: IO TmpPostgres.DB -> TestTree+testSelectArray = databasePropertyTest "Can SELECT Arrays (with aggregation)" \transaction -> do+  rows <- forAll $ Gen.list (Range.linear 1 10) Gen.bool++  transaction \connection -> do+    selected <- liftIO $ Rel8.select connection do+      Rel8.many $ Rel8.values (map Rel8.lit rows)++    selected === [foldMap pure rows]++    selected' <- liftIO $ Rel8.select connection $ Rel8.catListTable =<< do+      Rel8.many $ Rel8.values (map Rel8.lit rows)++    selected' === rows+++data NestedMaybeTable f = NestedMaybeTable+  { nmt1 :: Rel8.Column f Bool+  , nmt2 :: Rel8.HMaybe f (TestTable f)+  }+  deriving stock Generic+  deriving anyclass Rel8.Rel8able+++deriving stock instance Eq (NestedMaybeTable Result)+deriving stock instance Ord (NestedMaybeTable Result)+deriving stock instance Show (NestedMaybeTable Result)+++testNestedMaybeTable :: IO TmpPostgres.DB -> TestTree+testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other tables" \transaction -> do+  let example = NestedMaybeTable { nmt1 = True, nmt2 = Just (TestTable "Hi" True) }++  transaction \connection -> do+    selected <- liftIO $ Rel8.select connection do+      x <- Rel8.values [Rel8.lit example]+      pure $ Rel8.maybeTable (Rel8.lit False) (\_ -> Rel8.lit True) (nmt2 x)++    selected === [True]