packages feed

rel8 1.4.0.0 → 1.4.1.0

raw patch · 22 files changed

+450/−156 lines, 22 filesdep ~basedep ~opaleye

Dependency ranges changed: base, opaleye

Files

Changelog.md view
@@ -1,4 +1,26 @@-# 1.4.0.0 (2002-08-17)+# 1.4.1.0 (2023-01-19)++## New features++* Rel8 now supports window functions. See the "Window functions" section of the `Rel8` module documentation for more details. ([#182](https://github.com/circuithub/rel8/pull/182))+* `Query` now has `Monoid` and `Semigroup` instances. ([#207](https://github.com/circuithub/rel8/pull/207))+* `createOrReplaceView` has been added (to run `CREATE OR REPLACE VIEW`). ([#209](https://github.com/circuithub/rel8/pull/209) and [#212](https://github.com/circuithub/rel8/pull/212))+* `deriving Rel8able` now supports more polymorphism. ([#215](https://github.com/circuithub/rel8/pull/215))+* Support GHC 9.4 ([#199](https://github.com/circuithub/rel8/pull/199))++## Bug fixes++* Insertion of `DEFAULT` values has been fixed. ([#206](https://github.com/circuithub/rel8/pull/206))+* Avoid some exponential SQL generation in `Rel8.Tabulate.alignWith`. ([#213](https://github.com/circuithub/rel8/pull/213))+* `nextVal` has been fixed to work with case-sensitive sequence names. ([#217](https://github.com/circuithub/rel8/pull/217))++## Other++* Correct the documentation for "Supplying `Rel8able` instances" ([#200](https://github.com/circuithub/rel8/pull/200))+* Removed some redundant internal code ([#202](https://github.com/circuithub/rel8/pull/202))+* Rel8 is now less dependant on the internal Opaleye API. ([#204](https://github.com/circuithub/rel8/pull/204))++# 1.4.0.0 (2022-08-17)  ## Breaking changes
rel8.cabal view
@@ -1,6 +1,6 @@ cabal-version:       2.0 name:                rel8-version:             1.4.0.0+version:             1.4.1.0 synopsis:            Hey! Hey! Can u rel8? license:             BSD3 license-file:        LICENSE@@ -20,14 +20,14 @@ library   build-depends:       aeson-    , base ^>= 4.14 || ^>=4.15 || ^>=4.16+    , base ^>= 4.14 || ^>=4.15 || ^>=4.16 || ^>=4.17     , bifunctors     , bytestring     , case-insensitive     , comonad     , contravariant     , hasql ^>= 1.4.5.1 || ^>= 1.5.0.0 || ^>= 1.6.0.0-    , opaleye ^>= 0.9.3.3+    , opaleye ^>= 0.9.6.1     , pretty     , profunctors     , product-profunctors@@ -82,6 +82,7 @@     Rel8.Expr.Order     Rel8.Expr.Sequence     Rel8.Expr.Serialize+    Rel8.Expr.Window      Rel8.FCF @@ -120,6 +121,7 @@     Rel8.Query.SQL     Rel8.Query.These     Rel8.Query.Values+    Rel8.Query.Window      Rel8.Schema.Context.Nullify     Rel8.Schema.Dict@@ -179,6 +181,7 @@     Rel8.Table.These     Rel8.Table.Transpose     Rel8.Table.Undefined+    Rel8.Table.Window      Rel8.Type     Rel8.Type.Array@@ -196,6 +199,9 @@     Rel8.Type.String     Rel8.Type.Sum     Rel8.Type.Tag++    Rel8.Window+  test-suite tests   type:             exitcode-stdio-1.0
src/Rel8.hs view
@@ -275,6 +275,26 @@   , nullsLast      -- ** Window functions+  , Window+  , window+  , Partition+  , over+  , partitionBy+  , orderPartitionBy+  , cumulative+  , cumulative_+  , currentRow+  , rowNumber+  , rank+  , denseRank+  , percentRank+  , cumeDist+  , ntile+  , lag+  , lead+  , firstValue+  , lastValue+  , nthValue   , indexed      -- ** Bindings@@ -314,6 +334,7 @@      -- ** @CREATE VIEW@   , createView+  , createOrReplaceView      -- ** Sequences   , nextval@@ -347,6 +368,7 @@ import Rel8.Expr.Serialize import Rel8.Expr.Sequence import Rel8.Expr.Text ( like, ilike )+import Rel8.Expr.Window hiding ( cumulative ) import Rel8.Generic.Rel8able ( KRel8able, Rel8able ) import Rel8.Order import Rel8.Query@@ -368,6 +390,7 @@ import Rel8.Query.Set import Rel8.Query.These import Rel8.Query.Values+import Rel8.Query.Window import Rel8.Schema.Field import Rel8.Schema.HTable import Rel8.Schema.Name@@ -403,6 +426,7 @@ import Rel8.Table.Serialize import Rel8.Table.These import Rel8.Table.Transpose+import Rel8.Table.Window import Rel8.Type import Rel8.Type.Composite import Rel8.Type.Eq@@ -417,6 +441,7 @@ import Rel8.Type.Semigroup import Rel8.Type.String import Rel8.Type.Sum+import Rel8.Window   -- $running
src/Rel8/Aggregate.hs view
@@ -2,7 +2,6 @@ {-# language FlexibleContexts #-} {-# language FlexibleInstances #-} {-# language MultiParamTypeClasses #-}-{-# language NamedFieldPuns #-} {-# language RankNTypes #-} {-# language StandaloneKindSignatures #-} {-# language TypeFamilies #-}@@ -10,7 +9,7 @@  module Rel8.Aggregate   ( Aggregate(..), zipOutputs-  , Aggregator(..), unsafeMakeAggregate+  , unsafeMakeAggregate   , Aggregates   ) where@@ -21,10 +20,13 @@ import Data.Kind ( Constraint, Type ) import Prelude +-- profunctors+import Data.Profunctor ( dimap )+ -- opaleye-import qualified Opaleye.Internal.Aggregate as Opaleye+import qualified Opaleye.Aggregate as Opaleye import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye-import qualified Opaleye.Internal.PackMap as Opaleye+import qualified Opaleye.Internal.Column as Opaleye  -- rel8 import Rel8.Expr ( Expr )@@ -69,23 +71,13 @@ zipOutputs f (Aggregate a) (Aggregate b) = Aggregate (liftA2 f a b)  -type Aggregator :: Type-data Aggregator = Aggregator-  { operation :: Opaleye.AggrOp-  , ordering :: [Opaleye.OrderExpr]-  , distinction :: Opaleye.AggrDistinct-  }---unsafeMakeAggregate :: forall (input :: Type) (output :: Type). ()+unsafeMakeAggregate :: forall (input :: Type) (output :: Type) n n' a a'. ()   => (Expr input -> Opaleye.PrimExpr)   -> (Opaleye.PrimExpr -> Expr output)-  -> Maybe Aggregator+  -> Opaleye.Aggregator (Opaleye.Field_ n a) (Opaleye.Field_ n' a')   -> 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)+  Aggregate $ dimap in_ out aggregator+  where out = output . Opaleye.unColumn+        in_ = Opaleye.Column . input . const expr
− src/Rel8/Aggregate.hs-boot 
@@ -1,11 +0,0 @@-{-# language PolyKinds #-}-{-# language RoleAnnotations #-}-{-# language StandaloneKindSignatures #-}--module Rel8.Aggregate where--import Data.Kind--type Aggregate :: k -> Type-type role Aggregate nominal-data Aggregate a
src/Rel8/Expr/Aggregate.hs view
@@ -24,10 +24,12 @@ import Prelude hiding ( and, max, min, null, or, sum )  -- opaleye-import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye+import qualified Opaleye.Internal.Aggregate as Opaleye+import Opaleye.Internal.Column ( Field_( Column ) )+import qualified Opaleye.Aggregate as Opaleye  -- rel8-import Rel8.Aggregate ( Aggregate, Aggregator(..), unsafeMakeAggregate )+import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate ) import Rel8.Expr ( Expr ) import Rel8.Expr.Bool ( caseExpr ) import Rel8.Expr.Opaleye@@ -51,23 +53,13 @@  -- | 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 = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.count  -- | 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-    }+  Opaleye.distinctAggregator Opaleye.count   -- | Corresponds to @COUNT(*)@.@@ -82,42 +74,22 @@  -- | Corresponds to @bool_and@. and :: Expr Bool -> Aggregate Bool-and = unsafeMakeAggregate toPrimExpr fromPrimExpr $-  Just Aggregator-    { operation = Opaleye.AggrBoolAnd-    , ordering = []-    , distinction = Opaleye.AggrAll-    }+and = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.boolAnd   -- | Corresponds to @bool_or@. or :: Expr Bool -> Aggregate Bool-or = unsafeMakeAggregate toPrimExpr fromPrimExpr $-  Just Aggregator-    { operation = Opaleye.AggrBoolOr-    , ordering = []-    , distinction = Opaleye.AggrAll-    }+or = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.boolOr   -- | 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-    }+max = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.unsafeMax   -- | 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-    }+min = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.unsafeMin  -- | Corresponds to @sum@. Note that in SQL, @sum@ is type changing - for -- example the @sum@ of @integer@ returns a @bigint@. Rel8 doesn't support@@ -125,12 +97,7 @@ -- 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-    }+sum = unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) Opaleye.unsafeSum   -- | Corresponds to @avg@. Note that in SQL, @avg@ is type changing - for@@ -139,13 +106,7 @@ -- need a fractional result on an integral column, you should cast your input -- to 'Double' or 'Data.Scientific.Scientific' before calling 'avg'. avg :: Sql DBSum a => Expr a -> Aggregate a-avg = unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) $-  Just Aggregator-    { operation = Opaleye.AggrAvg-    , ordering = []-    , distinction = Opaleye.AggrAll-    }-+avg = unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) Opaleye.unsafeAvg  -- | Take the sum of all expressions that satisfy a predicate. sumWhere :: (Sql DBNum a, Sql DBSum a)@@ -157,17 +118,12 @@ 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-      }+  unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) (Opaleye.stringAgg (Column (toPrimExpr delimiter)))   -- | Aggregate a value by grouping by it. groupByExpr :: Sql DBEq a => Expr a -> Aggregate a-groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Nothing+groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.groupBy   -- | Collect expressions values as a list.@@ -182,23 +138,13 @@  slistAggExpr :: ()   => TypeInformation (Unnullify a) -> Expr a -> Aggregate [a]-slistAggExpr info = unsafeMakeAggregate to fromPrimExpr $ Just-  Aggregator-    { operation = Opaleye.AggrArr-    , ordering = []-    , distinction = Opaleye.AggrAll-    }+slistAggExpr info = unsafeMakeAggregate to fromPrimExpr Opaleye.arrayAgg   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-    }+snonEmptyAggExpr info = unsafeMakeAggregate to fromPrimExpr Opaleye.arrayAgg   where     to = encodeArrayElement info . toPrimExpr
src/Rel8/Expr/Sequence.hs view
@@ -11,6 +11,7 @@ import Rel8.Expr ( Expr ) import Rel8.Expr.Function ( function ) import Rel8.Expr.Serialize ( litExpr )+import Rel8.Expr.Text ( quoteIdent )  -- text import Data.Text ( pack )@@ -18,4 +19,4 @@  -- | See https://www.postgresql.org/docs/current/functions-sequence.html nextval :: String -> Expr Int64-nextval = function "nextval" . litExpr . pack+nextval = function "nextval" . quoteIdent . litExpr . pack
+ src/Rel8/Expr/Window.hs view
@@ -0,0 +1,121 @@+module Rel8.Expr.Window+  ( cumulative+  , rowNumber+  , rank+  , denseRank+  , percentRank+  , cumeDist+  , ntile+  , lag+  , lead+  , firstValue+  , lastValue+  , nthValue+  )+where++-- base+import Data.Int ( Int32, Int64 )+import Prelude++-- opaleye+import qualified Opaleye.Internal.Aggregate as Opaleye+import qualified Opaleye.Internal.PackMap as Opaleye+import qualified Opaleye.Internal.Window as Opaleye+import qualified Opaleye.Window as Opaleye++-- profunctors+import Data.Profunctor (dimap)++-- rel8+import Rel8.Aggregate ( Aggregate( Aggregate ) )+import Rel8.Expr ( Expr )+import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr, toColumn, toPrimExpr )+import Rel8.Schema.Null ( Nullify )+import Rel8.Window ( Window( Window ) )+++cumulative :: (a -> Aggregate b) -> Window a (Expr b)+cumulative f =+  fromWindowFunction $ Opaleye.aggregatorWindowFunction (fromAggregate f) id+++-- | [@row_number()@](https://www.postgresql.org/docs/current/functions-window.html)+rowNumber :: Window a (Expr Int64)+rowNumber = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.rowNumber+++-- | [@rank()@](https://www.postgresql.org/docs/current/functions-window.html)+rank :: Window a (Expr Int64)+rank = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.rank+++-- | [@dense_rank()@](https://www.postgresql.org/docs/current/functions-window.html)+denseRank :: Window a (Expr Int64)+denseRank = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.denseRank+++-- | [@percent_rank()@](https://www.postgresql.org/docs/current/functions-window.html)+percentRank :: Window a (Expr Double)+percentRank = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.percentRank+++-- | [@cume_dist()@](https://www.postgresql.org/docs/current/functions-window.html)+cumeDist :: Window a (Expr Double)+cumeDist = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.cumeDist+++-- | [@ntile(num_buckets)@](https://www.postgresql.org/docs/current/functions-window.html)+ntile :: Expr Int32 -> Window a (Expr Int32)+ntile buckets = fromWindowFunction $ fromPrimExpr . fromColumn <$>+  Opaleye.ntile (toColumn (toPrimExpr buckets))+++-- | [@lag(value, offset, default)@](https://www.postgresql.org/docs/current/functions-window.html)+lag :: Expr Int32 -> Expr a -> Window (Expr a) (Expr a)+lag offset def =+  fromWindowFunction $+    dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $+      Opaleye.lag (toColumn (toPrimExpr offset)) (toColumn (toPrimExpr def))+++-- | [@lead(value, offset, default)@](https://www.postgresql.org/docs/current/functions-window.html)+lead :: Expr Int32 -> Expr a -> Window (Expr a) (Expr a)+lead offset def =+  fromWindowFunction $+    dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $+      Opaleye.lead (toColumn (toPrimExpr offset)) (toColumn (toPrimExpr def))+++-- | [@first_value(value)@](https://www.postgresql.org/docs/current/functions-window.html)+firstValue :: Window (Expr a) (Expr a)+firstValue =+  fromWindowFunction $+    dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn)+      Opaleye.firstValue+++-- | [@last_value(value)@](https://www.postgresql.org/docs/current/functions-window.html)+lastValue :: Window (Expr a) (Expr a)+lastValue =+  fromWindowFunction $+    dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn)+      Opaleye.lastValue+++-- | [@nth_value(value, n)@](https://www.postgresql.org/docs/current/functions-window.html)+nthValue :: Expr Int32 -> Window (Expr a) (Expr (Nullify a))+nthValue n =+  fromWindowFunction $+    dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $+      Opaleye.nthValue (toColumn (toPrimExpr n))+++fromAggregate :: (a -> Aggregate b) -> Opaleye.Aggregator a (Expr b)+fromAggregate f = Opaleye.Aggregator $ Opaleye.PackMap $ \w a -> case f a of+  Aggregate (Opaleye.Aggregator (Opaleye.PackMap x)) -> x w ()+++fromWindowFunction :: Opaleye.WindowFunction a b -> Window a b+fromWindowFunction (Opaleye.WindowFunction (Opaleye.PackMap w)) =+  Window $ Opaleye.Windows $ Opaleye.PackMap $ \f -> w $ \o -> f (o, mempty)
src/Rel8/Generic/Rel8able.hs view
@@ -63,6 +63,11 @@ -- This is almost 'Data.Type.Equality.==', but we add an extra case. type (==) :: k -> k -> Bool type family a == b where+  -- This extra case is needed to solve the equation "a == a" (where a is a+  -- KRel8able), which occurs when we have polymorphic Rel8ables+  -- (e.g., newtype T t f = T { x :: t a })+  (a :: KRel8able) == (a :: KRel8able) = 'True+   -- This extra case is needed to solve the equation "a == Identity a",    -- which occurs when we have polymorphic Rel8ables    -- (e.g., newtype T a f = T { x :: Column f a })@@ -141,7 +146,7 @@ -- [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+-- project. To do this, enable the @DeriveAnyClass@ and @DeriveGeneric@ language -- extensions: -- -- @
src/Rel8/Order.hs view
@@ -4,7 +4,6 @@  module Rel8.Order   ( Order(..)-  , toOrderExprs   ) where @@ -17,8 +16,7 @@ import Data.Functor.Contravariant.Divisible ( Decidable, Divisible )  -- opaleye-import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye-import qualified Opaleye.Internal.Order as Opaleye+import qualified Opaleye.Order as Opaleye   -- | An ordering expression for @a@. Primitive orderings are defined with@@ -30,8 +28,3 @@ 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
@@ -1,4 +1,6 @@+{-# language FlexibleContexts #-} {-# language StandaloneKindSignatures #-}+{-# language UndecidableInstances #-}  module Rel8.Query   ( Query( Query )@@ -20,10 +22,11 @@ import qualified Opaleye.Internal.Tag as Opaleye  -- rel8+import Rel8.Expr ( Expr ) import Rel8.Query.Set ( unionAll ) import Rel8.Query.Opaleye ( fromOpaleye ) import Rel8.Query.Values ( values )-import Rel8.Table ( fromColumns, toColumns )+import Rel8.Table ( Table, fromColumns, toColumns ) import Rel8.Table.Alternative   ( AltTable, (<|>:)   , AlternativeTable, emptyTable@@ -208,3 +211,13 @@ -- | 'emptyTable' = 'values' @[]@. instance AlternativeTable Query where   emptyTable = values []+++-- | '<>' = 'unionAll'.+instance Table Expr a => Semigroup (Query a) where+  (<>) = (<|>:)+++-- | 'mempty' = @'values' []@.+instance Table Expr a => Monoid (Query a) where+  mempty = emptyTable
src/Rel8/Query/Indexed.hs view
@@ -4,31 +4,18 @@ where  -- base+import Control.Applicative ( liftA2 ) import Data.Int ( Int64 ) import Prelude --- opaleye-import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye-import qualified Opaleye.Internal.PackMap as Opaleye-import qualified Opaleye.Internal.PrimQuery as Opaleye-import qualified Opaleye.Internal.QueryArr as Opaleye-import qualified Opaleye.Internal.Tag as Opaleye- -- rel8 import Rel8.Expr ( Expr )-import Rel8.Expr.Opaleye ( fromPrimExpr )+import Rel8.Expr.Window ( rowNumber ) import Rel8.Query ( Query )-import Rel8.Query.Opaleye ( mapOpaleye )+import Rel8.Query.Window ( window )+import Rel8.Table.Window ( currentRow )   -- | Pair each row of a query with its index within the query. indexed :: Query a -> Query (Expr Int64, a)-indexed = mapOpaleye $ \f -> Opaleye.stateQueryArr $ \_ tag ->-  let-    (a, query, tag') = Opaleye.runStateQueryArr f () tag-    tag'' = Opaleye.next tag'-    window = Opaleye.ConstExpr $ Opaleye.OtherLit "ROW_NUMBER() OVER () - 1"-    (index, bindings) = Opaleye.run $ Opaleye.extractAttr "index" tag' window-    query' = query <> Opaleye.aRebind bindings-  in-    ((fromPrimExpr index, a), query', tag'')+indexed = window (liftA2 (,) (subtract 1 <$> rowNumber) currentRow)
+ src/Rel8/Query/Window.hs view
@@ -0,0 +1,26 @@+module Rel8.Query.Window+  ( window+  )+where++-- base+import Prelude ()++-- opaleye+import qualified Opaleye.Window as Opaleye++-- rel8+import Rel8.Query ( Query )+import Rel8.Query.Opaleye ( mapOpaleye )+import Rel8.Window ( Window( Window ) )+++-- | 'window' runs a query composed of expressions containing+-- [window functions](https://www.postgresql.org/docs/current/tutorial-window.html).+-- 'window' is similar to 'Rel8.aggregate', with the main difference being+-- that in a window query, each input row corresponds to one output row,+-- whereas aggregation queries fold the entire input query down into a single+-- row. To put this into a Haskell context, 'Rel8.aggregate' is to 'foldl' as+-- 'window' is to 'scanl'.+window :: Window a b -> Query a -> Query b+window (Window a) = mapOpaleye (Opaleye.runWindows a)
src/Rel8/Schema/HTable.hs view
@@ -16,11 +16,12 @@ module Rel8.Schema.HTable   ( HTable (HField, HConstrainTable)   , hfield, htabulate, htraverse, hdicts, hspecs-  , hmap, htabulateA, htraverseP, htraversePWithField+  , hfoldMap, hmap, htabulateA, htraverseP, htraversePWithField   ) where  -- base+import Data.Functor.Const ( Const( Const ), getConst ) import Data.Kind ( Constraint, Type ) import Data.Functor.Compose ( Compose( Compose ), getCompose ) import Data.Proxy ( Proxy )@@ -117,6 +118,11 @@   {-# INLINABLE htraverse #-}   {-# INLINABLE hdicts #-}   {-# INLINABLE hspecs #-}+++hfoldMap :: (HTable t, Semigroup s)+  => (forall a. context a -> s) -> t context -> s+hfoldMap f a = getConst $ htraverse (Const . f) a   hmap :: HTable t
− src/Rel8/Schema/Name.hs-boot 
@@ -1,11 +0,0 @@-{-# 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
src/Rel8/Statement/Select.hs view
@@ -19,7 +19,6 @@ -- base import Data.Foldable ( toList ) import Data.Kind ( Type )-import Data.List.NonEmpty ( NonEmpty( (:|) ) ) import Data.Void ( Void ) import Prelude hiding ( undefined ) @@ -92,7 +91,7 @@ ppRows :: Table Expr a => Query a -> Doc ppRows query = case optimize primQuery of   -- Special case VALUES because we can't use DEFAULT inside a SELECT-  Optimized (Opaleye.Product ((_, Opaleye.Values symbols rows) :| []) [])+  Optimized (Opaleye.Values symbols rows)     | eqSymbols symbols (toList (T.exprs a)) ->         Opaleye.ppValues_ (map Opaleye.sqlExpr <$> toList rows)   _ -> ppSelect query@@ -120,7 +119,7 @@  type Optimized :: Type -> Type data Optimized a = Empty | Unit | Optimized a-  deriving stock (Functor, Foldable, Traversable)+  deriving stock (Functor, Foldable, Traversable, Show)   optimize :: Opaleye.PrimQuery' a -> Optimized (Opaleye.PrimQuery' Void)
src/Rel8/Statement/View.hs view
@@ -3,6 +3,7 @@  module Rel8.Statement.View   ( createView+  , createOrReplaceView   ) where @@ -29,25 +30,49 @@ import Data.Text.Encoding ( encodeUtf8 )  +data CreateView = Create | CreateOrReplace++ -- | 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 -> Hasql.Statement () ()-createView schema query = Hasql.Statement bytes params decode prepare+createView =+  createViewGeneric Create+++-- | Given a 'TableSchema' and 'Query', @createOrReplaceView@ runs a+-- @CREATE OR REPLACE VIEW@ statement that will save the given query+-- as a view, replacing the current view definition if it exists and+-- adheres to the restrictions in place for replacing a view in+-- PostgreSQL.+createOrReplaceView :: Selects names exprs+  => TableSchema names -> Query exprs -> Hasql.Statement () ()+createOrReplaceView =+  createViewGeneric CreateOrReplace+++createViewGeneric :: Selects names exprs+  => CreateView -> TableSchema names -> Query exprs -> Hasql.Statement () ()+createViewGeneric replace schema query =+  Hasql.Statement bytes params decode prepare   where     bytes = encodeUtf8 (Text.pack sql)     params = Hasql.noParams     decode = Hasql.noResult     prepare = False     sql = show doc-    doc = ppCreateView schema query+    doc = ppCreateView schema query replace   ppCreateView :: Selects names exprs-  => TableSchema names -> Query exprs -> Doc-ppCreateView schema query =-  text "CREATE VIEW" <+>+  => TableSchema names -> Query exprs -> CreateView -> Doc+ppCreateView schema query replace =+  createOrReplace replace <+>   ppInto schema $$   text "AS" <+>   ppSelect query+  where+    createOrReplace Create = text "CREATE VIEW"+    createOrReplace CreateOrReplace = text "CREATE OR REPLACE VIEW"
src/Rel8/Table/Opaleye.hs view
@@ -35,7 +35,6 @@ import qualified Opaleye.Field as Opaleye ( Field_ ) import qualified Opaleye.Internal.Aggregate as Opaleye import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye-import qualified Opaleye.Internal.PackMap as Opaleye import qualified Opaleye.Internal.Values as Opaleye import qualified Opaleye.Table as Opaleye
+ src/Rel8/Table/Window.hs view
@@ -0,0 +1,43 @@+{-# language MonoLocalBinds #-}++module Rel8.Table.Window+  ( cumulative+  , cumulative_+  , currentRow+  )+where++-- base+import Prelude++-- opaleye+import qualified Opaleye.Window as Opaleye++-- rel8+import Rel8.Aggregate ( Aggregates )+import qualified Rel8.Expr.Window as Expr+import Rel8.Schema.HTable ( hfield, htabulateA )+import Rel8.Table ( fromColumns, toColumns )+import Rel8.Window ( Window( Window ) )+++-- | 'cumulative' allows the use of aggregation functions in 'Window'+-- expressions. In particular, @'cumulative' 'Rel8.sum'@+-- (when combined with 'Rel8.Window.orderPartitionBy') gives a running total,+-- also known as a \"cumulative sum\", hence the name @cumulative@.+cumulative :: Aggregates aggregates exprs => (a -> aggregates) -> Window a exprs+cumulative f =+  fmap fromColumns $+    htabulateA $ \field ->+      Expr.cumulative ((`hfield` field) . toColumns . f)+++-- | A version of 'cumulative' for use with nullary aggregators like+-- 'Rel8.Expr.Aggregate.countStar'.+cumulative_ :: Aggregates aggregates exprs => aggregates -> Window a exprs+cumulative_ = cumulative . const+++-- | Return every column of the current row of a window query.+currentRow :: Window a a+currentRow = Window $ Opaleye.over (Opaleye.noWindowFunction id) mempty mempty
src/Rel8/Tabulate.hs view
@@ -93,6 +93,7 @@ import Rel8.Query.List ( catNonEmptyTable ) import qualified Rel8.Query.Maybe as Q ( optional ) import Rel8.Query.Opaleye ( mapOpaleye, unsafePeekQuery )+import Rel8.Query.Rebind ( rebind ) import Rel8.Query.These ( alignBy ) import Rel8.Table ( Table, fromColumns, toColumns ) import Rel8.Table.Aggregate ( hgroupBy, listAgg, nonEmptyAgg )@@ -508,8 +509,8 @@   -> Tabulation k a -> Tabulation k b -> Tabulation k c alignWith f (Tabulation as) (Tabulation bs) = Tabulation $ \p -> do   tkab <- liftF2 (alignBy condition) as bs p+  k <- traverse (rebind "key") $ recover $ bimap fst fst tkab   let-    k = recover $ bimap fst fst tkab     tab = bimap snd snd tkab   pure (k, f tab)   where
+ src/Rel8/Window.hs view
@@ -0,0 +1,97 @@+{-# language DerivingVia #-}+{-# language FlexibleContexts #-}+{-# language GeneralizedNewtypeDeriving #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeApplications #-}++module Rel8.Window+  ( Window(..)+  , Partition+  , over+  , partitionBy+  , orderPartitionBy+  )+where++-- base+import Data.Functor.Const ( Const( Const ), getConst )+import Data.Functor.Contravariant ( Contravariant, contramap )+import Data.Kind ( Type )+import Prelude++-- opaleye+import qualified Opaleye.Internal.Window as Opaleye+import qualified Opaleye.Internal.PackMap as Opaleye++-- profunctors+import Data.Profunctor ( Profunctor )++-- product-profunctors+import Data.Profunctor.Product ( ProductProfunctor, (****), purePP )++-- rel8+import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )+import Rel8.Order( Order( Order ) )+import Rel8.Schema.HTable ( hfield, htabulateA )+import Rel8.Table ( Columns, toColumns )+import Rel8.Table.Eq ( EqTable )++-- semigroupoids+import Data.Functor.Apply ( Apply, WrappedApplicative(..) )+++-- | 'Window' is an applicative functor that represents expressions that+-- contain+-- [window functions](https://www.postgresql.org/docs/current/tutorial-window.html).+-- 'Rel8.Query.Window.window' can be used to+-- evaluate these expressions over a particular query.+type Window :: Type -> Type -> Type+newtype Window a b = Window (Opaleye.Windows a b)+  deriving newtype (Profunctor)+  deriving newtype (Functor, Applicative)+  deriving (Apply) via (WrappedApplicative (Window a))+++instance ProductProfunctor Window where+  purePP = pure+  (****) = (<*>)+++-- | In PostgreSQL, window functions must specify the \"window\" or+-- \"partition\" over which they operate. The syntax for this looks like:+-- @SUM(salary) OVER (PARTITION BY department)@. The Rel8 type 'Partition'+-- represents everything that comes after @OVER@.+--+-- 'Partition' is a 'Monoid', so 'Window's created with 'partitionBy' and+-- 'orderWindowBy' can be combined using '<>'.+type Partition :: Type -> Type+newtype Partition a = Partition (Opaleye.Window a)+  deriving newtype (Contravariant, Semigroup, Monoid)+++-- | 'over' adds a 'Partition' to a 'Window' expression.+--+-- @@@+-- '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 ->+    w (\(o, p') -> f (o, p' <> p))+infixl 1 `over`+++-- | Restricts a window function to operate only the group of rows that share+-- the same value(s) for the given expression(s).+partitionBy :: forall b a. EqTable b => (a -> b) -> Partition a+partitionBy f =+  Partition $ contramap (toColumns . f) $ getConst $+    htabulateA @(Columns b) $ \field ->+      Const $ Opaleye.partitionBy (toColumn . toPrimExpr . (`hfield` field))+++-- | Controls the order in which rows are processed by window functions. This+-- does not need to match the ordering of the overall query.+orderPartitionBy :: Order a -> Partition a+orderPartitionBy (Order ordering) = Partition $ Opaleye.orderPartitionBy ordering
tests/Rel8/Generic/Rel8able/Test.hs view
@@ -5,6 +5,7 @@ {-# language DuplicateRecordFields #-} {-# language FlexibleInstances #-} {-# language MultiParamTypeClasses #-}+{-# language StandaloneKindSignatures #-} {-# language TypeFamilies #-} {-# language UndecidableInstances #-} @@ -171,9 +172,17 @@   deriving anyclass Rel8able  - newtype IdRecord a f = IdRecord { recordId :: Column f a }   deriving stock Generic   instance DBType a => Rel8able (IdRecord a)+++type Nest :: KRel8able -> KRel8able -> KRel8able+data Nest t u f = Nest+  { foo :: t f+  , bar :: u f+  }+  deriving stock Generic+  deriving anyclass Rel8able