rel8 1.3.1.0 → 1.4.0.0

raw patch · 17 files changed

+616/−68 lines, 17 filesdep ~hasqldep ~opaleyePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: hasql, opaleye

API changes (from Hackage documentation)

Files

• Changelog.md +23/−0
• rel8.cabal +5/−3
• src/Rel8.hs +236/−3
• src/Rel8/Aggregate.hs-boot +11/−0
• src/Rel8/Column/Null.hs +26/−0
• src/Rel8/Expr/Opaleye.hs +10/−1
• src/Rel8/Query/Null.hs +15/−0
• src/Rel8/Schema/HTable.hs +23/−2
• src/Rel8/Schema/Name.hs-boot +11/−0
• src/Rel8/Table/Aggregate.hs +12/−0
• src/Rel8/Table/Maybe.hs +6/−0
• src/Rel8/Table/Null.hs +147/−0
• src/Rel8/Table/Nullify.hs +27/−0
• src/Rel8/Table/Opaleye.hs +28/−45
• src/Rel8/Table/Ord.hs +2/−2
• src/Rel8/Table/These.hs +14/−3
• src/Rel8/Tabulate.hs +20/−9

@@ -1,3 +1,26 @@+# 1.4.0.0 (2002-08-17)++## Breaking changes++* The behavior of `greatest`/`least` has been corrected, and was previously flipped. ([#183](https://github.com/circuithub/rel8/pull/183))++## New features++* `NullTable`/`HNull` have been added. This is an alternative to `MaybeTable` that doesn't use a tag columns. It's less flexible (no `Functor` or `Applicative` instance) and is meaningless when used with a table that has no non-nullable columns (so nesting `NullTable` is redundant). But in situations where the underlying `Table` does have non-nullable columns, it can losslessly converted to and from `MaybeTable`. It is useful for embedding into a base table when you don't want to store the extra tag column in your schema. ([#173](https://github.com/circuithub/rel8/pull/173))+* Add `fromMaybeTable`. ([#179](https://github.com/circuithub/rel8/pull/179))+* Add `alignMaybeTable`. ([#196](https://github.com/circuithub/rel8/pull/196))++## Improvements++* Optimize implementation of `AltTable` for `Tabulation` ([#178](https://github.com/circuithub/rel8/pull/178))++## Other+ +* Documentation improvements for `HADT`. ([#177](https://github.com/circuithub/rel8/pull/177))+* Document example usage of `groupBy`. ([#184](https://github.com/circuithub/rel8/pull/184))+* Build with and require Opaleye >= 0.9.3.3. ([#190](https://github.com/circuithub/rel8/pull/190))+* Build with `hasql` 1.6. ([#195](https://github.com/circuithub/rel8/pull/195))+ # 1.3.1.0 (2022-01-20)  ## Other

@@ -1,6 +1,6 @@ cabal-version:       2.0 name:                rel8-version:             1.3.1.0+version:             1.4.0.0 synopsis:            Hey! Hey! Can u rel8? license:             BSD3 license-file:        LICENSE@@ -26,8 +26,8 @@     , case-insensitive     , comonad     , contravariant-    , hasql ^>= 1.4.5.1 || ^>= 1.5.0.0-    , opaleye ^>= 0.9.1.0+    , hasql ^>= 1.4.5.1 || ^>= 1.5.0.0 || ^>= 1.6.0.0+    , opaleye ^>= 0.9.3.3     , pretty     , profunctors     , product-profunctors@@ -66,6 +66,7 @@     Rel8.Column.List     Rel8.Column.Maybe     Rel8.Column.NonEmpty+    Rel8.Column.Null     Rel8.Column.These      Rel8.Expr@@ -167,6 +168,7 @@     Rel8.Table.Maybe     Rel8.Table.Name     Rel8.Table.NonEmpty+    Rel8.Table.Null     Rel8.Table.Nullify     Rel8.Table.Opaleye     Rel8.Table.Ord

@@ -38,6 +38,7 @@   , HMaybe   , HList   , HNonEmpty+  , HNull   , HThese   , Lift @@ -57,6 +58,7 @@   , MaybeTable   , maybeTable, ($?), nothingTable, justTable   , isNothingTable, isJustTable+  , fromMaybeTable   , optional   , catMaybeTable   , traverseMaybeTable@@ -79,6 +81,7 @@   , isThisTable, isThatTable, isThoseTable   , hasHereTable, hasThereTable   , justHereTable, justThereTable+  , alignMaybeTable   , alignBy   , keepHereTable, loseHereTable   , keepThereTable, loseThereTable@@ -107,14 +110,37 @@   , catNonEmptyTable   , catNonEmpty -    -- ** @ADT@+    -- ** @NullTable@+  , NullTable+  , nullableTable, nullTable, nullifyTable+  , isNullTable, isNonNullTable+  , catNullTable+  , nameNullTable+  , toNullTable, toMaybeTable++    -- ** Algebraic data types / sum types+    -- $adts++    -- *** Naming of ADTs+    -- $naming+  , NameADT, nameADT   , ADT, ADTable++    -- *** Deconstruction of ADTs+    -- $deconstruction+  , DeconstructADT, deconstructADT++    -- *** Construction of ADTs+    -- $construction   , BuildADT, buildADT   , ConstructADT, constructADT-  , DeconstructADT, deconstructADT-  , NameADT, nameADT++    -- *** Other ADT operations   , AggregateADT, aggregateADT +    -- *** Miscellaneous notes+    -- $misc-notes+     -- ** @HKD@   , HKD, HKDable   , BuildHKD, buildHKD@@ -306,6 +332,7 @@ import Rel8.Column.List import Rel8.Column.Maybe import Rel8.Column.NonEmpty+import Rel8.Column.Null import Rel8.Column.These import Rel8.Expr import Rel8.Expr.Aggregate@@ -367,6 +394,7 @@ import Rel8.Table.Maybe import Rel8.Table.Name import Rel8.Table.NonEmpty+import Rel8.Table.Null import Rel8.Table.Opaleye ( castTable ) import Rel8.Table.Ord import Rel8.Table.Order@@ -396,3 +424,208 @@ -- provides 'select', 'insert', 'update' and 'delete' functions. Note that -- 'insert', 'update' and 'delete' will generally need the -- `DuplicateRecordFields` language extension enabled.++-- $adts+-- Algebraic data types can be modelled between Haskell and SQL.+--+-- * Your SQL table needs a certain text field that tags which Haskell constructor is in use.+-- * You have to use a few combinators to specify the sum type's individual constructors.+-- * If you want to do case analysis at the @Expr@ (SQL) level, you can use 'maybe'/'either'-like eliminators.+--+-- The documentation in this section will assume a set of database types like this:+--+-- @+-- data Thing f = ThingEmployer (Employer f) | ThingPotato (Potato f) | Nullary+--     deriving stock Generic+--+-- data Employer f = Employer { employerId :: f Int32, employerName :: f Text}+--   deriving stock Generic+--   deriving anyclass Rel8able+--+-- data Potato f = Potato { size :: f Int32, grower :: f Text }+--   deriving stock Generic+--   deriving anyclass Rel8able+-- @++-- $naming+--+-- First, in your 'TableSchema', name your type like this:+--+-- @+-- thingSchema :: TableSchema (ADT Thing Name)+-- thingSchema =+--   TableSchema+--     { schema = Nothing,+--       name = \"thing\",+--       columns =+--         nameADT @Thing+--           \"tag\"+--           Employer+--             { employerName = \"name\",+--               employerId = \"id\"+--             }+--           Potato {size = \"size\", grower = \"Mary\"}+--     }+-- @+--+-- Note that @nameADT \@Thing "tag"@ is variadic: it accepts one+-- argument per constructor, except the nullary ones (Nullary) because+-- there's nothing to do for them.++-- $deconstruction+--+-- To deconstruct sum types at the SQL level, use 'deconstructADT',+-- which is also variadic, and has one argument for each+-- constructor. Similar to 'maybe'.+--+-- @+-- query :: Query (ADT Thing Expr)+-- query = do+--   thingExpr <- each thingSchema+--   where_ $+--     deconstructADT @Thing+--       (\employer -> employerName employer ==. lit \"Mary\")+--       (\potato -> grower potato ==. lit \"Mary\")+--       (lit False) -- Nullary case+--       thingExpr+--   pure thingExpr+-- @+--+-- SQL output:+--+-- @+-- SELECT+-- CAST("tag0_1" AS text) as "tag",+-- CAST("id1_1" AS int4) as "ThingEmployer/_1/employerId",+-- CAST("name2_1" AS text) as "ThingEmployer/_1/employerName",+-- CAST("size3_1" AS int4) as "ThingPotato/_1/size",+-- CAST("Mary4_1" AS text) as "ThingPotato/_1/grower"+-- FROM (SELECT+--       *+--       FROM (SELECT+--             "tag" as "tag0_1",+--             "id" as "id1_1",+--             "name" as "name2_1",+--             "size" as "size3_1",+--             "Mary" as "Mary4_1"+--             FROM "thing" as "T1") as "T1"+--       WHERE (CASE WHEN ("tag0_1") = (CAST(E'ThingPotato' AS text)) THEN ("Mary4_1") = (CAST(E'Mary' AS text))+--                   WHEN ("tag0_1") = (CAST(E'Nullary' AS text)) THEN CAST(FALSE AS bool) ELSE ("name2_1") = (CAST(E'Mary' AS text)) END)) as "T1"+-- @++-- $construction+--+-- To construct an ADT, you can use 'buildADT' or 'constructADT'. Consider the following type:+--+-- @+-- data Task f = Pending | Complete (CompletedTask f)+-- @+--+-- 'buildADT' is for constructing values of 'Task' in the 'Expr'+-- context. 'buildADT' needs two type-level arguments before its type+-- makes any sense. The first argument is the type of the "ADT", which+-- in our case is 'Task'. The second is the name of the constructor we+-- want to use. So that means we have the following possible+-- instantiations of 'buildADT' for 'Task':+--+-- @+-- > :t buildADT @Task @\"Pending\"+-- buildADT @Task @\"Pending\" :: ADT Task Expr+-- > :t buildADT @Task @\"Complete\"+-- buildADT @Task @\"Complete\" :: CompletedTask Expr -> ADT Task Expr+-- @+--+-- Note that as the "Pending" constructor has no fields, @buildADT+-- \@Task \@"Pending"@ is equivalent to @lit Pending@. But @buildADT+-- \@Task \@"Complete"@ is not the same as @lit . Complete@:+--+-- @+-- > :t lit . Complete+-- lit . Complete :: CompletedTask Result -> ADT Task Expr+-- @+--+--+-- Note that the former takes a @CompletedTask Expr@ while the latter+-- takes a @CompletedTask Result@. The former is more powerful because+-- you can construct @Task@s using dynamic values coming a database+-- query.+--+-- To show what this can look like in SQL, consider:+--+-- @+-- > :{+-- showQuery $ values+--   [ buildADT @Task @\"Pending\"+--   , buildADT @Task @\"Complete\" CompletedTask {date = Rel8.Expr.Time.now}+--   ]+-- :}+-- @+--+-- This produces the following SQL:+--+-- @+-- SELECT+-- CAST(\"values0_1\" AS text) as \"tag\",+-- CAST(\"values1_1\" AS timestamptz) as \"Complete/_1/date\"+-- FROM (SELECT+--       *+--       FROM (SELECT \"column1\" as \"values0_1\",+--                    \"column2\" as \"values1_1\"+--             FROM+--             (VALUES+--              (CAST(E'Pending' AS text),CAST(NULL AS timestamptz)),+--              (CAST(E'Complete' AS text),CAST(now() AS timestamptz))) as \"V\") as \"T1\") as \"T1\"+-- @+--+-- This is what you get if you run it in @psql@:+--+--+-- @+--    tag    |       Complete/_1/date+-- ----------+-------------------------------+--  Pending  |+--  Complete | 2022-05-19 21:28:23.969065+00+-- (2 rows)+-- @+--+-- "constructADT" is less convenient but more general alternative to+-- "buildADT". It requires only one type-level argument for its type+-- to make sense:+--+-- @+-- > :t constructADT @Task+-- constructADT @Task+--   :: (forall r. r -> (CompletedTask Expr -> r) -> r) -> ADT Task Expr+-- @+--+-- This might still seem a bit opaque, but basically it gives you a+-- Church-encoded constructor for arbitrary algebraic data types. You+-- might use it as follows:+--+-- @+-- let+--   pending :: ADT Task Expr+--   pending = constructADT @Task $ \pending _complete -> pending+--+--   complete :: ADT Task Expr+--   complete = constructADT @Task $ \_pending complete -> complete CompletedTask {date = Rel8.Expr.Time.now}+-- @+--+-- These values are otherwise identical to the ones we saw above with+-- @buildADT@, it's just a different style of constructing them.+--++-- $misc-notes+--+-- 1. Note that the order of the arguments for all of these functions+-- is determined by the order of the constructors in the data+-- definition. If it were @data Task = Complete (CompletedTask f) |+-- Pending@ then the order of all the invocations of @constructADT@+-- and @deconstructADT@ would need to change.+--+-- 2. Maybe this is obvious, but just to spell it out: once you're in+-- the @Result@ context, you can of course construct @Task@ values+-- normally and use standard Haskell pattern-matching. @constructADT@+-- and @deconstructADT@ are specifically only needed in the @Expr@+-- context, and they allow you to do the equivalent of pattern+-- matching in PostgreSQL.

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

@@ -0,0 +1,26 @@+{-# language DataKinds #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeFamilyDependencies #-}++module Rel8.Column.Null+  ( HNull+  )+where++-- base+import Data.Kind ( Type )+import Prelude++-- rel8+import qualified Rel8.Schema.Kind as K+import Rel8.Schema.Result ( Result )+import Rel8.Table.Null ( NullTable )+++-- | Nest a 'Null' value within a 'Rel8able'. @HNull f a@ will produce a+-- 'NullTable' @a@ in the 'Expr' context, and a @'Maybe' a@ in the 'Result'+-- context.+type HNull :: K.Context -> Type -> Type+type family HNull context = maybe | maybe -> context where+  HNull Result = Maybe+  HNull context = NullTable context

@@ -10,7 +10,7 @@   , scastExpr, sunsafeCastExpr   , unsafeLiteral   , fromPrimExpr, toPrimExpr, mapPrimExpr, zipPrimExprsWith, traversePrimExpr-  , toColumn, fromColumn+  , toColumn, fromColumn, traverseFieldP   ) where @@ -27,7 +27,10 @@ import Rel8.Type ( DBType, typeInformation ) import Rel8.Type.Information ( TypeInformation(..) ) +-- profunctors+import Data.Profunctor ( Profunctor, dimap ) + castExpr :: Sql DBType a => Expr a -> Expr a castExpr = scastExpr typeInformation @@ -78,6 +81,12 @@ traversePrimExpr :: Functor f   => (Opaleye.PrimExpr -> f Opaleye.PrimExpr) -> Expr a -> f (Expr b) traversePrimExpr f = fmap fromPrimExpr . f . toPrimExpr+++traverseFieldP :: Profunctor p+  => p (Opaleye.Field_ n x) (Opaleye.Field_ m y)+  -> p (Expr a) (Expr b)+traverseFieldP =  dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn)   toColumn :: Opaleye.PrimExpr -> Opaleye.Field_ n b

@@ -1,5 +1,8 @@+{-# language FlexibleContexts #-}+ module Rel8.Query.Null   ( catNull+  , catNullTable   ) where @@ -9,6 +12,8 @@ -- rel8 import Rel8.Expr ( Expr ) import Rel8.Expr.Null ( isNonNull, unsafeUnnullify )+import Rel8.Table ( Table )+import Rel8.Table.Null ( NullTable, isNonNullTable, unsafeUnnullifyTable ) import Rel8.Query ( Query ) import Rel8.Query.Filter ( where_ ) @@ -21,3 +26,13 @@ catNull a = do   where_ $ isNonNull a   pure $ unsafeUnnullify a+++-- | Filter a 'Query' that might return @nullTable@ to a 'Query' without any+-- @nullTable@s.+--+-- Corresponds to 'Data.Maybe.catMaybes'.+catNullTable :: Table Expr a => NullTable Expr a -> Query a+catNullTable a = do+  where_ $ isNonNullTable a+  pure $ unsafeUnnullifyTable a

@@ -16,7 +16,7 @@ module Rel8.Schema.HTable   ( HTable (HField, HConstrainTable)   , hfield, htabulate, htraverse, hdicts, hspecs-  , hmap, htabulateA+  , hmap, htabulateA, htraverseP, htraversePWithField   ) where @@ -32,6 +32,12 @@   ) import Prelude +-- profunctors+import Data.Profunctor ( rmap, Profunctor (lmap) )++-- product-profunctors+import Data.Profunctor.Product ( ProductProfunctor ((****)) )+ -- rel8 import Rel8.Schema.Dict ( Dict ) import Rel8.Schema.Spec ( Spec )@@ -41,7 +47,6 @@ -- 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').@@ -124,6 +129,22 @@ htabulateA f = htraverse getCompose $ htabulate $ Compose . f {-# INLINABLE htabulateA #-} +newtype ApplyP p a b = ApplyP { unApplyP :: p a b }++instance Profunctor p => Functor (ApplyP p a) where+  fmap f = ApplyP . rmap f . unApplyP++instance ProductProfunctor p => Apply (ApplyP p a) where+  ApplyP f <.> ApplyP x = ApplyP (rmap id f **** x)++htraverseP :: (HTable t, ProductProfunctor p)+  => (forall a. p (f a) (g a)) -> p (t f) (t g)+htraverseP f = htraversePWithField (const f)++htraversePWithField :: (HTable t, ProductProfunctor p)+  => (forall a. HField t a -> p (f a) (g a)) -> p (t f) (t g)+htraversePWithField f = unApplyP $ htabulateA $ \field -> ApplyP $+  lmap (flip hfield field) (f field)  type GHField :: K.HTable -> Type -> Type newtype GHField t a = GHField (HField (GHColumns (Rep (t Proxy))) a)

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

@@ -37,6 +37,18 @@  -- | Group equal tables together. This works by aggregating each column in the -- given table with 'groupByExpr'.+--+-- For example, if we have a table of items, we could group the items by the+-- order they belong to:+--+-- @+-- itemsByOrder :: Query (OrderId Expr, ListTable Expr (Item Expr))+-- itemsByOrder = aggregate $ do+--   item <- each itemSchema+--   let orderId = groupBy (itemOrderId item)+--   let orderItems = listAgg item+--   pure (orderId, orderItems)+-- @ groupBy :: forall exprs aggregates. (EqTable exprs, Aggregates aggregates exprs)   => exprs -> aggregates groupBy = fromColumns . hgroupBy (eqTable @exprs) . toColumns

@@ -15,6 +15,7 @@   ( MaybeTable(..)   , maybeTable, nothingTable, justTable   , isNothingTable, isJustTable+  , fromMaybeTable   , ($?)   , aggregateMaybeTable   , nameMaybeTable@@ -204,6 +205,11 @@ -- 'pure'. justTable :: a -> MaybeTable Expr a justTable = MaybeTable mempty . pure+++-- | 'Data.Maybe.fromMaybe' for 'MaybeTable's.+fromMaybeTable :: Table Expr a => a -> MaybeTable Expr a -> a+fromMaybeTable fallback = maybeTable fallback id   -- | Project a single expression out of a 'MaybeTable'. You can think of this

@@ -0,0 +1,147 @@+{-# language DataKinds #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language MultiParamTypeClasses #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeApplications #-}+{-# language TypeFamilies #-}+{-# language UndecidableInstances #-}++module Rel8.Table.Null+  ( NullTable(..)+  , nullableTable, nullTable, nullifyTable, unsafeUnnullifyTable+  , isNullTable, isNonNullTable+  , nameNullTable+  , toMaybeTable, toNullTable+  )+where++-- base+import Data.Kind ( Type )+import Prelude hiding ( null, undefined )++-- comonad+import Control.Comonad ( extract )++-- rel8+import Rel8.Expr ( Expr )+import Rel8.Expr.Bool ( not_ )+import Rel8.Kind.Context ( Reifiable )+import qualified Rel8.Schema.Kind as K+import Rel8.Schema.Name ( Name )+import Rel8.Table+  ( Table, Columns, Context, fromColumns, toColumns+  , FromExprs, fromResult, toResult+  , Transpose+  )+import Rel8.Table.Alternative+  ( AltTable, (<|>:)+  , AlternativeTable, emptyTable+  )+import Rel8.Table.Bool ( bool )+import Rel8.Table.Eq ( EqTable, eqTable )+import Rel8.Table.Maybe ( MaybeTable, justTable, maybeTable, nothingTable )+import Rel8.Table.Nullify ( Nullify, isNull )+import Rel8.Table.Ord ( OrdTable, ordTable )+import Rel8.Table.Projection ( Projectable, project )+import Rel8.Table.Serialize ( ToExprs )+import Rel8.Table.Undefined ( undefined )+++-- | @NullTable t@ is the table @t@, but where all the columns in @t@ have the+-- possibility of being 'Rel8.null'. This is very similar to+-- 'Rel8.MaybeTable', except that it does not use an extra tag field, so it+-- cannot distinguish between @Nothing@ and @Just Nothing@ if nested. In other+-- words, if all of the columns of the @t@ passed to @NullTable@ are already+-- nullable, then @NullTable@ has no effect.+type NullTable :: K.Context -> Type -> Type+newtype NullTable context a = NullTable (Nullify context a)+++instance Projectable (NullTable context) where+  project f (NullTable a) = NullTable (project f a)+++instance context ~ Expr => AltTable (NullTable context) where+  ma <|>: mb = bool ma mb (isNullTable ma)+++instance context ~ Expr => AlternativeTable (NullTable context) where+  emptyTable = nullTable+++instance (Table context a, Reifiable context, context ~ context') =>+  Table context' (NullTable context a)+ where+  type Columns (NullTable context a) = Columns (Nullify context a)+  type Context (NullTable context a) = Context (Nullify context a)+  type FromExprs (NullTable context a) = FromExprs (Nullify context a)+  type Transpose to (NullTable context a) = NullTable to (Transpose to a)++  toColumns (NullTable a) = toColumns a+  fromColumns = NullTable . fromColumns++  toResult = toResult @_ @(Nullify context a)+  fromResult = fromResult @_ @(Nullify context a)+++instance (EqTable a, context ~ Expr) => EqTable (NullTable context a) where+  eqTable = eqTable @(Nullify context a)+++instance (OrdTable a, context ~ Expr) => OrdTable (NullTable context a) where+  ordTable = ordTable @(Nullify context a)+++instance (ToExprs exprs a, context ~ Expr) =>+  ToExprs (NullTable context exprs) (Maybe a)+++-- | Check if any of the non-nullable fields of @a@ are 'Rel8.null' under the+-- 'NullTable'. Returns 'Rel8.false' if @a@ has no non-nullable fields.+isNullTable :: Table Expr a => NullTable Expr a -> Expr Bool+isNullTable (NullTable a) = isNull a+++-- | The inverse of 'isNullTable'.+isNonNullTable :: Table Expr a => NullTable Expr a -> Expr Bool+isNonNullTable = not_ . isNullTable+++-- | Like 'Rel8.nullable'.+nullableTable :: (Table Expr a, Table Expr b)+  => b -> (a -> b) -> NullTable Expr a -> b+nullableTable b f ma@(NullTable a) = bool (f (extract a)) b (isNullTable ma)+++-- | The null table. Like 'Rel8.null'.+nullTable :: Table Expr a => NullTable Expr a+nullTable = NullTable (pure undefined)+++-- | Lift any table into 'NullTable'. Like 'Rel8.nullify'.+nullifyTable :: a -> NullTable Expr a+nullifyTable = NullTable . pure+++unsafeUnnullifyTable :: NullTable Expr a -> a+unsafeUnnullifyTable (NullTable a) = extract a+++-- | Construct a 'NullTable' in the 'Name' context. This can be useful if you+-- have a 'NullTable' that you are storing in a table and need to construct a+-- 'TableSchema'.+nameNullTable :: a -> NullTable Name a+nameNullTable = NullTable . pure+++-- | Convert a 'NullTable' to a 'MaybeTable'.+toMaybeTable :: Table Expr a => NullTable Expr a -> MaybeTable Expr a+toMaybeTable = nullableTable nothingTable justTable+++-- | Convert a 'MaybeTable' to a 'NullTable'. Note that if the underlying @a@+-- has no non-nullable fields, this is a lossy conversion.+toNullTable :: Table Expr a => MaybeTable Expr a -> NullTable Expr a+toNullTable = maybeTable nullTable nullifyTable

@@ -1,7 +1,9 @@ {-# language DataKinds #-}+{-# language FlexibleContexts #-} {-# language FlexibleInstances #-} {-# language LambdaCase #-} {-# language MultiParamTypeClasses #-}+{-# language NamedFieldPuns #-} {-# language ScopedTypeVariables #-} {-# language StandaloneKindSignatures #-} {-# language TypeApplications #-}@@ -12,11 +14,13 @@   ( Nullify   , aggregateNullify   , guard+  , isNull   ) where  -- base import Control.Applicative ( liftA2 )+import Data.Functor.Const ( Const( Const ), getConst ) import Data.Functor.Identity ( runIdentity ) import Data.Kind ( Type ) import Prelude@@ -27,6 +31,8 @@ -- rel8 import Rel8.Aggregate ( Aggregate ) import Rel8.Expr ( Expr )+import Rel8.Expr.Bool ( (||.), false )+import qualified Rel8.Expr.Null as Expr import Rel8.Kind.Context ( Reifiable, contextSing ) import Rel8.Schema.Context.Nullify   ( Nullifiability( NAggregate, NExpr )@@ -45,12 +51,14 @@   , hproject   ) import qualified Rel8.Schema.Kind as K+import Rel8.Schema.Null ( Nullity( NotNull, Null ) ) import qualified Rel8.Schema.Result as R import Rel8.Table   ( Table, Columns, Context, toColumns, fromColumns   , FromExprs, fromResult, toResult   , Transpose   )+import Rel8.Schema.Spec ( Spec( Spec, nullity ) ) import Rel8.Table.Eq ( EqTable, eqTable ) import Rel8.Table.Ord ( OrdTable, ordTable ) import Rel8.Table.Projection ( Projectable, apply, project )@@ -182,3 +190,22 @@   -> HNullify t context guard tag isNonNull isNonNullExpr =   hguard (guarder contextSing tag isNonNull isNonNullExpr)+++isNull :: forall a. Table Expr a => Nullify Expr a -> Expr Bool+isNull =+  maybe false getAny .+  getConst .+  hunnullify (\Spec {nullity} a -> Const $ case nullity of+    NotNull -> Just $ Any $ Expr.isNull a+    Null -> Nothing) .+  toColumns+++newtype Any = Any+  { getAny :: Expr Bool+  }+++instance Semigroup Any where+  Any a <> Any b = Any (a ||. b)

@@ -28,17 +28,16 @@ -- base import Data.Functor.Const ( Const( Const ), getConst ) import Data.List.NonEmpty ( NonEmpty )-import Prelude hiding ( undefined )+import Prelude  -- opaleye+import qualified Opaleye.Adaptors as Opaleye+import qualified Opaleye.Field as Opaleye ( Field_ ) 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+import qualified Opaleye.Table as Opaleye  -- profunctors import Data.Profunctor ( dimap, lmap )@@ -48,27 +47,25 @@ import Rel8.Expr ( Expr ) import Rel8.Expr.Opaleye   ( fromPrimExpr, toPrimExpr-  , traversePrimExpr-  , fromColumn, toColumn-  , scastExpr+  , scastExpr, traverseFieldP   )-import Rel8.Schema.HTable ( htabulateA, hfield, htraverse, hspecs, htabulate )+import Rel8.Schema.HTable ( htabulateA, hfield, hspecs, htabulate,+                            htraverseP, htraversePWithField ) import Rel8.Schema.Name ( Name( Name ), Selects, ppColumn ) import Rel8.Schema.Spec ( Spec(..) ) import Rel8.Schema.Table ( TableSchema(..), ppTable ) import Rel8.Table ( Table, fromColumns, toColumns )-import Rel8.Table.Undefined ( undefined )+import Rel8.Type.Information ( typeName )  -- semigroupoids import Data.Functor.Apply ( WrappedApplicative(..) )+import Data.Profunctor.Product ( ProductProfunctor )   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-      Aggregate (Opaleye.Aggregator (Opaleye.PackMap inner)) ->-        inner f ()+aggregator = dimap toColumns fromColumns $+             htraverseP $+             lmap (\(Aggregate a) -> (a, ())) Opaleye.aggregatorApply   attributes :: Selects names exprs => TableSchema names -> exprs@@ -79,22 +76,19 @@         show (ppTable schema) <> "." <> show (ppColumn column)  +fromOpaleyespec :: (ProductProfunctor p, Table Expr a)+  => p (Opaleye.Field_ n x) (Opaleye.Field_ n x)+  -> p a a+fromOpaleyespec x =+  dimap toColumns fromColumns (htraverseP (traverseFieldP x))++ 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-        (a, b) -> fromPrimExpr <$> f (toPrimExpr a, toPrimExpr b)+binaryspec = fromOpaleyespec Opaleye.binaryspecField   distinctspec :: Table Expr a => Opaleye.Distinctspec a a-distinctspec =-  Opaleye.Distinctspec $ Opaleye.Aggregator $ Opaleye.PackMap $ \f ->-    fmap fromColumns .-    unwrapApplicative .-    htraverse-      (\a -> WrapApplicative $ fromPrimExpr <$> f (Nothing, toPrimExpr a)) .-    toColumns+distinctspec = fromOpaleyespec Opaleye.distinctspecField   exprs :: Table Expr a => a -> NonEmpty Opaleye.PrimExpr@@ -113,8 +107,8 @@ 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)+    Nothing -> Opaleye.table name (tableFields columns)+    Just schemaName -> Opaleye.tableWithSchema schemaName name (tableFields columns)   tableFields :: Selects names exprs@@ -126,36 +120,25 @@   where     go :: Name a -> Opaleye.TableFields (Expr a) (Expr a)     go (Name name) =-      dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $+      traverseFieldP $         Opaleye.requiredTableField name   unpackspec :: Table Expr a => Opaleye.Unpackspec a a-unpackspec = Opaleye.Unpackspec $ Opaleye.PackMap $ \f ->-  fmap fromColumns .-  unwrapApplicative .-  htraverse (WrapApplicative . traversePrimExpr f) .-  toColumns+unpackspec = fromOpaleyespec Opaleye.unpackspecField {-# INLINABLE unpackspec #-}   valuesspec :: Table Expr a => Opaleye.Valuesspec a a-valuesspec = Opaleye.ValuesspecSafe (toPackMap undefined) unpackspec+valuesspec = dimap toColumns fromColumns $+  htraversePWithField (traverseFieldP . Opaleye.valuesspecFieldType . typeName)+  where typeName = Rel8.Type.Information.typeName . info . hfield hspecs   view :: Selects names exprs => names -> exprs view columns = fromColumns $ htabulate $ \field ->   case hfield (toColumns columns) field of     Name column -> fromPrimExpr $ Opaleye.BaseTableAttrExpr column---toPackMap :: Table Expr a-  => a -> Opaleye.PackMap Opaleye.PrimExpr Opaleye.PrimExpr () a-toPackMap as = Opaleye.PackMap $ \f () ->-  fmap fromColumns $-  unwrapApplicative .-  htraverse (WrapApplicative . traversePrimExpr f) $-  toColumns as   -- | Transform a table by adding 'CAST' to all columns. This is most useful for

@@ -146,9 +146,9 @@  -- | 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)+least a b = bool b a (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)+greatest a b = bool b a (a >: b)

@@ -20,6 +20,7 @@   , isThisTable, isThatTable, isThoseTable   , hasHereTable, hasThereTable   , justHereTable, justThereTable+  , alignMaybeTable   , aggregateTheseTable   , nameTheseTable   )@@ -29,13 +30,13 @@ import Data.Bifunctor ( Bifunctor, bimap ) import Data.Kind ( Type ) import Data.Maybe ( isJust )-import Prelude hiding ( undefined )+import Prelude hiding ( null, undefined )  -- rel8 import Rel8.Aggregate ( Aggregate ) import Rel8.Expr ( Expr )-import Rel8.Expr.Bool ( (&&.), not_ )-import Rel8.Expr.Null ( isNonNull )+import Rel8.Expr.Bool ( (&&.), (||.), boolExpr, not_ )+import Rel8.Expr.Null ( null, isNonNull ) import Rel8.Kind.Context ( Reifiable ) import Rel8.Schema.Context.Nullify ( Nullifiable ) import Rel8.Schema.Dict ( Dict( Dict ) )@@ -286,6 +287,16 @@ -- Corresponds to 'Data.These.Combinators.justThere'. justThereTable :: TheseTable context a b -> MaybeTable context b justThereTable = there+++-- | Construct a @TheseTable@ from two 'MaybeTable's.+alignMaybeTable :: ()+  => MaybeTable Expr a+  -> MaybeTable Expr b+  -> MaybeTable Expr (TheseTable Expr a b)+alignMaybeTable a b = MaybeTable tag (pure (TheseTable a b))+  where+    tag = boolExpr null mempty (isJustTable a ||. isJustTable b)   -- | Construct a @TheseTable@. Corresponds to 'This'.

@@ -58,7 +58,7 @@ import Data.Functor.Contravariant ( Contravariant, (>$<), contramap ) import Data.Int ( Int64 ) import Data.Kind ( Type )-import Data.Maybe ( fromMaybe )+import Data.Maybe ( fromJust, fromMaybe ) import Prelude hiding ( lookup, zip, zipWith )  -- bifunctors@@ -90,7 +90,6 @@ import Rel8.Query ( Query ) import qualified Rel8.Query.Exists as Q ( exists, present, absent ) import Rel8.Query.Filter ( where_ )-import Rel8.Query.Limit ( limit ) import Rel8.Query.List ( catNonEmptyTable ) import qualified Rel8.Query.Maybe as Q ( optional ) import Rel8.Query.Opaleye ( mapOpaleye, unsafePeekQuery )@@ -234,7 +233,13 @@ -- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<|>:)@ is -- @unionWith (<>)@. instance EqTable k => AltTable (Tabulation k) where-  as <|>: bs = catNonEmptyTable `through` ((<>) `on` some) as bs+  tas <|>: tbs = do+    eas <- peek tas+    ebs <- peek tbs+    case (eas, ebs) of+      (Left as, Left bs) -> liftQuery $ as <|>: bs+      (Right as, Right bs) -> fromQuery $ as <|>: bs+      _ -> catNonEmptyTable `through` ((<>) `on` some) tas tbs   instance EqTable k => AlternativeTable (Tabulation k) where@@ -343,12 +348,8 @@ -- \"first\" value it encounters for each key, but note that \"first\" is -- undefined unless you first call 'order'. distinct :: EqTable k => Tabulation k a -> Tabulation k a-distinct (Tabulation f) = Tabulation $ \p ->-  -- workaround for https://github.com/tomjaguarpaw/haskell-opaleye/pull/518-  case fst (unsafePeekQuery (f p)) of-    Nothing -> limit 1 (f p)-    Just _ ->-      mapOpaleye (Opaleye.distinctOnExplicit (key unpackspec) fst) (f p)+distinct (Tabulation f) = Tabulation $+  mapOpaleye (Opaleye.distinctOnExplicit (key unpackspec) fst) . f   -- | 'order' orders the /values/ of a 'Tabulation' within their@@ -626,3 +627,13 @@ -- @do@-notation. difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a difference a b = a <* absent b+++-- | 'Tabulation's can be produced with either 'fromQuery' or 'liftQuery', and+-- in some cases we might want to treat these differently. 'peek' uses+-- 'unsafePeekQuery' to determine which type of 'Tabulation' we have.+peek :: Tabulation k a -> Tabulation k (Either (Query a) (Query (k, a)))+peek (Tabulation f) = Tabulation $ \p ->+  pure $ (empty,) $ case unsafePeekQuery (f p) of+    (Nothing, _) -> Left $ fmap snd (f p)+    (Just _, _) -> Right $ fmap (first fromJust) (f p)