opaleye 0.9.3.2 → 0.9.3.3

raw patch · 20 files changed

+509/−144 lines, 20 filesdep ~basedep ~textPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• opaleye.cabal +4/−2
• src/Opaleye.hs +2/−0
• src/Opaleye/Internal/Aggregate.hs +8/−0
• src/Opaleye/Internal/Column.hs +1/−1
• src/Opaleye/Internal/HaskellDB/PrimQuery.hs +22/−0
• src/Opaleye/Internal/HaskellDB/Sql.hs +8/−0
• src/Opaleye/Internal/HaskellDB/Sql/Default.hs +45/−22
• src/Opaleye/Internal/HaskellDB/Sql/Print.hs +17/−1
• src/Opaleye/Internal/MaybeFields.hs +1/−4
• src/Opaleye/Internal/Optimize.hs +1/−0
• src/Opaleye/Internal/Order.hs +0/−1
• src/Opaleye/Internal/PrimQuery.hs +5/−0
• src/Opaleye/Internal/QueryArr.hs +6/−1
• src/Opaleye/Internal/RunQuery.hs +1/−1
• src/Opaleye/Internal/Sql.hs +7/−0
• src/Opaleye/Internal/Values.hs +158/−106
• src/Opaleye/Internal/Window.hs +119/−0
• src/Opaleye/Values.hs +5/−5
• src/Opaleye/Window.hs +93/−0

@@ -1,3 +1,9 @@+## 0.9.3.3++* No externally visible changes++* Substantial internal changes to `Opaleye.Values`+ ## 0.9.3.2  * No externally visible changes

@@ -1,6 +1,6 @@ name:            opaleye copyright:       Copyright (c) 2014-2018 Purely Agile Limited; 2019-2022 Tom Ellis-version:         0.9.3.2+version:         0.9.3.3 synopsis:        An SQL-generating DSL targeting PostgreSQL description:     An SQL-generating DSL targeting PostgreSQL.  Allows                  Postgres queries to be written within Haskell in a@@ -70,6 +70,7 @@                    Opaleye.TypeFamilies,                    Opaleye.Values,                    Opaleye.With,+                   Opaleye.Window,                    Opaleye.Internal.Aggregate,                    Opaleye.Internal.Binary,                    Opaleye.Internal.Constant,@@ -102,7 +103,8 @@                    Opaleye.Internal.Tag,                    Opaleye.Internal.TypeFamilies,                    Opaleye.Internal.Unpackspec,-                   Opaleye.Internal.Values+                   Opaleye.Internal.Values,+                   Opaleye.Internal.Window,                    Opaleye.Internal.HaskellDB.PrimQuery,                    Opaleye.Internal.HaskellDB.Sql,                    Opaleye.Internal.HaskellDB.Sql.Default,

@@ -37,6 +37,7 @@                , module Opaleye.ToFields                , module Opaleye.Values                , module Opaleye.With+               , module Opaleye.Window                ) where  import Opaleye.Adaptors@@ -62,4 +63,5 @@ import Opaleye.Table import Opaleye.ToFields import Opaleye.Values+import Opaleye.Window import Opaleye.With

@@ -88,6 +88,14 @@   -> a -> f b runAggregator (Aggregator a) = PM.traversePM a +-- For rel8.+--+-- Like https://www.stackage.org/haddock/lts-19.10/base-4.15.1.0/Control-Arrow.html#t:ArrowApply+aggregatorApply :: Aggregator (Aggregator a b, a) b+aggregatorApply = Aggregator $ PM.PackMap $ \f (agg, a) ->+  case agg of+    Aggregator (PM.PackMap inner) -> inner f a+ -- In Postgres (and, I believe, standard SQL) "aggregate functions are -- not allowed in FROM clause of their own query level".  There -- doesn't seem to be any fundamental reason for this, but we are

@@ -44,7 +44,7 @@ -- | Cast a column to any other type. Implements Postgres's @::@ or -- @CAST( ... AS ... )@ operations.  This is safe for some -- conversions, such as uuid to text.-unsafeCast :: String -> Field_ n' a -> Field_ n' b+unsafeCast :: String -> Field_ n a -> Field_ n b unsafeCast = mapColumn . HPQ.CastExpr   where     mapColumn :: (HPQ.PrimExpr -> HPQ.PrimExpr) -> Field_ n c -> Field_ n' a

@@ -23,6 +23,7 @@                 | BinExpr   BinOp PrimExpr PrimExpr                 | UnExpr    UnOp PrimExpr                 | AggrExpr  AggrDistinct AggrOp PrimExpr [OrderExpr]+                | WndwExpr  WndwOp Partition                 | ConstExpr Literal                 | CaseExpr [(PrimExpr,PrimExpr)] PrimExpr                 | ListExpr (NEL.NonEmpty PrimExpr)@@ -101,3 +102,24 @@  data BoundExpr = Inclusive PrimExpr | Exclusive PrimExpr | PosInfinity | NegInfinity                  deriving (Show,Read)++data WndwOp+  = WndwRowNumber+  | WndwRank+  | WndwDenseRank+  | WndwPercentRank+  | WndwCumeDist+  | WndwNtile PrimExpr+  | WndwLag PrimExpr PrimExpr PrimExpr+  | WndwLead PrimExpr PrimExpr PrimExpr+  | WndwFirstValue PrimExpr+  | WndwLastValue PrimExpr+  | WndwNthValue PrimExpr PrimExpr+  | WndwAggregate AggrOp PrimExpr+  deriving (Show,Read)++data Partition = Partition+  { partitionBy :: [PrimExpr]+  , orderBy :: [OrderExpr]+  }+  deriving (Read, Show)

@@ -31,6 +31,13 @@                          , sqlOrderNulls     :: SqlOrderNulls }   deriving Show ++data SqlPartition = SqlPartition+  { sqlPartitionBy :: [SqlExpr]+  , sqlOrderBy :: [(SqlExpr, SqlOrder)]+  }+  deriving Show+ data SqlRangeBound = Inclusive SqlExpr | Exclusive SqlExpr | PosInfinity | NegInfinity                    deriving Show @@ -46,6 +53,7 @@              | PostfixSqlExpr String SqlExpr              | FunSqlExpr     String [SqlExpr]              | AggrFunSqlExpr String [SqlExpr] [(SqlExpr, SqlOrder)] SqlDistinct -- ^ Aggregate functions separate from normal functions.+             | WndwFunSqlExpr String [SqlExpr] SqlPartition              | ConstSqlExpr   String              | CaseSqlExpr    (NEL.NonEmpty (SqlExpr,SqlExpr)) SqlExpr              | ListSqlExpr    (NEL.NonEmpty SqlExpr)

@@ -50,6 +50,13 @@             PQ.NullsLast  -> Sql.SqlNullsLast  +toSqlPartition :: SqlGenerator -> Partition -> SqlPartition+toSqlPartition gen (Partition partition order) = SqlPartition+  { sqlPartitionBy = map (sqlExpr gen) partition+  , sqlOrderBy = map (toSqlOrder gen) order+  }++ toSqlColumn :: Attribute -> SqlColumn toSqlColumn = SqlColumn @@ -129,16 +136,15 @@       -- because it leads to a non-uniformity of treatment, as seen       -- below.  Perhaps we should have just `AggrExpr AggrOp` and       -- always put the `PrimExpr` in the `AggrOp`.-      AggrExpr distinct op e ord -> let op' = showAggrOp op-                                        e' = sqlExpr gen e+      AggrExpr distinct op e ord -> let (op', e') = showAggrOp gen op e                                         ord' = toSqlOrder gen <$> ord                                         distinct' = case distinct of                                                       AggrDistinct -> SqlDistinct                                                       AggrAll      -> SqlNotDistinct-                                        moreAggrFunParams = case op of-                                          AggrStringAggr primE -> [sqlExpr gen primE]-                                          _ -> []-                                     in AggrFunSqlExpr op' (e' : moreAggrFunParams) ord' distinct'+                                     in AggrFunSqlExpr op' e' ord' distinct'+      WndwExpr op window  -> let (op', e') = showWndwOp gen op+                                 window' = toSqlPartition gen window+                              in WndwFunSqlExpr op' e' window'       ConstExpr l      -> ConstSqlExpr (sqlLiteral gen l)       CaseExpr cs e    -> let cs' = [(sqlExpr gen c, sqlExpr gen x)| (c,x) <- cs]                               e'  = sqlExpr gen e@@ -214,22 +220,39 @@ sqlUnOp  (UnOpOther s) = (s, UnOpFun)  -showAggrOp :: AggrOp -> String-showAggrOp AggrCount          = "COUNT"-showAggrOp AggrSum            = "SUM"-showAggrOp AggrAvg            = "AVG"-showAggrOp AggrMin            = "MIN"-showAggrOp AggrMax            = "MAX"-showAggrOp AggrStdDev         = "StdDev"-showAggrOp AggrStdDevP        = "StdDevP"-showAggrOp AggrVar            = "Var"-showAggrOp AggrVarP           = "VarP"-showAggrOp AggrBoolAnd        = "BOOL_AND"-showAggrOp AggrBoolOr         = "BOOL_OR"-showAggrOp AggrArr            = "ARRAY_AGG"-showAggrOp JsonArr            = "JSON_AGG"-showAggrOp (AggrStringAggr _) = "STRING_AGG"-showAggrOp (AggrOther s)      = s+showAggrOp :: SqlGenerator -> AggrOp -> PrimExpr -> (String, [SqlExpr])+showAggrOp gen op arg = case op of+  AggrCount -> ("COUNT", [sqlExpr gen arg])+  AggrSum -> ("SUM", [sqlExpr gen arg])+  AggrAvg -> ("AVG", [sqlExpr gen arg])+  AggrMin -> ("MIN", [sqlExpr gen arg])+  AggrMax -> ("MAX", [sqlExpr gen arg])+  AggrStdDev -> ("StdDev", [sqlExpr gen arg])+  AggrStdDevP -> ("StdDevP", [sqlExpr gen arg])+  AggrVar -> ("Var", [sqlExpr gen arg])+  AggrVarP -> ("VarP", [sqlExpr gen arg])+  AggrBoolAnd -> ("BOOL_AND", [sqlExpr gen arg])+  AggrBoolOr -> ("BOOL_OR", [sqlExpr gen arg])+  AggrArr -> ("ARRAY_AGG", [sqlExpr gen arg])+  JsonArr -> ("JSON_AGG", [sqlExpr gen arg])+  AggrStringAggr sep -> ("STRING_AGG", [sqlExpr gen arg, sqlExpr gen sep])+  AggrOther s -> (s, [sqlExpr gen arg])+++showWndwOp :: SqlGenerator -> WndwOp -> (String, [SqlExpr])+showWndwOp gen op = case op of+  WndwRowNumber -> ("ROW_NUMBER", [])+  WndwRank -> ("RANK", [])+  WndwDenseRank -> ("DENSE_RANK", [])+  WndwPercentRank -> ("PERCENT_RANK", [])+  WndwCumeDist -> ("CUME_DIST", [])+  WndwNtile e -> ("NTILE", [sqlExpr gen e])+  WndwLag e offset def -> ("LAG", map (sqlExpr gen) [e, offset, def])+  WndwLead e offset def -> ("LEAD", map (sqlExpr gen) [e, offset, def])+  WndwFirstValue e -> ("FIRST_VALUE", [sqlExpr gen e])+  WndwLastValue e -> ("LAST_VALUE", [sqlExpr gen e])+  WndwNthValue e n -> ("NTH_VALUE", map (sqlExpr gen) [e, n])+  WndwAggregate op' arg -> showAggrOp gen op' arg   defaultSqlLiteral :: SqlGenerator -> Literal -> String

@@ -24,7 +24,7 @@ import Opaleye.Internal.HaskellDB.Sql (SqlColumn(..), SqlDelete(..),                                SqlExpr(..), SqlOrder(..), SqlInsert(..),                                SqlUpdate(..), SqlTable(..), SqlRangeBound(..),-                               OnConflict(..))+                               SqlPartition(..), OnConflict(..)) import qualified Opaleye.Internal.HaskellDB.Sql as Sql  import Data.List (intersperse)@@ -55,6 +55,21 @@     ppGroupAttrs :: [SqlExpr] -> Doc     ppGroupAttrs = commaV (ppSqlExpr . deliteral) +ppWindowExpr :: String -> [SqlExpr] -> SqlPartition -> Doc+ppWindowExpr f es partition = text f <> parens (commaH ppSqlExpr es) <+> text "OVER" <+> parens (ppSqlPartition partition)++ppSqlPartition :: SqlPartition -> Doc+ppSqlPartition partition =+  ppPartitionBy (sqlPartitionBy partition) <+>+  ppOrderBy (sqlOrderBy partition)++ppPartitionBy :: [SqlExpr] -> Doc+ppPartitionBy [] = empty+ppPartitionBy es = text "PARTITION BY" <+> ppPartitionAttrs es+  where+    ppPartitionAttrs :: [SqlExpr] -> Doc+    ppPartitionAttrs = commaH (ppSqlExpr . deliteral)+ ppOrderBy :: [(SqlExpr,SqlOrder)] -> Doc ppOrderBy [] = empty ppOrderBy ord = text "ORDER BY" <+> commaV ppOrd ord@@ -177,6 +192,7 @@       ArraySqlExpr es        -> text "ARRAY" <> brackets (commaH ppSqlExpr es)       RangeSqlExpr t s e     -> ppRange t s e       AggrFunSqlExpr f es ord distinct -> text f <> parens (ppSqlDistinct distinct <+> commaH ppSqlExpr es <+> ppOrderBy ord)+      WndwFunSqlExpr f es window -> ppWindowExpr f es window       CaseSqlExpr cs el   -> text "CASE" <+> vcat (toList (fmap ppWhen cs))                              <+> text "ELSE" <+> ppSqlExpr el <+> text "END"           where ppWhen (w,t) = text "WHEN" <+> ppSqlExpr w

@@ -288,10 +288,7 @@ withNullsField col = result   where result = WithNulls (P.lmap (\(MaybeFields b c) ->                                       ifExplict PP.def b c nullC) col)-        nullC = IC.Column (V.nullPE (columnProxy result))--        columnProxy :: f (IC.Field_ n sqlType) -> Maybe sqlType-        columnProxy _ = Nothing+        nullC = V.nullFields V.nullspecField  binaryspecMaybeFields   :: WithNulls B.Binaryspec a b

@@ -53,6 +53,7 @@                    \x y -> PQ.Product <$> sequenceOf (traverse._2) x                                       <*> pure y   , PQ.aggregate = fmap . PQ.Aggregate+  , PQ.window    = fmap . PQ.Window   , PQ.distinctOnOrderBy = \mDistinctOns -> fmap . PQ.DistinctOnOrderBy mDistinctOns   , PQ.limit     = fmap . PQ.Limit   , PQ.join      = \jt pe pq1 pq2 -> PQ.Join jt pe <$> sequence pq1 <*> sequence pq2

@@ -14,7 +14,6 @@ import qualified Opaleye.Internal.Column              as IC import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ import qualified Opaleye.Internal.PrimQuery           as PQ-import qualified Opaleye.Internal.Tag                 as T import qualified Opaleye.Internal.Unpackspec          as U  {-|

@@ -133,6 +133,7 @@                                                 HPQ.AggrDistinct),                                           HPQ.Symbol))                               (PrimQuery' a)+                  | Window (Bindings (HPQ.WndwOp, HPQ.Partition)) (PrimQuery' a)                   -- | Represents both @DISTINCT ON@ and @ORDER BY@                   --   clauses. In order to represent valid SQL only,                   --   @DISTINCT ON@ expressions are always@@ -180,6 +181,7 @@                                    HPQ.Symbol)                       -> p                       -> p'+  , window            :: Bindings (HPQ.WndwOp, HPQ.Partition) -> p -> p'   , distinctOnOrderBy :: Maybe (NEL.NonEmpty HPQ.PrimExpr)                       -> [HPQ.OrderExpr]                       -> p@@ -212,6 +214,7 @@   , baseTable         = BaseTable   , product           = Product   , aggregate         = Aggregate+  , window            = Window   , distinctOnOrderBy = DistinctOnOrderBy   , limit             = Limit   , join              = Join@@ -236,6 +239,7 @@   , baseTable = \ti bs -> g (baseTable f ti bs)   , product = \ps conds -> g (product f ((fmap . fmap) self ps) conds)   , aggregate = \b p -> g (aggregate f b (self p))+  , window = \b p -> g (window f b (self p))   , distinctOnOrderBy = \m os p -> g (distinctOnOrderBy f m os (self p))   , limit = \l p -> g (limit f l (self p))   , join = \j pe lp lp' -> g (join f j pe (fmap self lp) (fmap self lp'))@@ -258,6 +262,7 @@   BaseTable ti syms -> baseTable f ti syms   Product qs pes -> product f qs pes   Aggregate aggrs q -> aggregate f aggrs q+  Window wndws q -> window f wndws q   DistinctOnOrderBy dxs oxs q -> distinctOnOrderBy f dxs oxs q   Limit op q -> limit f op q   Join j cond q1 q2 -> join f j cond q1 q2

@@ -19,7 +19,7 @@ import qualified Control.Category as C import           Control.Category ((<<<), id) import           Control.Applicative (Applicative, pure, (<*>))-import           Control.Monad.Trans.State.Strict (State, runState, state)+import           Control.Monad.Trans.State.Strict (State, evalState, runState, state) import qualified Data.Profunctor as P import qualified Data.Profunctor.Product as PP import           Data.Semigroup ((<>))@@ -75,10 +75,15 @@   let (b, pq, tag') = f a tag   in ((b, pq), tag') +-- This is used by Rel8, but at some point it should switch to+-- runSimpleSelectStart runSimpleQueryArrStart :: QueryArr a b -> a -> (b, PQ.PrimQuery, Tag) runSimpleQueryArrStart q a =   let ((b, pqa), t') = runState (runSimpleQueryArr' q a) Tag.start   in (b, pqa, t')++runSimpleSelectStart :: Select a -> (a, PQ.PrimQuery)+runSimpleSelectStart = flip evalState Tag.start . runSimpleSelect  runQueryArrUnpack :: U.Unpackspec a b                   -> Query a -> ([HPQ.PrimExpr], PQ.PrimQuery, Tag)

@@ -433,5 +433,5 @@   where sql :: Maybe PGS.Query         sql = fmap String.fromString (S.showSqlExplicit u q)         -- FIXME: We're doing work twice here-        (b, _, _) = Q.runSimpleQueryArrStart q ()+        (b, _) = Q.runSimpleSelectStart q         parser = prepareRowParser qr b

@@ -111,6 +111,7 @@   , PQ.baseTable         = baseTable   , PQ.product           = product   , PQ.aggregate         = aggregate+  , PQ.window            = window   , PQ.distinctOnOrderBy = distinctOnOrderBy   , PQ.limit             = limit_   , PQ.join              = join@@ -204,6 +205,12 @@  aggrExpr :: Maybe (HPQ.AggrOp, [HPQ.OrderExpr], HPQ.AggrDistinct) -> HPQ.PrimExpr -> HPQ.PrimExpr aggrExpr = maybe id (\(op, ord, distinct) e -> HPQ.AggrExpr distinct op e ord)++window :: PQ.Bindings (HPQ.WndwOp, HPQ.Partition) -> Select -> Select+window wndws' s = SelectFrom $ newSelect+  { attrs = SelectAttrsStar (ensureColumns (map (sqlBinding . fmap (uncurry HPQ.WndwExpr)) wndws'))+  , tables = oneTable s+  }  distinctOnOrderBy :: Maybe (NEL.NonEmpty HPQ.PrimExpr) -> [HPQ.OrderExpr] -> Select -> Select distinctOnOrderBy distinctExprs orderExprs s = SelectFrom $ newSelect

@@ -1,115 +1,80 @@+{-# LANGUAGE Arrows #-} {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}  module Opaleye.Internal.Values where  import           Opaleye.Internal.Column (Field_(Column))+import qualified Opaleye.Internal.Column as C+import qualified Opaleye.Column as OC import qualified Opaleye.Internal.Unpackspec as U import qualified Opaleye.Internal.Tag as T+import qualified Opaleye.Internal.Operators as O import qualified Opaleye.Internal.PrimQuery as PQ import qualified Opaleye.Internal.PackMap as PM+import qualified Opaleye.Internal.QueryArr as Q import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ import qualified Opaleye.Internal.PGTypes import qualified Opaleye.SqlTypes -import           Data.Functor.Identity (runIdentity)+import           Control.Arrow (returnA)+import qualified Control.Monad.Trans.State.Strict as State import qualified Data.List.NonEmpty as NEL import           Data.Profunctor (Profunctor, dimap, rmap, lmap) import           Data.Profunctor.Product (ProductProfunctor) import qualified Data.Profunctor.Product as PP import           Data.Profunctor.Product.Default (Default, def)-import           Data.Void (Void, absurd)--import           Control.Applicative (Applicative, pure, (<*>))---- FIXME: We don't currently handle the case of zero columns.  Need to--- emit a dummy column and data.-valuesU :: U.Unpackspec columns columns'-        -> ValuesspecUnsafe columns columns'-        -> [columns]-        -> ((), T.Tag) -> (columns', PQ.PrimQuery)-valuesU unpack valuesspec rows ((), t) = (newColumns, primQ')-  where runRow row = valuesRow-           where (_, valuesRow) =-                   PM.run (U.runUnpackspec unpack extractValuesEntry row)--        (newColumns, valuesPEs_nulls) =-          PM.run (runValuesspec valuesspec (extractValuesField t))--        valuesPEs = map fst valuesPEs_nulls--        values :: [[HPQ.PrimExpr]]-        values = map runRow rows--        primQ' = case NEL.nonEmpty values of-          Nothing      -> PQ.Empty ()-          Just values' -> PQ.Values valuesPEs values'---- We don't actually use the return value of this.  It might be better--- to come up with another Applicative instance for specifically doing--- what we need.-extractValuesEntry :: HPQ.PrimExpr -> PM.PM [HPQ.PrimExpr] HPQ.PrimExpr-extractValuesEntry pe = do-  PM.write pe-  return pe--extractValuesField :: T.Tag -> primExpr-                   -> PM.PM [(HPQ.Symbol, primExpr)] HPQ.PrimExpr-extractValuesField = PM.extractAttr "values"--newtype ValuesspecUnsafe columns columns' =-  Valuesspec (PM.PackMap () HPQ.PrimExpr () columns')--runValuesspec :: Applicative f => ValuesspecUnsafe columns columns'-              -> (() -> f HPQ.PrimExpr) -> f columns'-runValuesspec (Valuesspec v) f = PM.traversePM v f ()+import           Data.Semigroup (Semigroup, (<>)) -instance Default ValuesspecUnsafe (Field_ n a) (Field_ n a) where-  def = Valuesspec (PM.iso id Column)+import           Control.Applicative (Applicative, pure, (<*>), liftA2) -valuesUSafe :: Valuesspec columns columns'-            -> [columns]-            -> ((), T.Tag) -> (columns', PQ.PrimQuery)-valuesUSafe valuesspec@(ValuesspecSafe _ unpack) rows ((), t) =-  (newColumns, primQ')-  where runRow row =-          case PM.run (U.runUnpackspec unpack extractValuesEntry row) of-            (_, []) -> [zero]-            (_, xs) -> xs+nonEmptyValues :: Rowspec columns columns'+               -> NEL.NonEmpty columns+               -> Q.Select columns'+nonEmptyValues rowspec rows =+  let nerowspec' = case rowspec of+        NonEmptyRows nerowspec -> nerowspec+        EmptyRows fields ->+          dimap (const zero) (const fields) nonEmptyRowspecField+          where zero = 0 :: C.Field Opaleye.SqlTypes.SqlInt4+  in nonEmptyRows nerowspec' rows -        (newColumns, valuesPEs_nulls) =-          PM.run (runValuesspecSafe valuesspec (extractValuesField t))+nonEmptyRows :: NonEmptyRowspec fields fields'+             -> NEL.NonEmpty fields+             -> Q.Select fields'+nonEmptyRows (NonEmptyRowspec runRow fields) rows =+  Q.productQueryArr $ do+    (valuesPEs, newColumns) <- fields+    pure (newColumns, PQ.Values (NEL.toList valuesPEs) (fmap (NEL.toList . runRow) rows)) -        valuesPEs = map fst valuesPEs_nulls-        nulls = case map snd valuesPEs_nulls of-          []     -> [nullInt]-          nulls' -> nulls'+emptySelectExplicit :: Nullspec columns a -> Q.Select a+emptySelectExplicit nullspec = proc () -> do+  O.restrict -< Opaleye.SqlTypes.sqlBool False+  returnA -< nullFields nullspec -        yieldNoRows :: PQ.PrimQuery -> PQ.PrimQuery-        yieldNoRows = PQ.restrict (HPQ.ConstExpr (HPQ.BoolLit False))+data NonEmptyRowspec fields fields' =+  NonEmptyRowspec (fields -> NEL.NonEmpty HPQ.PrimExpr)+                  (State.State T.Tag (NEL.NonEmpty HPQ.Symbol, fields')) -        zero = HPQ.ConstExpr (HPQ.IntegerLit 0)-        nullInt = HPQ.CastExpr (Opaleye.Internal.PGTypes.showSqlType-                                  (Nothing :: Maybe Opaleye.SqlTypes.SqlInt4))-                               (HPQ.ConstExpr HPQ.NullLit)+-- Some overlap here with extractAttrPE+nonEmptyRowspecField :: NonEmptyRowspec (Field_ n a) (Field_ n a)+nonEmptyRowspecField = NonEmptyRowspec (pure . C.unColumn) s+  where s = do+          t <- T.fresh+          let symbol = HPQ.Symbol "values" t+          pure (pure symbol, C.Column (HPQ.AttrExpr symbol)) -        (values, wrap) = case NEL.nonEmpty rows of-          Nothing    -> (pure nulls, yieldNoRows)-          Just rows' -> (fmap runRow rows', id)+rowspecField :: Rowspec (Field_ n a) (Field_ n a)+rowspecField = NonEmptyRows nonEmptyRowspecField -        primQ' = wrap (PQ.Values valuesPEs values)+data Rowspec fields fields' =+    NonEmptyRows (NonEmptyRowspec fields fields')+  | EmptyRows fields'  data Valuesspec fields fields' =-  ValuesspecSafe (PM.PackMap HPQ.PrimExpr HPQ.PrimExpr () fields')-                 (U.Unpackspec fields fields')--{-# DEPRECATED ValuesspecSafe "Use Valuesspec instead.  Will be removed in version 0.10." #-}-type ValuesspecSafe = Valuesspec--runValuesspecSafe :: Applicative f-                  => Valuesspec columns columns'-                  -> (HPQ.PrimExpr -> f HPQ.PrimExpr)-                  -> f columns'-runValuesspecSafe (ValuesspecSafe v _) f = PM.traversePM v f ()+  ValuesspecSafe (Nullspec fields fields')+                 (Rowspec fields fields')  valuesspecField :: Opaleye.SqlTypes.IsSqlType a                 => Valuesspec (Field_ n a) (Field_ n a)@@ -121,27 +86,28 @@  -- For rel8 valuesspecFieldType :: String -> Valuesspec (Field_ n a) (Field_ n a)-valuesspecFieldType sqlType = def_-    where def_ = ValuesspecSafe (PM.PackMap (\f () -> fmap Column (f null_)))-                                U.unpackspecField-          null_ = nullPEType sqlType+valuesspecFieldType sqlType =+  ValuesspecSafe (nullspecFieldType sqlType) rowspecField -instance Opaleye.Internal.PGTypes.IsSqlType a+instance forall a n. Opaleye.Internal.PGTypes.IsSqlType a   => Default Valuesspec (Field_ n a) (Field_ n a) where-  def = valuesspecField--nullPE :: Opaleye.SqlTypes.IsSqlType a => proxy a -> HPQ.PrimExpr-nullPE sqlType = nullPEType (Opaleye.Internal.PGTypes.showSqlType sqlType)+  def = ValuesspecSafe nullspecField rowspecField -nullPEType :: String -> HPQ.PrimExpr-nullPEType sqlType = HPQ.CastExpr sqlType (HPQ.ConstExpr HPQ.NullLit)+newtype Nullspec fields fields' = Nullspec fields' --- Implementing this in terms of Valuesspec for convenience-newtype Nullspec fields fields' = Nullspec (Valuesspec Void fields')+nullspecField :: forall a n sqlType.+                 Opaleye.SqlTypes.IsSqlType sqlType+              => Nullspec a (Field_ n sqlType)+nullspecField = nullspecFieldType ty+  where ty = Opaleye.Internal.PGTypes.showSqlType (Nothing :: Maybe sqlType) -nullspecField :: Opaleye.SqlTypes.IsSqlType b-              => Nullspec a (Field_ n b)-nullspecField = Nullspec (lmap absurd valuesspecField)+nullspecFieldType :: String+                  -> Nullspec a (Field_ n sqlType)+nullspecFieldType sqlType =+  (Nullspec+  . C.unsafeCast sqlType+  . C.unsafeCoerceColumn)+  OC.null  nullspecList :: Nullspec a [b] nullspecList = pure []@@ -162,7 +128,7 @@ -- that!  Used to create such fields when we know we will never look -- at them expecting to find something non-NULL. nullFields :: Nullspec a fields -> fields-nullFields (Nullspec v) = runIdentity (runValuesspecSafe v pure)+nullFields (Nullspec v) = v  -- { @@ -191,24 +157,110 @@     ValuesspecSafe (f <*> x) (f' <*> x')  instance Profunctor Valuesspec where-  dimap f g (ValuesspecSafe q q') = ValuesspecSafe (rmap g q) (dimap f g q')+  dimap f g (ValuesspecSafe q q') = ValuesspecSafe (dimap f g q) (dimap f g q')  instance ProductProfunctor Valuesspec where   purePP = pure   (****) = (<*>)  instance Functor (Nullspec a) where-  fmap f (Nullspec g) = Nullspec (fmap f g)+  fmap f (Nullspec g) = Nullspec (f g)  instance Applicative (Nullspec a) where-  pure = Nullspec . pure-  Nullspec f <*> Nullspec x = Nullspec (f <*> x)+  pure = Nullspec+  Nullspec f <*> Nullspec x = Nullspec (f x)  instance Profunctor Nullspec where-  dimap _ g (Nullspec q) = Nullspec (fmap g q)+  dimap _ g (Nullspec q) = Nullspec (g q)  instance ProductProfunctor Nullspec where   purePP = pure   (****) = (<*>) +instance Functor (NonEmptyRowspec a) where+  fmap = rmap++instance Profunctor NonEmptyRowspec where+  dimap f g (NonEmptyRowspec a b) =+    NonEmptyRowspec (lmap f a) ((fmap . fmap) g b)++instance Functor (Rowspec a) where+  fmap = rmap++instance Applicative (Rowspec a) where+  pure x = EmptyRows x+  r1 <*> r2 = case (r1, r2) of+    (EmptyRows f, EmptyRows x) -> EmptyRows (f x)+    (EmptyRows f, NonEmptyRows (NonEmptyRowspec x1 x2)) ->+      NonEmptyRows (NonEmptyRowspec x1 ((fmap . fmap) f x2))+    (NonEmptyRows (NonEmptyRowspec f1 f2), EmptyRows x) ->+     NonEmptyRows (NonEmptyRowspec f1 ((fmap . fmap) ($ x) f2))+    (NonEmptyRows (NonEmptyRowspec f1 f2),+     NonEmptyRows (NonEmptyRowspec x1 x2)) ->+      NonEmptyRows (NonEmptyRowspec+            (f1 <> x1)+            ((liftA2 . liftF2) ($) f2 x2))++    where -- Instead of depending on Apply+          -- https://www.stackage.org/haddock/lts-19.16/semigroupoids-5.3.7/Data-Functor-Apply.html#v:liftF2+          liftF2 :: Semigroup m+                 => (a' -> b -> c) -> (m, a') -> (m, b) -> (m, c)+          liftF2 f (ys1, x1) (ys2, x2) = (ys1 <> ys2, f x1 x2)++instance Profunctor Rowspec where+  dimap f g = \case+    EmptyRows x -> EmptyRows (g x)+    NonEmptyRows x -> NonEmptyRows (dimap f g x)++instance ProductProfunctor Rowspec where+  purePP = pure+  (****) = (<*>)+ -- }++{-# DEPRECATED valuesU "Will be removed in 0.10" #-}+valuesU :: U.Unpackspec columns columns'+        -> ValuesspecUnsafe columns columns'+        -> [columns]+        -> ((), T.Tag) -> (columns', PQ.PrimQuery)+valuesU unpack valuesspec rows ((), t) = (newColumns, primQ')+  where runRow row = valuesRow+           where (_, valuesRow) =+                   PM.run (U.runUnpackspec unpack extractValuesEntry row)++        (newColumns, valuesPEs_nulls) =+          PM.run (runValuesspec valuesspec (extractValuesField t))++        valuesPEs = map fst valuesPEs_nulls++        values :: [[HPQ.PrimExpr]]+        values = map runRow rows++        primQ' = case NEL.nonEmpty values of+          Nothing      -> PQ.Empty ()+          Just values' -> PQ.Values valuesPEs values'++{-# DEPRECATED extractValuesEntry "Will be removed in 0.10" #-}+extractValuesEntry :: HPQ.PrimExpr -> PM.PM [HPQ.PrimExpr] HPQ.PrimExpr+extractValuesEntry pe = do+  PM.write pe+  return pe++{-# DEPRECATED extractValuesField "Will be removed in 0.10" #-}+extractValuesField :: T.Tag -> primExpr+                   -> PM.PM [(HPQ.Symbol, primExpr)] HPQ.PrimExpr+extractValuesField = PM.extractAttr "values"++{-# DEPRECATED runValuesspec "Will be removed in 0.10" #-}+runValuesspec :: Applicative f => ValuesspecUnsafe columns columns'+              -> (() -> f HPQ.PrimExpr) -> f columns'+runValuesspec (Valuesspec v) f = PM.traversePM v f ()++newtype ValuesspecUnsafe columns columns' =+  Valuesspec (PM.PackMap () HPQ.PrimExpr () columns')++instance Default ValuesspecUnsafe (Field_ n a) (Field_ n a) where+  def = Valuesspec (PM.iso id Column)++{-# DEPRECATED ValuesspecSafe "Use Valuesspec instead.  Will be removed in version 0.10." #-}+type ValuesspecSafe = Valuesspec

@@ -0,0 +1,119 @@+module Opaleye.Internal.Window where++import           Control.Applicative (Applicative, pure, (<*>))++import qualified Opaleye.Internal.Aggregate as A+import qualified Opaleye.Internal.PackMap as PM+import qualified Opaleye.Internal.PrimQuery as PQ+import qualified Opaleye.Internal.QueryArr as Q+import qualified Opaleye.Internal.Tag as T+import qualified Opaleye.Internal.Column as C+import qualified Opaleye.Internal.Order as O++import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ+++-- | 'Window' is an applicative functor that represents expressions that+-- contain+-- [window functions](https://www.postgresql.org/docs/current/tutorial-window.html).+-- 'window' can be used to evaluate these expressions over a particular query.+newtype Window a =+  Window (PM.PackMap (HPQ.WndwOp, Partition) HPQ.PrimExpr () a)+++instance Functor Window where+  fmap f (Window g) = Window (fmap f g)+++instance Applicative Window where+  pure = Window . pure+  Window f <*> Window x = Window (f <*> x)+++runWindow :: Applicative f+  => Window a -> ((HPQ.WndwOp, Partition) -> f HPQ.PrimExpr) -> f a+runWindow (Window a) f = PM.traversePM a f ()+++extractWindowFields+  :: T.Tag+  -> (HPQ.WndwOp, Partition)+  -> PM.PM (PQ.Bindings (HPQ.WndwOp, HPQ.Partition)) HPQ.PrimExpr+extractWindowFields tag (op, Partition ps os) = do+  i <- PM.new+  let symbol = HPQ.Symbol ("window" ++ i) tag+  PM.write (symbol, (op, (HPQ.Partition ps os)))+  pure (HPQ.AttrExpr symbol)+++-- | 'window' runs a query composed of expressions containing+-- [window functions](https://www.postgresql.org/docs/current/tutorial-window.html).+-- 'window' is similar to 'Opaleye.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, 'Opaleye.aggregate' is to 'foldl'+-- as 'window' is to 'scanl'.+window :: Q.Select (Window a) -> Q.Select a+window q = Q.productQueryArr $ do+  (wndw, primQ) <- Q.runSimpleQueryArr' q ()+  tag <- T.fresh+  let+    (a, bindings) = PM.run (runWindow wndw (extractWindowFields tag))+  pure (a, PQ.Window bindings primQ)+++makeWndw :: HPQ.WndwOp -> Window (C.Field_ n a)+makeWndw op = Window (PM.PackMap (\f _ -> C.Column <$> f (op, mempty)))+++-- | 'cumulative' allows the use of aggregation functions in 'Window'+-- expressions. In particular, @'cumulative' 'Opaleye.sum'@+-- (when combined with 'orderPartitionBy') gives a running total,+-- also known as a \"cumulative sum\", hence the name @cumulative@.+cumulative :: A.Aggregator a b -> a -> Window b+cumulative (A.Aggregator (PM.PackMap pm)) a = Window $ PM.PackMap $ \f _ ->+  pm (\(mop, expr) -> case mop of+         Nothing -> pure expr+         Just (op, _, _) -> f (HPQ.WndwAggregate op expr, mempty)) a+++-- | 'over' adds a 'Partition' to a 'Window' expression.+--+-- @+-- 'cumulative' 'Opaleye.sum' salary \`'over'\` 'partitionBy' department <> 'orderPartitionBy' salary ('Opaleye.desc' id)+-- @+over :: Window a -> Partition -> Window a+over (Window (PM.PackMap pm)) partition =+  Window $ PM.PackMap $ \f -> pm $ \(op, partition') ->+    f (op, partition' <> partition)+infixl 1 `over`+++-- | 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 Opaleye type 'Partition'+-- represents everything that comes after @OVER@.+--+-- 'Partition' is a 'Monoid', so 'Partition's created with 'partitionBy' and+-- 'orderPartitionBy' can be combined using '<>'.+data Partition = Partition ![HPQ.PrimExpr] ![HPQ.OrderExpr]+++instance Semigroup Partition where+  Partition ps os <> Partition ps' os' = Partition (ps <> ps') (os <> os')+++instance Monoid Partition where+  mempty = Partition [] []+++-- | Restricts a window function to operate only the group of rows that share+-- the same value(s) for the given expression(s).+partitionBy :: C.Field_ n a -> Partition+partitionBy (C.Column expr) = Partition [expr] []+++-- | Controls the order in which rows are processed by window functions. This+-- does not need to match the ordering of the overall query.+orderPartitionBy :: a -> O.Order a -> Partition+orderPartitionBy a ordering = Partition [] (O.orderExprs a ordering)

@@ -17,10 +17,11 @@  import qualified Opaleye.Internal.QueryArr as Q import qualified Opaleye.Internal.Tag as Tag-import           Opaleye.Internal.Values as V+import qualified Opaleye.Internal.Values as V import qualified Opaleye.Internal.Unpackspec as U import qualified Opaleye.Select              as S +import qualified Data.List.NonEmpty as NEL import           Data.Profunctor.Product.Default (Default, def)  {-# DEPRECATED valuesUnsafe "Use 'values' instead.  Will be removed in 0.10." #-}@@ -59,10 +60,9 @@  valuesExplicit :: V.Valuesspec fields fields'                -> [fields] -> S.Select fields'-valuesExplicit valuesspec fields =-  Q.productQueryArr $ do-    t <- Tag.fresh-    pure (V.valuesUSafe valuesspec fields ((), t))+valuesExplicit (V.ValuesspecSafe nullspec rowspec) fields = case NEL.nonEmpty fields of+  Nothing -> V.emptySelectExplicit nullspec+  Just rows -> V.nonEmptyValues rowspec rows  {-# DEPRECATED valuesSafe "Use 'values' instead.  Will be removed in 0.10." #-} valuesSafe :: Default V.Valuesspec fields fields

@@ -0,0 +1,93 @@+module Opaleye.Window+       (+         -- * Window queries+         W.window+       , W.Window+       , W.over+       , W.Partition+       , W.partitionBy+       , W.orderPartitionBy++         -- ** Specific window functions+       , W.cumulative+       , rowNumber+       , rank+       , denseRank+       , percentRank+       , cumeDist+       , ntile+       , lag+       , lead+       , firstValue+       , lastValue+       , nthValue+       ) where++import qualified Opaleye.Internal.Column as IC+import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ+import qualified Opaleye.Internal.Window as W++import qualified Opaleye.Field as F+import qualified Opaleye.SqlTypes as T++-- This page of Postgres documentation tell us what window+-- functions are available+--+--   https://www.postgresql.org/docs/devel/functions-window.html+++-- | [@row_number()@](https://www.postgresql.org/docs/current/functions-window.html)+rowNumber :: W.Window (F.Field T.SqlInt8)+rowNumber = W.makeWndw HPQ.WndwRowNumber+++-- | [@rank()@](https://www.postgresql.org/docs/current/functions-window.html)+rank :: W.Window (F.Field T.SqlInt8)+rank = W.makeWndw HPQ.WndwRank+++-- | [@dense_rank()@](https://www.postgresql.org/docs/current/functions-window.html)+denseRank :: W.Window (F.Field T.SqlInt8)+denseRank = W.makeWndw HPQ.WndwDenseRank+++-- | [@percent_rank()@](https://www.postgresql.org/docs/current/functions-window.html)+percentRank :: W.Window (F.Field T.SqlFloat8)+percentRank = W.makeWndw HPQ.WndwPercentRank+++-- | [@cume_dist()@](https://www.postgresql.org/docs/current/functions-window.html)+cumeDist :: W.Window (F.Field T.SqlFloat8)+cumeDist = W.makeWndw HPQ.WndwCumeDist+++-- | [@ntile(num_buckets)@](https://www.postgresql.org/docs/current/functions-window.html)+ntile :: F.Field T.SqlInt4 -> W.Window (F.Field T.SqlInt4)+ntile (IC.Column buckets) = W.makeWndw $ HPQ.WndwNtile buckets+++-- | [@lag(value, offset, default)@](https://www.postgresql.org/docs/current/functions-window.html)+lag :: F.Field_ n a -> F.Field T.SqlInt4 -> F.Field_ n a -> W.Window (F.Field_ n a)+lag (IC.Column a) (IC.Column offset) (IC.Column def) =+  W.makeWndw $ HPQ.WndwLag a offset def+++-- | [@lead(value, offset, default)@](https://www.postgresql.org/docs/current/functions-window.html)+lead :: F.Field_ n a -> F.Field T.SqlInt4 -> F.Field_ n a -> W.Window (F.Field_ n a)+lead (IC.Column a) (IC.Column offset) (IC.Column def) =+  W.makeWndw $ HPQ.WndwLead a offset def+++-- | [@first_value(value)@](https://www.postgresql.org/docs/current/functions-window.html)+firstValue :: F.Field_ n a -> W.Window (F.Field_ n a)+firstValue (IC.Column a) = W.makeWndw $ HPQ.WndwFirstValue a+++-- | [@last_value(value)@](https://www.postgresql.org/docs/current/functions-window.html)+lastValue :: F.Field_ n a -> W.Window (F.Field_ n a)+lastValue (IC.Column a) = W.makeWndw $ HPQ.WndwLastValue a+++-- | [@nth_value(value, n)@](https://www.postgresql.org/docs/current/functions-window.html)+nthValue :: F.Field_ n a -> F.Field T.SqlInt4 -> W.Window (F.FieldNullable a)+nthValue (IC.Column a) (IC.Column n) = W.makeWndw $ HPQ.WndwNthValue a n