packages feed

rel8 1.5.0.0 → 1.6.0.0

raw patch · 29 files changed

+687/−120 lines, 29 filesdep +binary-parserdep +iproutedep ~basedep ~base-compatdep ~data-dwordnew-uploader

Dependencies added: binary-parser, iproute

Dependency ranges changed: base, base-compat, data-dword, hasql, network-ip, tmp-postgres

Files

Changelog.md view
@@ -1,4 +1,46 @@ +<a id='changelog-1.6.0.0'></a>+# 1.6.0.0 — 2024-12-13++## Removed++- Remove `Table Expr b` constraint from `materialize`. ([#334](https://github.com/circuithub/rel8/pull/334))++## Added++- Support GHC-9.10. ([#340](https://github.com/circuithub/rel8/pull/340))++- Support hasql-1.8 ([#345](https://github.com/circuithub/rel8/pull/345))++- Add `aggregateJustTable`, `aggregateJustTable` aggregator functions. These provide another way to do aggregation of `MaybeTable`s than the existing `aggregateMaybeTable` function. ([#333](https://github.com/circuithub/rel8/pull/333))++- Add `aggregateLeftTable`, `aggregateLeftTable1`, `aggregateRightTable` and `aggregateRightTable1` aggregator functions. These provide another way to do aggregation of `EitherTable`s than the existing `aggregateEitherTable` function. ([#333](https://github.com/circuithub/rel8/pull/333))++- Add `aggregateThisTable`, `aggregateThisTable1`, `aggregateThatTable`, `aggregateThatTable1`, `aggregateThoseTable`, `aggregateThoseTable1`, `aggregateHereTable`, `aggregateHereTable1`, `aggregateThereTable` and `aggregateThereTable1` aggregation functions. These provide another way to do aggregation of `TheseTable`s than the existing `aggregateTheseTable` function. ([#333](https://github.com/circuithub/rel8/pull/333))++- Add `rawFunction`, `rawBinaryOperator`, `rawAggregateFunction`, `unsafeCoerceExpr`, `unsafePrimExpr`, `unsafeSubscript`, `unsafeSubscripts` — these give more options for generating SQL expressions that Rel8 does not support natively. ([#331](https://github.com/circuithub/rel8/pull/331))++- Expose `unsafeUnnullify` and `unsafeUnnullifyTable` from `Rel8`. ([#343](https://github.com/circuithub/rel8/pull/343))++- Expose `listOf` and `nonEmptyOf`. ([#330](https://github.com/circuithub/rel8/pull/330))++- Add `NOINLINE` pragmas to `Generic` derived default methods of `Rel8able`. This should speed up+  compilation times. If users wish for these methods to be `INLINE`d, they can override with a+  pragma in their own code. ([#346](https://github.com/circuithub/rel8/pull/346))++## Fixed++- `JSONEncoded` should be encoded as `json` not `jsonb`. ([#347](https://github.com/circuithub/rel8/pull/347))++- Disallow NULL characters in Hedgehog generated text values. ([#339](https://github.com/circuithub/rel8/pull/339))++- Fix fromRational bug. ([#338](https://github.com/circuithub/rel8/pull/338))++- Fix regex match operator. ([#336](https://github.com/circuithub/rel8/pull/336))++- Fix some documentation formatting issues. ([#332](https://github.com/circuithub/rel8/pull/332)), ([#329](https://github.com/circuithub/rel8/pull/329)), ([#327](https://github.com/circuithub/rel8/pull/327)), and ([#318](https://github.com/circuithub/rel8/pull/318))++ <a id='changelog-1.5.0.0'></a> # 1.5.0.0 — 2024-03-19
rel8.cabal view
@@ -1,6 +1,6 @@ cabal-version:       2.0 name:                rel8-version:             1.5.0.0+version:             1.6.0.0 synopsis:            Hey! Hey! Can u rel8? license:             BSD3 license-file:        LICENSE@@ -22,17 +22,20 @@       aeson     , attoparsec     , attoparsec-aeson-    , base ^>= 4.16 || ^>= 4.17 || ^>= 4.18 || ^>= 4.19+    , base ^>= 4.16 || ^>= 4.17 || ^>= 4.18 || ^>= 4.19 || ^>= 4.20     , base16 >= 1.0-    , base-compat ^>= 0.11 || ^>= 0.12 || ^>= 0.13+    , base-compat ^>= 0.11 || ^>= 0.12 || ^>= 0.13 || ^>= 0.14     , bifunctors+    , binary-parser ^>= 0.5+    , data-dword ^>= 0.3     , bytestring     , case-insensitive     , comonad     , contravariant     , data-textual-    , hasql ^>= 1.6.1.2-    , network-ip+    , hasql >= 1.6.1.2 && < 1.9+    , network-ip ^>= 0.3+    , iproute ^>= 1.7     , opaleye ^>= 0.10.2.1     , pretty     , profunctors@@ -99,6 +102,7 @@     Rel8.Expr.Sequence     Rel8.Expr.Serialize     Rel8.Expr.Show+    Rel8.Expr.Subscript     Rel8.Expr.Window      Rel8.FCF@@ -185,6 +189,7 @@     Rel8.Table     Rel8.Table.ADT     Rel8.Table.Aggregate+    Rel8.Table.Aggregate.Maybe     Rel8.Table.Alternative     Rel8.Table.Bool     Rel8.Table.Cols@@ -237,7 +242,8 @@ test-suite tests   type:             exitcode-stdio-1.0   build-depends:-      base+      aeson+    , base     , bytestring     , case-insensitive     , containers@@ -247,6 +253,7 @@     , hedgehog          ^>= 1.0 || ^>= 1.1 || ^>= 1.2 || ^>= 1.3 || ^>= 1.4 || ^>= 1.5     , mmorph     , network-ip+    , iproute     , rel8     , scientific     , tasty@@ -256,6 +263,7 @@     , tmp-postgres      ^>=1.34.1.0     , transformers     , uuid+    , vector    other-modules:     Rel8.Generic.Rel8able.Test
src/Rel8.hs view
@@ -66,6 +66,7 @@   , optional   , catMaybeTable   , traverseMaybeTable+  , aggregateJustTable, aggregateJustTable1   , aggregateMaybeTable   , nameMaybeTable @@ -76,6 +77,8 @@   , keepLeftTable   , keepRightTable   , bitraverseEitherTable+  , aggregateLeftTable, aggregateLeftTable1+  , aggregateRightTable, aggregateRightTable1   , aggregateEitherTable   , nameEitherTable @@ -93,12 +96,17 @@   , keepThatTable, loseThatTable   , keepThoseTable, loseThoseTable   , bitraverseTheseTable+  , aggregateThisTable, aggregateThisTable1+  , aggregateThatTable, aggregateThatTable1+  , aggregateThoseTable, aggregateThoseTable1+  , aggregateHereTable, aggregateHereTable1+  , aggregateThereTable, aggregateThereTable1   , aggregateTheseTable   , nameTheseTable      -- ** @ListTable@   , ListTable-  , listTable, ($*)+  , listOf, listTable, ($*)   , nameListTable   , many   , manyExpr@@ -107,7 +115,7 @@      -- ** @NonEmptyTable@   , NonEmptyTable-  , nonEmptyTable, ($+)+  , nonEmptyOf, nonEmptyTable, ($+)   , nameNonEmptyTable   , some   , someExpr@@ -121,6 +129,7 @@   , catNullTable   , nameNullTable   , toNullTable, toMaybeTable+  , unsafeUnnullifyTable      -- ** Algebraic data types / sum types     -- $adts@@ -161,7 +170,9 @@   , Sql   , litExpr   , unsafeCastExpr+  , unsafeCoerceExpr   , unsafeLiteral+  , unsafePrimExpr      -- ** @null@   , NotNull@@ -176,6 +187,7 @@   , liftOpNull   , catNull   , coalesce+  , unsafeUnnullify      -- ** Boolean operations   , DBEq@@ -198,6 +210,8 @@   , function   , binaryOperator   , queryFunction+  , rawFunction+  , rawBinaryOperator      -- * Queries   , Query@@ -285,6 +299,7 @@   , and, andOn   , or, orOn   , aggregateFunction+  , rawAggregateFunction    , mode, modeOn   , percentile, percentileOn@@ -396,12 +411,13 @@ import Rel8.Column.These import Rel8.Expr import Rel8.Expr.Aggregate+import Rel8.Expr.Array import Rel8.Expr.Bool import Rel8.Expr.Default import Rel8.Expr.Eq import Rel8.Expr.Function import Rel8.Expr.Null-import Rel8.Expr.Opaleye (unsafeCastExpr, unsafeLiteral)+import Rel8.Expr.Opaleye (unsafeCastExpr, unsafeCoerceExpr, unsafeLiteral, unsafePrimExpr) import Rel8.Expr.Ord import Rel8.Expr.Order import Rel8.Expr.Serialize@@ -453,6 +469,7 @@ import Rel8.Table import Rel8.Table.ADT import Rel8.Table.Aggregate+import Rel8.Table.Aggregate.Maybe import Rel8.Table.Alternative import Rel8.Table.Bool import Rel8.Table.Either
src/Rel8/Aggregate/Function.hs view
@@ -3,6 +3,7 @@  module Rel8.Aggregate.Function (   aggregateFunction,+  rawAggregateFunction, ) where  -- base@@ -31,10 +32,14 @@   (Table Expr i, Sql DBType a) =>   QualifiedName ->   Aggregator1 i (Expr a)-aggregateFunction name =+aggregateFunction name = castExpr <$> rawAggregateFunction name+++rawAggregateFunction :: Table Expr i => QualifiedName -> Aggregator1 i (Expr a)+rawAggregateFunction name =   unsafeMakeAggregator     id-    (castExpr . fromPrimExpr . fromColumn)+    (fromPrimExpr . fromColumn)     Empty     (Opaleye.makeAggrExplicit unpackspec       (Opaleye.AggrOther (showQualifiedName name)))
src/Rel8/Array.hs view
@@ -13,6 +13,10 @@   , index1, index1Expr   , last1, last1Expr   , length1, length1Expr++    -- ** Unsafe+  , unsafeSubscript+  , unsafeSubscripts   ) where @@ -22,5 +26,6 @@ -- rel8 import Rel8.Expr.List import Rel8.Expr.NonEmpty+import Rel8.Expr.Subscript import Rel8.Table.List import Rel8.Table.NonEmpty
src/Rel8/Expr/Default.hs view
@@ -24,7 +24,7 @@ -- @DEFAULT@ value. Trying to use @unsafeDefault@ where there is no default -- will cause a runtime crash ----- 3. @DEFAULT@ values can not be transformed. For example, the innocuous Rel8+-- 3. @DEFAULT@ values cannot be transformed. For example, the innocuous Rel8 -- code @unsafeDefault + 1@ will crash, despite type checking. -- -- Also note, PostgreSQL's syntax rules mean that @DEFAULT@ can only appear in
src/Rel8/Expr/Function.hs view
@@ -11,7 +11,9 @@   ( Arguments   , function   , primFunction+  , rawFunction   , binaryOperator+  , rawBinaryOperator   ) where @@ -22,19 +24,20 @@ -- opaleye import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye --- pretty-import Text.PrettyPrint (parens, text)- -- rel8 import {-# SOURCE #-} Rel8.Expr (Expr) import Rel8.Expr.Opaleye   ( castExpr   , fromPrimExpr, toPrimExpr, zipPrimExprsWith   )-import Rel8.Schema.Escape (escape) import Rel8.Schema.HTable (hfoldMap) import Rel8.Schema.Null ( Sql )-import Rel8.Schema.QualifiedName (QualifiedName (..), showQualifiedName)+import Rel8.Schema.QualifiedName+  ( QualifiedName (..)+  , showQualifiedName+  , showQualifiedOperator+  +  ) import Rel8.Table (Table, toColumns) import Rel8.Type ( DBType ) @@ -59,9 +62,15 @@ -- the arguments @arguments@ returning an @'Expr' a@. function :: (Arguments arguments, Sql DBType a)   => QualifiedName -> arguments -> Expr a-function qualified = castExpr . fromPrimExpr . primFunction qualified+function qualified = castExpr . rawFunction qualified  +-- | A less safe version of 'function' that does not wrap the return value in+-- a cast.+rawFunction :: Arguments arguments => QualifiedName -> arguments -> Expr a+rawFunction qualified = fromPrimExpr . primFunction qualified++ primFunction :: Arguments arguments   => QualifiedName -> arguments -> Opaleye.PrimExpr primFunction qualified = Opaleye.FunExpr name . arguments@@ -72,14 +81,13 @@ -- | Construct an expression by applying an infix binary operator to two -- operands. binaryOperator :: Sql DBType c => QualifiedName -> Expr a -> Expr b -> Expr c-binaryOperator operator a b =-  castExpr $ zipPrimExprsWith (Opaleye.BinExpr (Opaleye.OpOther name)) a b-  where-    name = showQualifiedOperator operator+binaryOperator operator a b = castExpr $ rawBinaryOperator operator a b  -showQualifiedOperator :: QualifiedName -> String-showQualifiedOperator QualifiedName {schema = mschema, ..} = case mschema of-  Nothing -> name-  Just schema ->-    show $ text "OPERATOR" <> parens (escape schema <> text "." <> text name)+-- | A less safe version of 'binaryOperator' that does not wrap the return+-- value in a cast.+rawBinaryOperator :: QualifiedName -> Expr a -> Expr b -> Expr c+rawBinaryOperator operator a b =+  zipPrimExprsWith (Opaleye.BinExpr (Opaleye.OpOther name)) a b+  where+    name = showQualifiedOperator operator
src/Rel8/Expr/Null.hs view
@@ -35,6 +35,10 @@ nullify (Expr a) = Expr a  +-- | Assume that a nullable column's value is non-null. If the column is+-- actually @null@, this will lead to runtime errors when you try to decode+-- the value into Haskell, so you should prefer to use 'Rel8.nullable'+-- unless you know what you're doing. unsafeUnnullify :: Expr (Maybe a) -> Expr a unsafeUnnullify (Expr a) = Expr a
src/Rel8/Expr/Opaleye.hs view
@@ -9,6 +9,8 @@ module Rel8.Expr.Opaleye   ( castExpr, unsafeCastExpr   , scastExpr, sunsafeCastExpr+  , unsafeCoerceExpr+  , unsafePrimExpr   , unsafeLiteral   , fromPrimExpr, toPrimExpr, mapPrimExpr, zipPrimExprsWith, traversePrimExpr   , toColumn, fromColumn, traverseFieldP@@ -44,6 +46,22 @@   TypeInformation {typeName} -> sunsafeCastExpr typeName  +-- | Change the type of an 'Expr', without a cast. Even more unsafe than+-- 'unsafeCastExpr'. Only use this if you are certain that the @typeName@s of+-- @a@ and @b@ refer to exactly the same PostgreSQL type.+unsafeCoerceExpr :: Expr a -> Expr b+unsafeCoerceExpr (Expr a) = Expr a+++-- | Import a raw 'Opaleye.PrimExpr' from @opaleye@, without a cast.+--+-- This is an escape hatch, and can be used if Rel8 cannot adequately express+-- the expression you need. If you find yourself using this function, please+-- let us know, as it may indicate that something is missing from Rel8!+unsafePrimExpr :: Opaleye.PrimExpr -> Expr a+unsafePrimExpr = fromPrimExpr++ scastExpr :: TypeInformation (Unnullify a) -> Expr a -> Expr a scastExpr TypeInformation {typeName} = sunsafeCastExpr typeName @@ -56,9 +74,9 @@  -- | 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!+-- This is an escape hatch, and can be used if Rel8 cannot adequately express+-- the expression 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
+ src/Rel8/Expr/Subscript.hs view
@@ -0,0 +1,65 @@+{-# language FlexibleContexts #-}+{-# language MonoLocalBinds #-}++module Rel8.Expr.Subscript+  ( unsafeSubscript+  , unsafeSubscripts+  )+where++-- base+import Data.Foldable (foldl')+import Prelude++-- opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye++-- rel8+import Rel8.Expr (Expr)+import Rel8.Expr.Opaleye (fromPrimExpr, toPrimExpr)+import Rel8.Schema.HTable (hfoldMap)+import Rel8.Schema.Null (Sql, Unnullify)+import Rel8.Table (Table, toColumns)+import Rel8.Type (DBType, typeInformation)+import Rel8.Type.Array (extractArrayElement)+import Rel8.Type.Information (TypeInformation)+++-- | @'unsafeSubscript' a i@ will generate the SQL @a[i]@.+--+-- Note that this function is not type checked and the generated SQL has no+-- casts. This is only intended an escape hatch to be used if Rel8 cannot+-- otherwise express the expression you need. If you find yourself using this+-- function, please let us know, as it may indicate that something is missing+-- from Rel8!+unsafeSubscript :: Sql DBType b => Expr a -> Expr i -> Expr b+unsafeSubscript = sunsafeSubscript typeInformation+++-- | @'unsafeSubscripts' a (i, j)@ will generate the SQL @a[i][j]@.+--+-- Note that this function is not type checked and the generated SQL has no+-- casts. This is only intended an escape hatch to be used if Rel8 cannot+-- otherwise express the expression you need. If you find yourself using this+-- function, please let us know, as it may indicate that something is missing+-- from Rel8!+unsafeSubscripts :: (Table Expr i, Sql DBType b) => Expr a -> i -> Expr b+unsafeSubscripts = sunsafeSubscripts typeInformation+++sunsafeSubscript :: TypeInformation (Unnullify b) -> Expr a -> Expr i -> Expr b+sunsafeSubscript info array i =+  fromPrimExpr . extractArrayElement info $+    Opaleye.ArrayIndex (toPrimExpr array) (toPrimExpr i)+++sunsafeSubscripts :: Table Expr i => TypeInformation (Unnullify b) -> Expr a -> i -> Expr b+sunsafeSubscripts info array i =+  fromPrimExpr $ extractArrayElement info $ primSubscripts array indices+  where+    indices = hfoldMap (pure . toPrimExpr) $ toColumns i+++primSubscripts :: Expr a -> [Opaleye.PrimExpr] -> Opaleye.PrimExpr+primSubscripts array indices =+  foldl' Opaleye.ArrayIndex (toPrimExpr array) indices
src/Rel8/Expr/Text.hs view
@@ -58,9 +58,9 @@  -- | Matches regular expression, case sensitive ----- Corresponds to the @~.@ operator.+-- Corresponds to the @~@ operator. (~.) :: Expr Text -> Expr Text -> Expr Bool-(~.) = binaryOperator "~."+(~.) = binaryOperator "~" infix 2 ~.
src/Rel8/Generic/Rel8able.hs view
@@ -168,6 +168,7 @@   type GColumns t = G.GColumns TColumns (GRep t Expr)   type GFromExprs t = t Result +  {-# NOINLINE gfromColumns #-} -- See Note [Generics and Inlining]   default gfromColumns :: forall context.     ( SRel8able t Expr     , forall table. SRel8able t (Field table)@@ -181,6 +182,7 @@     SName -> sfromColumns     SResult -> sfromResult +  {-# NOINLINE gtoColumns #-} -- See Note [Generics and Inlining]   default gtoColumns :: forall context.     ( SRel8able t Expr     , forall table. SRel8able t (Field table)@@ -194,10 +196,12 @@     SName -> stoColumns     SResult -> stoResult +  {-# NOINLINE gfromResult #-} -- See Note [Generics and Inlining]   default gfromResult :: (SSerialize t, GFromExprs t ~ t Result)     => GColumns t Result -> GFromExprs t   gfromResult = sfromResult +  {-# NOINLINE gtoResult #-} -- See Note [Generics and Inlining]   default gtoResult :: (SSerialize t, GFromExprs t ~ t Result)     => GFromExprs t -> GColumns t Result   gtoResult = stoResult@@ -274,3 +278,11 @@     (\(_ :: proxy x) -> serialize @_ @x) .   from .   Record++-- Note [Generics and Inlining]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- We want to make sure that Generics derived functions (by default)+-- do not expose their unfoldings. These are always unoptimised code and can+-- therefore be quite large, and bloat our interfaces.+-- By marking these as NOINLINE we can considerably speed up our compile times.+-- If users do want these INLINEd, they can locally override the default using a pragma.
src/Rel8/Query/Materialize.hs view
@@ -15,7 +15,6 @@ import Rel8.Expr ( Expr ) import Rel8.Query ( Query ) import Rel8.Query.Opaleye ( fromOpaleye, toOpaleye )-import Rel8.Query.Rebind ( rebind ) import Rel8.Table ( Table ) import Rel8.Table.Opaleye ( unpackspec ) @@ -31,10 +30,9 @@ -- specifically the @WITH _ AS MATERIALIZED (_)@ form introduced in PostgreSQL -- 12. This means that 'materialize' can only be used with PostgreSQL 12 or -- newer.-materialize :: (Table Expr a, Table Expr b)-  => Query a -> (Query a -> Query b) -> Query b+materialize :: Table Expr a => Query a -> (Query a -> Query b) -> Query b materialize query f =-  (>>= rebind "with") . fromOpaleye $+  fromOpaleye $     withMaterializedExplicit unpackspec       (toOpaleye query')       (toOpaleye . f . fromOpaleye)
src/Rel8/Schema/QualifiedName.hs view
@@ -8,6 +8,7 @@   ( QualifiedName (..)   , ppQualifiedName   , showQualifiedName+  , showQualifiedOperator   ) where @@ -17,7 +18,7 @@ import Prelude  -- pretty-import Text.PrettyPrint (Doc, text)+import Text.PrettyPrint (Doc, parens, text)  -- rel8 import Rel8.Schema.Escape (escape)@@ -52,3 +53,10 @@  showQualifiedName :: QualifiedName -> String showQualifiedName = show . ppQualifiedName+++showQualifiedOperator :: QualifiedName -> String+showQualifiedOperator QualifiedName {schema = mschema, ..} = case mschema of+  Nothing -> name+  Just schema ->+    show $ text "OPERATOR" <> parens (escape schema <> text "." <> text name)
src/Rel8/Statement.hs view
@@ -132,7 +132,7 @@ --     delete Delete --       { from = fooSchema --       , using = pure ()---       , deleteWhere = \_ -> predicate+--       , deleteWhere = \\_ -> predicate --       , returning = Returning id --       } --   insert Insert
src/Rel8/Table/Aggregate.hs view
@@ -9,9 +9,8 @@   ( groupBy, groupByOn   , listAgg, listAggOn, nonEmptyAgg, nonEmptyAggOn   , listCat, listCatOn, nonEmptyCat, nonEmptyCatOn-  , filterWhere, filterWhereOptional+  , filterWhere   , orderAggregateBy-  , optionalAggregate   ) where @@ -25,11 +24,7 @@ import Data.Profunctor (dimap, lmap)  -- rel8-import Rel8.Aggregate-  ( Aggregator,  Aggregator' (Aggregator), Aggregator1-  , toAggregator-  )-import Rel8.Aggregate.Fold (Fallback (Fallback))+import Rel8.Aggregate (Aggregator,  Aggregator' (Aggregator), Aggregator1) import Rel8.Expr ( Expr ) import Rel8.Expr.Aggregate   ( filterWhereExplicit@@ -39,7 +34,6 @@   , snonEmptyAggExpr   , snonEmptyCatExpr   )-import Rel8.Expr.Opaleye (toColumn, toPrimExpr) import Rel8.Order (Order (Order)) import Rel8.Schema.Dict ( Dict( Dict ) ) import Rel8.Schema.HTable (HTable, hfield, hspecs, htabulateA)@@ -49,7 +43,6 @@ import Rel8.Table (Table, toColumns, fromColumns) import Rel8.Table.Eq ( EqTable, eqTable ) import Rel8.Table.List ( ListTable )-import Rel8.Table.Maybe (MaybeTable, makeMaybeTable, justTable, nothingTable) import Rel8.Table.NonEmpty ( NonEmptyTable ) import Rel8.Table.Opaleye (ifPP) import Rel8.Type.Eq ( DBEq )@@ -91,22 +84,13 @@ -- predicate supplied to 'filterWhere' could return 'Rel8.false' for every -- row, 'filterWhere' needs an 'Aggregator' as opposed to an 'Aggregator1', so -- that it can return a default value in such a case. For a variant of--- 'filterWhere' that can work with 'Aggregator1's, see 'filterWhereOptional'.+-- 'filterWhere' that can work with 'Aggregator1's, see+-- 'Rel8.filterWhereOptional'. filterWhere :: Table Expr a   => (i -> Expr Bool) -> Aggregator i a -> Aggregator' fold i a filterWhere = filterWhereExplicit ifPP  --- | A variant of 'filterWhere' that can be used with an 'Aggregator1'--- (upgrading it to an 'Aggregator' in the process). It returns--- 'nothingTable' in the case where the predicate matches zero rows.-filterWhereOptional :: Table Expr a-  => (i -> Expr Bool) -> Aggregator' fold i a -> Aggregator' fold' i (MaybeTable Expr a)-filterWhereOptional f (Aggregator _ aggregator) =-  Aggregator (Fallback nothingTable) $-    Opaleye.filterWhereInternal makeMaybeTable (toColumn . toPrimExpr . f) aggregator-- -- | 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@@ -184,11 +168,3 @@ orderAggregateBy :: Order i -> Aggregator' fold i a -> Aggregator' fold i a orderAggregateBy (Order order) (Aggregator fallback aggregator) =   Aggregator fallback $ Opaleye.orderAggregate order aggregator----- | 'optionalAggregate' upgrades an 'Aggregator1' into an 'Aggregator' by--- having it return 'nothingTable' when aggregating over an empty collection--- of rows.-optionalAggregate :: Table Expr a-  => Aggregator' fold i a -> Aggregator' fold' i (MaybeTable Expr a)-optionalAggregate = toAggregator nothingTable . fmap justTable
+ src/Rel8/Table/Aggregate/Maybe.hs view
@@ -0,0 +1,89 @@+{-# language FlexibleContexts #-}++module Rel8.Table.Aggregate.Maybe+  ( filterWhereOptional+  , optionalAggregate+  , aggregateJustTable+  , aggregateJustTable1+  , aggregateMaybeTable+  )+where++-- base+import Prelude++-- opaleye+import qualified Opaleye.Internal.Aggregate as Opaleye++-- profunctors+import Data.Profunctor (lmap)++-- rel8+import Rel8.Aggregate+  ( Aggregator' (Aggregator)+  , Aggregator, toAggregator+  , Aggregator1, toAggregator1+  )+import Rel8.Aggregate.Fold (Fallback (Fallback))+import Rel8.Expr (Expr)+import Rel8.Expr.Aggregate (groupByExprOn)+import Rel8.Expr.Opaleye (toColumn, toPrimExpr)+import Rel8.Table (Table)+import Rel8.Table.Aggregate (filterWhere)+import Rel8.Table.Maybe+  ( MaybeTable (MaybeTable, just, tag), justTable, nothingTable+  , isJustTable+  , makeMaybeTable+  )+import Rel8.Table.Nullify (aggregateNullify, unsafeUnnullifyTable)+++-- | A variant of 'filterWhere' that can be used with an 'Aggregator1'+-- (upgrading it to an 'Aggregator' in the process). It returns+-- 'nothingTable' in the case where the predicate matches zero rows.+filterWhereOptional :: Table Expr a+  => (i -> Expr Bool) -> Aggregator' fold i a -> Aggregator' fold' i (MaybeTable Expr a)+filterWhereOptional f (Aggregator _ aggregator) =+  Aggregator (Fallback nothingTable) $+    Opaleye.filterWhereInternal makeMaybeTable (toColumn . toPrimExpr . f) aggregator+++-- | 'optionalAggregate' upgrades an 'Aggregator1' into an 'Aggregator' by+-- having it return 'nothingTable' when aggregating over an empty collection+-- of rows.+optionalAggregate :: Table Expr a+  => Aggregator' fold i a -> Aggregator' fold' i (MaybeTable Expr a)+optionalAggregate = toAggregator nothingTable . fmap justTable+++-- | Lift an 'Aggregator' to operate on a 'MaybeTable'. If the input query has+-- @'justTable' i@s, they are folded into a single @a@ by the given aggregator+-- — in the case where the input query is all 'nothingTable's, the+-- 'Aggregator'\'s fallback @a@ is returned.+aggregateJustTable :: Table Expr a+  => Aggregator i a+  -> Aggregator' fold (MaybeTable Expr i) a+aggregateJustTable =+  filterWhere isJustTable . lmap (unsafeUnnullifyTable . just)+++-- | Lift an 'Aggregator1' to operate on a 'MaybeTable'. If the input query+-- has @'justTable' i@s, they are folded into a single @'justTable' a@ by the+-- given aggregator — in the case where the input query is all+-- 'nothingTable's, a single 'nothingTable' row is returned.+aggregateJustTable1 :: Table Expr a+  => Aggregator' fold i a+  -> Aggregator' fold' (MaybeTable Expr i) (MaybeTable Expr a)+aggregateJustTable1 =+  filterWhereOptional isJustTable . lmap (unsafeUnnullifyTable . just)+++-- | Lift an aggregator to operate on a 'MaybeTable'. @nothingTable@s and+-- @justTable@s are grouped separately.+aggregateMaybeTable :: ()+  => Aggregator' fold i a+  -> Aggregator1 (MaybeTable Expr i) (MaybeTable Expr a)+aggregateMaybeTable aggregator =+  MaybeTable+    <$> groupByExprOn tag+    <*> lmap just (toAggregator1 (aggregateNullify aggregator))
src/Rel8/Table/Either.hs view
@@ -1,3 +1,4 @@+{-# language ApplicativeDo #-} {-# language DataKinds #-} {-# language DeriveFunctor #-} {-# language DerivingStrategies #-}@@ -19,6 +20,8 @@   ( EitherTable(..)   , eitherTable, leftTable, rightTable   , isLeftTable, isRightTable+  , aggregateLeftTable, aggregateLeftTable1+  , aggregateRightTable, aggregateRightTable1   , aggregateEitherTable   , nameEitherTable   )@@ -37,7 +40,7 @@ import Data.Profunctor (lmap)  -- rel8-import Rel8.Aggregate (Aggregator', Aggregator1, toAggregator1)+import Rel8.Aggregate (Aggregator, Aggregator', Aggregator1, toAggregator1) import Rel8.Expr ( Expr ) import Rel8.Expr.Aggregate (groupByExprOn) import Rel8.Expr.Serialize ( litExpr )@@ -54,9 +57,14 @@   , FromExprs, fromResult, toResult   , Transpose   )+import Rel8.Table.Aggregate (filterWhere)+import Rel8.Table.Aggregate.Maybe (filterWhereOptional) import Rel8.Table.Bool ( bool ) import Rel8.Table.Eq ( EqTable, eqTable )-import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )+import Rel8.Table.Maybe (MaybeTable)+import Rel8.Table.Nullify+  ( Nullify, aggregateNullify, guard, unsafeUnnullifyTable+  ) import Rel8.Table.Ord ( OrdTable, ordTable ) import Rel8.Table.Projection ( Biprojectable, Projectable, biproject, project ) import Rel8.Table.Serialize ( ToExprs )@@ -216,6 +224,50 @@ -- | Construct a right 'EitherTable'. Like 'Right'. rightTable :: Table Expr a => b -> EitherTable Expr a b rightTable = EitherTable (litExpr IsRight) undefined . pure+++-- | Lift an 'Aggregator' to operate on an 'EitherTable'. If the input query has+-- @'leftTable' a@s, they are folded into a single @c@ by the given aggregator+-- — in the case where the input query is all 'rightTable's, the+-- 'Aggregator'\'s fallback @c@ is returned.+aggregateLeftTable :: Table Expr c+  => Aggregator a c+  -> Aggregator' fold (EitherTable Expr a b) c+aggregateLeftTable =+  filterWhere isLeftTable . lmap (unsafeUnnullifyTable . left)+++-- | Lift an 'Aggregator1' to operate on an 'EitherTable'. If the input query+-- has @'leftTable' a@s, they are folded into a single @'Rel8.justTable' c@+-- by the given aggregator — in the case where the input query is all+-- 'rightTable's, a single 'nothingTable' row is returned.+aggregateLeftTable1 :: Table Expr c+  => Aggregator' fold a c+  -> Aggregator' fold' (EitherTable Expr a b) (MaybeTable Expr c)+aggregateLeftTable1 =+  filterWhereOptional isLeftTable . lmap (unsafeUnnullifyTable . left)+++-- | Lift an 'Aggregator' to operate on an 'EitherTable'. If the input query has+-- @'rightTable' b@s, they are folded into a single @c@ by the given aggregator+-- — in the case where the input query is all 'rightTable's, the+-- 'Aggregator'\'s fallback @c@ is returned.+aggregateRightTable :: Table Expr c+  => Aggregator b c+  -> Aggregator' fold (EitherTable Expr a b) c+aggregateRightTable =+  filterWhere isRightTable . lmap (unsafeUnnullifyTable . right)+++-- | Lift an 'Aggregator1' to operate on an 'EitherTable'. If the input query+-- has @'rightTable' b@s, they are folded into a single @'Rel8.justTable' c@+-- by the given aggregator — in the case where the input query is all+-- 'leftTable's, a single 'nothingTable' row is returned.+aggregateRightTable1 :: Table Expr c+  => Aggregator' fold a c+  -> Aggregator' fold' (EitherTable Expr a b) (MaybeTable Expr c)+aggregateRightTable1 =+  filterWhereOptional isLeftTable . lmap (unsafeUnnullifyTable . left)   -- | Lift a pair aggregators to operate on an 'EitherTable'. @leftTable@s and
src/Rel8/Table/Maybe.hs view
@@ -18,9 +18,9 @@   , isNothingTable, isJustTable   , fromMaybeTable   , ($?)-  , aggregateMaybeTable   , nameMaybeTable   , makeMaybeTable+  , unsafeFromJustTable   ) where @@ -38,13 +38,8 @@ import qualified Opaleye.Field as Opaleye import qualified Opaleye.SqlTypes as Opaleye --- profunctors-import Data.Profunctor (lmap)- -- rel8-import Rel8.Aggregate (Aggregator', Aggregator1, toAggregator1) import Rel8.Expr ( Expr )-import Rel8.Expr.Aggregate (groupByExprOn) import Rel8.Expr.Bool ( boolExpr ) import Rel8.Expr.Null ( isNull, isNonNull, null, nullify ) import Rel8.Expr.Opaleye (fromColumn, fromPrimExpr)@@ -70,7 +65,7 @@ import Rel8.Table.Eq ( EqTable, eqTable ) import Rel8.Table.Ord ( OrdTable, ordTable ) import Rel8.Table.Projection ( Projectable, project )-import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )+import Rel8.Table.Nullify (Nullify, guard, unsafeUnnullifyTable) import Rel8.Table.Serialize ( ToExprs ) import Rel8.Table.Undefined ( undefined ) import Rel8.Type ( DBType )@@ -222,6 +217,10 @@ fromMaybeTable fallback = maybeTable fallback id  +unsafeFromJustTable :: MaybeTable Expr a -> a+unsafeFromJustTable (MaybeTable _ just) = unsafeUnnullifyTable just++ -- | 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@.@@ -231,17 +230,6 @@   Null -> boolExpr (f (extract a)) null (isNothingTable ma)   NotNull -> boolExpr (nullify (f (extract a))) null (isNothingTable ma) infixl 4 $?----- | Lift an aggregator to operate on a 'MaybeTable'. @nothingTable@s and--- @justTable@s are grouped separately.-aggregateMaybeTable :: ()-  => Aggregator' fold i a-  -> Aggregator1 (MaybeTable Expr i) (MaybeTable Expr a)-aggregateMaybeTable aggregator =-  MaybeTable-    <$> groupByExprOn tag-    <*> lmap just (toAggregator1 (aggregateNullify aggregator))   -- | Construct a 'MaybeTable' in the 'Name' context. This can be useful if you
src/Rel8/Table/Null.hs view
@@ -126,6 +126,7 @@ nullifyTable = NullTable . pure  +-- | Assume that a 'NullTable' is non-null. Like 'Rel8.unsafeUnnullify'. unsafeUnnullifyTable :: NullTable Expr a -> a unsafeUnnullifyTable (NullTable a) = extract a
src/Rel8/Table/Nullify.hs view
@@ -16,6 +16,7 @@   , aggregateNullify   , guard   , isNull+  , unsafeUnnullifyTable   ) where @@ -182,9 +183,7 @@   -> Aggregator' fold (Nullify Expr i) (Nullify Expr a) aggregateNullify = dimap from to   where-    from = \case-      Table _ a -> a-      Fields notNullifiable _ -> absurd NExpr notNullifiable+    from = unsafeUnnullifyTable     to = Table NExpr  @@ -206,6 +205,12 @@     NotNull -> Just $ Any $ Expr.isNull a     Null -> Nothing) .   toColumns+++unsafeUnnullifyTable :: Nullify Expr a -> a+unsafeUnnullifyTable = \case+  Table _ a -> a+  Fields notNullifiable _ -> absurd NExpr notNullifiable   newtype Any = Any
src/Rel8/Table/These.hs view
@@ -22,12 +22,18 @@   , hasHereTable, hasThereTable   , justHereTable, justThereTable   , alignMaybeTable+  , aggregateThisTable, aggregateThisTable1+  , aggregateThatTable, aggregateThatTable1+  , aggregateThoseTable, aggregateThoseTable1+  , aggregateHereTable, aggregateHereTable1+  , aggregateThereTable, aggregateThereTable1   , aggregateTheseTable   , nameTheseTable   ) where  -- base+import Control.Arrow ((&&&)) import Data.Bifunctor ( Bifunctor, bimap ) import Data.Kind ( Type ) import Data.Maybe ( isJust )@@ -37,7 +43,7 @@ import Data.Profunctor (lmap)  -- rel8-import Rel8.Aggregate (Aggregator', Aggregator1)+import Rel8.Aggregate (Aggregator, Aggregator', Aggregator1) import Rel8.Expr ( Expr ) import Rel8.Expr.Bool ( (&&.), (||.), boolExpr, not_ ) import Rel8.Expr.Null ( null, isNonNull )@@ -55,13 +61,19 @@   , FromExprs, fromResult, toResult   , Transpose   )+import Rel8.Table.Aggregate (filterWhere)+import Rel8.Table.Aggregate.Maybe+  ( aggregateJustTable, aggregateJustTable1+  , aggregateMaybeTable+  , filterWhereOptional+  ) import Rel8.Table.Eq ( EqTable, eqTable ) import Rel8.Table.Maybe   ( MaybeTable(..)   , maybeTable, justTable, nothingTable   , isJustTable-  , aggregateMaybeTable   , nameMaybeTable+  , unsafeFromJustTable   ) import Rel8.Table.Nullify ( Nullify, guard ) import Rel8.Table.Ord ( OrdTable, ordTable )@@ -328,8 +340,118 @@     there  --- | Lift a pair aggregators to operate on a 'TheseTable'. @thisTable@s,--- @thatTable@s are @thoseTable@s are grouped separately.+-- | Lift an 'Aggregator' to operate on a 'TheseTable'. If the input query has+-- @'thisTable' a@s, they are folded into a single @c@ by the given aggregator+-- — in the case where the input query is all 'thatTable's or 'thoseTable's,+-- the 'Aggregator'\'s fallback @c@ is returned.+aggregateThisTable :: Table Expr c+  => Aggregator a c+  -> Aggregator' fold (TheseTable Expr a b) c+aggregateThisTable =+  filterWhere isThisTable . lmap (unsafeFromJustTable . here)+++-- | Lift an 'Aggregator1' to operate on a 'TheseTable'. If the input query+-- has @'thisTable' a@s, they are folded into a single @'Rel8.justTable' c@+-- by the given aggregator — in the case where the input query is all+-- 'thatTable's or 'thoseTable's, a single 'nothingTable' row is returned.+aggregateThisTable1 :: Table Expr c+  => Aggregator' fold a c+  -> Aggregator' fold' (TheseTable Expr a b) (MaybeTable Expr c)+aggregateThisTable1 =+  filterWhereOptional isThisTable . lmap (unsafeFromJustTable . here)+++-- | Lift an 'Aggregator' to operate on a 'TheseTable'. If the input query has+-- @'thatTable' b@s, they are folded into a single @c@ by the given aggregator+-- — in the case where the input query is all 'thisTable's or 'thoseTable's,+-- the 'Aggregator'\'s fallback @c@ is returned.+aggregateThatTable :: Table Expr c+  => Aggregator b c+  -> Aggregator' fold (TheseTable Expr a b) c+aggregateThatTable =+  filterWhere isThatTable . lmap (unsafeFromJustTable . there)+++-- | Lift an 'Aggregator1' to operate on a 'TheseTable'. If the input query+-- has @'thatTable' b@s, they are folded into a single @'Rel8.justTable' c@+-- by the given aggregator — in the case where the input query is all+-- 'thisTable's or 'thoseTable's, a single 'nothingTable' row is returned.+aggregateThatTable1 :: Table Expr c+  => Aggregator' fold b c+  -> Aggregator' fold' (TheseTable Expr a b) (MaybeTable Expr c)+aggregateThatTable1 =+  filterWhereOptional isThatTable . lmap (unsafeFromJustTable . there)+++-- | Lift an 'Aggregator' to operate on a 'ThoseTable'. If the input query has+-- @'thoseTable' a b@s, they are folded into a single @c@ by the given+-- aggregator — in the case where the input query is all 'thisTable's or+-- 'thatTable's, the 'Aggregator'\'s fallback @c@ is returned.+aggregateThoseTable :: Table Expr c+  => Aggregator (a, b) c+  -> Aggregator' fold (TheseTable Expr a b) c+aggregateThoseTable =+  filterWhere isThoseTable+    . lmap (unsafeFromJustTable . here &&& unsafeFromJustTable . there)+++-- | Lift an 'Aggregator1' to operate on a 'TheseTable'. If the input query+-- has @'thoseTable' a b@s, they are folded into a single @'Rel8.justTable' c@+-- by the given aggregator — in the case where the input query is all+-- 'thisTable's or 'thatTable's, a single 'nothingTable' row is returned.+aggregateThoseTable1 :: Table Expr c+  => Aggregator' fold (a, b) c+  -> Aggregator' fold' (TheseTable Expr a b) (MaybeTable Expr c)+aggregateThoseTable1 =+  filterWhereOptional isThoseTable+    . lmap (unsafeFromJustTable . here &&& unsafeFromJustTable . there)+++-- | Lift an 'Aggregator' to operate on a 'TheseTable'. If the input query has+-- @'thisTable' a@s or @'thoseTable' a _@s, the @a@s are folded into a single+-- @c@ by the given aggregator — in the case where the input query is all+-- 'thatTable's, the 'Aggregator'\'s fallback @c@ is returned.+aggregateHereTable :: Table Expr c+  => Aggregator a c+  -> Aggregator' fold (TheseTable Expr a b) c+aggregateHereTable = lmap here . aggregateJustTable+++-- | Lift an 'Aggregator1' to operate on an 'TheseTable'. If the input query+-- has @'thisTable' a@s or @'thoseTable' a _@s, the @a@s are folded into a+-- single @'Rel8.justTable' c@ by the given aggregator — in the case where+-- the input query is all 'thatTable's, a single 'nothingTable' row is+-- returned.+aggregateHereTable1 :: Table Expr c+  => Aggregator' fold a c+  -> Aggregator' fold' (TheseTable Expr a b) (MaybeTable Expr c)+aggregateHereTable1 = lmap here . aggregateJustTable1+++-- | Lift an 'Aggregator' to operate on a 'TheseTable'. If the input query has+-- @'thatTable' b@s or @'thoseTable' _ b@s, the @b@s are folded into a single+-- @c@ by the given aggregator — in the case where the input query is all+-- 'thisTable's, the 'Aggregator'\'s fallback @c@ is returned.+aggregateThereTable :: Table Expr c+  => Aggregator b c+  -> Aggregator' fold (TheseTable Expr a b) c+aggregateThereTable = lmap there . aggregateJustTable+++-- | Lift an 'Aggregator1' to operate on an 'TheseTable'. If the input query+-- has @'thatTable' b@s or @'thoseTable' _ b@s, the @b@s are folded into a+-- single @'Rel8.justTable' c@ by the given aggregator — in the case where+-- the input query is all 'thisTable's, a single 'nothingTable' row is+-- returned.+aggregateThereTable1 :: Table Expr c+  => Aggregator' fold b c+  -> Aggregator' fold' (TheseTable Expr a b) (MaybeTable Expr c)+aggregateThereTable1 = lmap there . aggregateJustTable1+++-- | Lift a pair aggregators to operate on a 'TheseTable'. 'thisTable's,+-- 'thatTable's are 'thoseTable's are grouped separately. aggregateTheseTable :: ()   => Aggregator' fold i a   -> Aggregator' fold' i' b
src/Rel8/Tabulate.hs view
@@ -527,7 +527,7 @@ -- -- Note that you can achieve the same effect with 'optional' and the -- 'Applicative' instance for 'Tabulation', i.e., this is just--- @\left right -> liftA2 (,) left (optional right). You can also+-- @\\left right -> liftA2 (,) left (optional right)@. You can also -- use @do@-notation. leftAlign :: EqTable k   => Tabulation k a -> Tabulation k b -> Tabulation k (a, MaybeTable Expr b)@@ -540,7 +540,7 @@ -- -- Note that you can achieve the same effect with 'optional' and the -- 'Applicative' instance for 'Tabulation', i.e., this is just--- @\f left right -> liftA2 f left (optional right). You can also+-- @\\f left right -> liftA2 f left (optional right)@. You can also -- use @do@-notation. leftAlignWith :: EqTable k   => (a -> MaybeTable Expr b -> c)@@ -554,7 +554,7 @@ -- -- Note that you can achieve the same effect with 'optional' and the -- 'Applicative' instance for 'Tabulation', i.e., this is just--- @\left right -> liftA2 (flip (,)) right (optional left). You can+-- @\\left right -> liftA2 (flip (,)) right (optional left)@. You can -- also use @do@-notation. rightAlign :: EqTable k   => Tabulation k a -> Tabulation k b -> Tabulation k (MaybeTable Expr a, b)@@ -567,7 +567,7 @@ -- -- Note that you can achieve the same effect with 'optional' and the -- 'Applicative' instance for 'Tabulation', i.e., this is just--- @\f left right -> liftA2 (flip f) right (optional left). You can+-- @\\f left right -> liftA2 (flip f) right (optional left)@. You can -- also use @do@-notation. rightAlignWith :: EqTable k   => (MaybeTable Expr a -> b -> c)@@ -607,7 +607,7 @@ -- -- Note that you can achieve a similar effect with 'present' and the -- 'Applicative' instance of 'Tabulation', i.e., this is just--- @\left right -> left <* present right@. You can also use+-- @\\left right -> left <* present right@. You can also use -- @do@-notation. similarity :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a similarity a b = a <* present b@@ -621,14 +621,14 @@ -- -- Note that you can achieve a similar effect with 'absent' and the -- 'Applicative' instance of 'Tabulation', i.e., this is just--- @\left right -> left <* absent right@. You can also use+-- @\\left right -> left <* absent right@. You can also use -- @do@-notation. difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a difference a b = a <* absent b   -- | 'Q.materialize' for 'Tabulation's.-materialize :: (Table Expr k, Table Expr a, Table Expr b)+materialize :: (Table Expr k, Table Expr a)   => Tabulation k a -> (Tabulation k a -> Query b) -> Query b materialize tabulation f = case peek tabulation of   Tabulation query -> do
src/Rel8/Type.hs view
@@ -27,14 +27,19 @@ -- base import Control.Applicative ((<|>)) import Data.Fixed (Fixed)-import Data.Int ( Int16, Int32, Int64 )+import Data.Int ( Int8, Int16, Int32, Int64 )+import Data.Word (Word8, Word32) import Data.List.NonEmpty ( NonEmpty ) import Data.Kind ( Constraint, Type ) import Prelude+import Data.Bits (Bits (..))+import Data.DoubleWord (fromHiAndLo)+import Text.Read (readMaybe)  -- bytestring import Data.ByteString (ByteString) import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy as Lazy ( ByteString ) import qualified Data.ByteString.Lazy as ByteString ( fromStrict, toStrict ) @@ -51,6 +56,9 @@ -- network-ip import qualified Network.IP.Addr as IP +import qualified Data.IP+import qualified BinaryParser+ -- opaleye import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye import qualified Opaleye.Internal.HaskellDB.Sql.Default as Opaleye ( quote )@@ -433,7 +441,9 @@         Opaleye.ConstExpr . Opaleye.StringLit . IP.printNetAddr     , decode =         Decoder-          { binary = Hasql.inet+          { binary = (Hasql.custom . const . BinaryParser.run $ netaddrParser+                      (\netmask x -> IP.netAddr (IP.IPv4 $ IP.IP4 x) netmask)+                      (\netmask x1 x2 x3 x4 -> IP.netAddr (IP.IPv6 $ IP.IP6 $ fromHiAndLo (fromHiAndLo x1 x2) (fromHiAndLo x3 x4)) netmask) :: Hasql.Value (IP.NetAddr IP.IP))           , parser = parse $               textual                 <|> (`IP.netAddr` 32) . IP.IPv4 <$> textual@@ -442,6 +452,53 @@           }     , typeName = "inet"     }++-- | Corresponds to @inet@+instance DBType Data.IP.IPRange where+  typeInformation = TypeInformation+    { encode =+        Opaleye.ConstExpr . Opaleye.StringLit . show+    , decode =+        Decoder+          { binary = (Hasql.custom . const . BinaryParser.run $ netaddrParser+                      (\netmask x -> Data.IP.IPv4Range $ Data.IP.makeAddrRange (Data.IP.toIPv4w x) $ fromIntegral netmask)+                      (\netmask x1 x2 x3 x4 -> Data.IP.IPv6Range $ Data.IP.makeAddrRange (Data.IP.toIPv6w (x1, x2, x3, x4)) $ fromIntegral netmask))+          , parser = \str -> case readMaybe $ BS8.unpack str of+              Just x -> Right x+              Nothing -> Left "Failed to parse inet"+          , delimiter = ','+          }+    , typeName = "inet"+    }++-- | Address family AF_INET+inetAddressFamily :: Word8+inetAddressFamily =+  2++-- | Address family AF_INET6+inet6AddressFamily :: Word8+inet6AddressFamily =+  3++-- | This is vendored from `postgresql-binary`.+netaddrParser :: (Word8 -> Word32 -> ip) -> (Word8 -> Word32 -> Word32 -> Word32 ->  Word32 -> ip) -> BinaryParser.BinaryParser ip+netaddrParser mkIpv4 mkIpv6 = do+  af <- intOfSize 1+  netmask <- intOfSize 1+  isCidr <- intOfSize @Int8 1+  ipSize <- intOfSize @Int8 1+  if | af == inetAddressFamily ->+         mkIpv4 netmask <$> intOfSize 4+     | af == inet6AddressFamily ->+         mkIpv6 netmask <$> intOfSize 4 <*> intOfSize 4  <*> intOfSize 4 <*> intOfSize 4+     | otherwise -> BinaryParser.failure ("Unknown address family: " <> Text.pack (show af))++intOfSize :: (Integral a, Bits a) => Int -> BinaryParser.BinaryParser a+intOfSize x =+  fmap integralPack (BinaryParser.bytesOfSize x)+  where+    integralPack = BS.foldl' (\n h -> shiftL n 8 .|. fromIntegral h) 0   instance Sql DBType a => DBType [a] where
src/Rel8/Type/JSONBEncoded.hs view
@@ -30,7 +30,7 @@ -- | Like 'Rel8.JSONEncoded', but works for @jsonb@ columns. type JSONBEncoded :: Type -> Type newtype JSONBEncoded a = JSONBEncoded { fromJSONBEncoded :: a }-+  deriving (Show, Eq, Ord)  instance (FromJSON a, ToJSON a) => DBType (JSONBEncoded a) where   typeInformation = TypeInformation
src/Rel8/Type/JSONEncoded.hs view
@@ -1,29 +1,56 @@ {-# language StandaloneKindSignatures #-}+{-# language OverloadedStrings        #-}+{-# language TypeApplications         #-}  module Rel8.Type.JSONEncoded ( JSONEncoded(..) ) where  -- aeson-import Data.Aeson ( FromJSON, ToJSON, parseJSON, toJSON )+import Data.Aeson ( FromJSON, ToJSON, parseJSON ) import Data.Aeson.Types ( parseEither )+import qualified Data.Aeson as Aeson  -- base import Data.Kind ( Type )+import Data.Bifunctor (first) import Prelude +-- hasql+import qualified Hasql.Decoders as Hasql+ -- rel8 import Rel8.Type ( DBType(..) )-import Rel8.Type.Information ( parseTypeInformation )+import Rel8.Type.Information ( TypeInformation(..) )+import Rel8.Type.Decoder ( Decoder(..) ) +-- opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye+import qualified Opaleye.Internal.HaskellDB.Sql.Default as Opaleye ( quote ) +-- text+import qualified Data.Text as Text+import qualified Data.Text.Lazy as Lazy+import qualified Data.Text.Lazy.Encoding as Lazy++ -- | 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. type JSONEncoded :: Type -> Type newtype JSONEncoded a = JSONEncoded { fromJSONEncoded :: a }+  deriving (Show, Eq, Ord)   instance (FromJSON a, ToJSON a) => DBType (JSONEncoded a) where-  typeInformation = parseTypeInformation f g typeInformation-    where-      f = fmap JSONEncoded . parseEither parseJSON-      g = toJSON . fromJSONEncoded+  typeInformation = TypeInformation+    { encode =+        Opaleye.ConstExpr . Opaleye.OtherLit . Opaleye.quote .+        Lazy.unpack . Lazy.decodeUtf8 .+        Aeson.encode . fromJSONEncoded+    , decode =+        Decoder+          { binary = Hasql.refine (first Text.pack . fmap JSONEncoded . parseEither parseJSON) Hasql.json+          , parser = fmap JSONEncoded . Aeson.eitherDecodeStrict+          , delimiter = ','+          }+    , typeName = "json"+    }
src/Rel8/Type/Num.hs view
@@ -41,7 +41,7 @@  -- | The class of database types that can be coerced to from integral -- expressions. This is a Rel8 concept, and allows us to provide--- 'fromIntegral'.+-- 'Rel8.Expr.Num.fromIntegral'. type DBIntegral :: Type -> Constraint class (DBNum a, DBOrd a) => DBIntegral a instance DBIntegral Int16
src/Rel8/Window.hs view
@@ -72,9 +72,9 @@  -- | 'over' adds a 'Partition' to a 'Window' expression. ----- @@@--- 'Rel8.Table.Window.cumulative' ('Rel8.Expr.Aggregate.sum' . salary) `over` 'partitionBy' department <> 'orderPartitionBy' (salary >$< 'Rel8.desc')--- @@@+-- @+--   'Rel8.Table.Window.cumulative' ('Rel8.Expr.Aggregate.sum' . salary) `over` 'partitionBy' department <> 'orderPartitionBy' (salary >$< 'Rel8.desc')+-- @ over :: Window a b -> Partition a -> Window a b over (Window (Opaleye.Windows (Opaleye.PackMap w))) (Partition p) =   Window $ Opaleye.Windows $ Opaleye.PackMap $ \f ->
tests/Main.hs view
@@ -18,6 +18,11 @@   ) where +-- aeson+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Key as Aeson.Key+import qualified Data.Aeson.KeyMap as Aeson.KeyMap+ -- base import Control.Applicative ( empty, liftA2, liftA3 ) import Control.Exception ( bracket, throwIO )@@ -66,6 +71,8 @@ import Network.IP.Addr (NetAddr, IP, IP4(..), IP6(..), IP46(..), net4Addr, net6Addr, fromNetAddr46, Net4Addr, Net6Addr) import Data.DoubleWord (Word128(..)) +import qualified Data.IP+ -- rel8 import Rel8 ( Result ) import qualified Rel8@@ -81,6 +88,7 @@  -- text import Data.Text ( Text, pack, unpack )+import qualified Data.Text as T import qualified Data.Text.Lazy import Data.Text.Encoding ( decodeUtf8 ) @@ -96,7 +104,10 @@ -- uuid import qualified Data.UUID +-- vector+import qualified Data.Vector as Vector + main :: IO () main = defaultMain tests @@ -430,14 +441,18 @@   compositeTypeName = "composite"   compositeFields = Rel8.namesFromLabels +-- | Postgres doesn't support the NULL character (not to be confused with a NULL value) inside strings.+removeNull :: Text -> Text+removeNull = T.filter (/='\0') + testDBType :: IO TmpPostgres.DB -> TestTree testDBType getTestDatabase = testGroup "DBType instances"   [ dbTypeTest "Bool" Gen.bool   , dbTypeTest "ByteString" $ Gen.bytes (Range.linear 0 128)   , dbTypeTest "CalendarDiffTime" genCalendarDiffTime-  , 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 "CI Lazy Text" $ mk . Data.Text.Lazy.fromStrict . removeNull <$> Gen.text (Range.linear 0 10) Gen.unicode+  , dbTypeTest "CI Text" $ mk .removeNull <$> Gen.text (Range.linear 0 10) Gen.unicode   , dbTypeTest "Composite" genComposite   , dbTypeTest "Day" genDay   , dbTypeTest "Double" $ (/ 10) . fromIntegral @Int @Double <$> Gen.integral (Range.linear (-100) 100)@@ -446,14 +461,18 @@   , 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 "Lazy Text" $ Data.Text.Lazy.fromStrict . removeNull <$> 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 "Scientific" $ genScientific+  , dbTypeTest "Text" $ removeNull <$> 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   , dbTypeTest "INet" genNetAddrIP+  , dbTypeTest "INet" genIPRange+  , dbTypeTest "Value" genValue+  , dbTypeTest "JSONEncoded" genJSONEncoded+  , dbTypeTest "JSONBEncoded" genJSONBEncoded   ]    where@@ -509,7 +528,8 @@         diff res''''' (==) (concat xsss)        -      +    genScientific :: Gen Scientific+    genScientific = (/ 10) . fromIntegral @Int @Scientific <$> Gen.integral (Range.linear (-100) 100)      genComposite :: Gen Composite     genComposite = do@@ -568,7 +588,40 @@         in fromNetAddr46 <$> Gen.choice [ genIPv4, genIPv6 ] +    genIPRange :: Gen (Data.IP.IPRange)+    genIPRange =+      let+        genIP4Mask :: Gen Int+        genIP4Mask = Gen.integral (Range.linearFrom 0 0 32) +        genIPv4 :: Gen Data.IP.IPv4+        genIPv4 = Data.IP.toIPv4w <$> genWord32++        genIP6Mask :: Gen Int+        genIP6Mask = Gen.integral (Range.linearFrom 0 0 128)++        genIPv6 :: Gen (Data.IP.IPv6)+        genIPv6 = Data.IP.toIPv6w <$> ((,,,) <$> genWord32 <*> genWord32 <*> genWord32 <*> genWord32)++       in Gen.choice [ Data.IP.IPv4Range <$> (Data.IP.makeAddrRange <$> genIPv4 <*> genIP4Mask), Data.IP.IPv6Range <$> (Data.IP.makeAddrRange <$> genIPv6 <*> genIP6Mask)]++    genKey :: Gen Aeson.Key+    genKey = Aeson.Key.fromText <$> Gen.text (Range.linear 0 10) Gen.unicode++    genValue :: Gen Aeson.Value+    genValue = Gen.recursive Gen.choice+     [ pure Aeson.Null+     , Aeson.Bool <$> Gen.bool+     , Aeson.Number <$> genScientific+     , Aeson.String <$> Gen.text (Range.linear 0 10) Gen.unicode]+     [ Aeson.Object . Aeson.KeyMap.fromMap <$> Gen.map (Range.linear 0 10) ((,) <$> genKey <*> genValue)+     , Aeson.Array . Vector.fromList <$> Gen.list (Range.linear 0 10) genValue+     ]++    genJSONEncoded = Rel8.JSONEncoded <$> genValue+    genJSONBEncoded = Rel8.JSONBEncoded <$> genValue++ testDBEq :: IO TmpPostgres.DB -> TestTree testDBEq getTestDatabase = testGroup "DBEq instances"   [ dbEqTest "Bool" Gen.bool@@ -625,7 +678,14 @@         pure $ fromRational rational     diff result (~=) double   where-    a ~= b = abs (a - b) < 1e-15+    wholeDigits x = fromIntegral $ length $ show $ round x+    -- A Double gives us between 15-17 decimal digits of precision.+    -- It's tempting to say that two numbers are equal if they differ by less than 1e15.+    -- But this doesn't hold.+    -- The precision is split between the whole numer part and the decimal part of the number.+    -- For instance, a number between 10 and 99 only has around 13 digits of precision in its decimal part.+    -- Postgres and Haskell show differing amounts of digits in these cases,+    a ~= b = abs (a - b) < 10**(-15 + wholeDigits a)     infix 4 ~=