opaleye 0.9.2.0 → 0.9.3.0

raw patch · 23 files changed

+327/−82 lines, 23 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• Test/Opaleye/Test/Arbitrary.hs +4/−4
• Test/Test.hs +23/−1
• opaleye.cabal +3/−2
• src/Opaleye.hs +2/−0
• src/Opaleye/Aggregate.hs +1/−1
• src/Opaleye/Exists.hs +2/−2
• src/Opaleye/Internal/Aggregate.hs +14/−11
• src/Opaleye/Internal/Binary.hs +1/−1
• src/Opaleye/Internal/Constant.hs +7/−0
• src/Opaleye/Internal/Join.hs +1/−1
• src/Opaleye/Internal/Locking.hs +1/−1
• src/Opaleye/Internal/Optimize.hs +14/−5
• src/Opaleye/Internal/PrimQuery.hs +87/−37
• src/Opaleye/Internal/Print.hs +19/−2
• src/Opaleye/Internal/QueryArr.hs +3/−5
• src/Opaleye/Internal/RunQuery.hs +7/−0
• src/Opaleye/Internal/Sql.hs +21/−0
• src/Opaleye/Internal/Table.hs +1/−1
• src/Opaleye/Order.hs +5/−5
• src/Opaleye/Table.hs +1/−1
• src/Opaleye/Values.hs +2/−2
• src/Opaleye/With.hs +100/−0

@@ -1,3 +1,11 @@+## 0.9.3.0++* Add `with` and `withRecursive` (thanks to Erik Hesselink and Shane+  O'Brien).++* Add `Default ToFields` and `DefaultFromField` instances for+  postgresql-simple's `Aeson` (thanks to Bas Van Dijk).+ ## 0.9.2.0  * Added `nullableToMaybeFields` and `maybeFieldsToNullable`

@@ -448,13 +448,13 @@         TQ.oneof [             do             ArbitraryHaskellsList l <- TQ.arbitrary-            return (fmap fieldsList (O.valuesSafe (fmap O.toFields l)))+            return (fmap fieldsList (O.values (fmap O.toFields l)))           , -- We test empty lists of values separately, because we             -- used to not support them             do               s <- TQ.choose (0, 5)               l <- TQ.vectorOf s (pure ())-              return (fmap (const emptyChoices) (O.valuesSafe l))+              return (fmap (const emptyChoices) (O.values l))           ]     ] @@ -518,10 +518,10 @@       return (arbitraryBinary binaryOperation)   ]   where arbitraryBinary binaryOperation q1 q2 =-          (fmap fieldsList+           fmap fieldsList             (binaryOperation               (fmap listFields q1)-              (fmap listFields q2)))+              (fmap listFields q2))  genSelectArrMapper :: [TQ.Gen (O.SelectArr a Fields -> O.SelectArr a Fields)] genSelectArrMapper =

@@ -10,6 +10,7 @@ import qualified Control.Applicative              as A import           Control.Arrow                    ((&&&), (***), (<<<), (>>>)) import qualified Control.Arrow                    as Arr+import           Control.Monad                    (guard) import qualified Data.Aeson                       as Json import qualified Data.Function                    as F import qualified Data.List                        as L@@ -818,6 +819,24 @@ testTableFunctor = it "" $ testH (O.selectTable table1F) (result `shouldBe`)   where result = fmap (\(col1, col2) -> (col1 + col2, col1 - col2)) table1data +recursive = O.withRecursive table1Q $ \(n, x) -> do+          O.where_ (n O..< 5)+          pure (n + 1, x + 1)++testWithRecursive :: Test+testWithRecursive = it "with recursive" $ testH recursive (`shouldBe` expected)+  where expected = withRecursive [] table1data $ \(n, x) -> do+          guard (n < 5)+          pure (n + 1, x + 1)+        withRecursive r s f =+          let r' = s ++ (r >>= f)+          in if r' == r then r else withRecursive r' s f++testWith :: Test+testWith = it "with" $ testH with (`shouldBe` expected)+  where with = O.with table1Q $ \t -> (,) <$> t <*> table2Q+        expected = (,) <$> table1data <*> table2data+ -- TODO: This is getting too complicated testUpdate :: Test testUpdate = it "" $ \conn -> do@@ -1283,7 +1302,7 @@   it "MaybeFields equality" $ testH query2 (`shouldBe` [True])   where nothing_ = OM.nothingFields :: MaybeFields ()         query :: Select (MaybeFields (Field O.SqlInt4))-        query = O.distinct (O.valuesSafe [ fmap (const 0) nothing_+        query = O.distinct (O.values [ fmap (const 0) nothing_                                          , fmap (const 1) nothing_ ])         query2 :: Select (Field O.SqlBool)         query2 = pure ((fmap (const (0 :: Field O.SqlInt4)) nothing_)@@ -1558,3 +1577,6 @@         testAddIntervalFromTimestampToTimestamp         testAddIntervalFromTimestamptzToTimestamptz         testAddIntervalFromTimeToTime+      describe "with" $ do+        testWithRecursive+        testWith

@@ -1,6 +1,6 @@ name:            opaleye copyright:       Copyright (c) 2014-2018 Purely Agile Limited; 2019-2022 Tom Ellis-version:         0.9.2.0+version:         0.9.3.0 synopsis:        An SQL-generating DSL targeting PostgreSQL description:     An SQL-generating DSL targeting PostgreSQL.  Allows                  Postgres queries to be written within Haskell in a@@ -26,7 +26,7 @@   default-language: Haskell2010   hs-source-dirs: src   build-depends:-      aeson               >= 0.6     && < 2.1+      aeson               >= 0.6     && < 2.2     , base                >= 4.9     && < 4.17     , base16-bytestring   >= 0.1.1.6 && < 1.1     , case-insensitive    >= 1.2     && < 1.3@@ -69,6 +69,7 @@                    Opaleye.ToFields,                    Opaleye.TypeFamilies,                    Opaleye.Values,+                   Opaleye.With,                    Opaleye.Internal.Aggregate,                    Opaleye.Internal.Binary,                    Opaleye.Internal.Constant,

@@ -36,6 +36,7 @@                , module Opaleye.Table                , module Opaleye.ToFields                , module Opaleye.Values+               , module Opaleye.With                ) where  import Opaleye.Adaptors@@ -61,3 +62,4 @@ import Opaleye.Table import Opaleye.ToFields import Opaleye.Values+import Opaleye.With

@@ -82,7 +82,7 @@ -- See 'Opaleye.Internal.Sql.aggregate' for details of how aggregating -- by an empty query with no group by is handled. aggregate :: Aggregator a b -> S.Select a -> S.Select b-aggregate agg q = Q.productQueryArr' $ \() -> do+aggregate agg q = Q.productQueryArr $ do   (a, pq) <- Q.runSimpleQueryArr' q ()   t <- Tag.fresh   pure (A.aggregateU agg (a, pq, t))

@@ -2,7 +2,7 @@  import           Opaleye.Field (Field) import           Opaleye.Internal.Column (Field_(Column))-import           Opaleye.Internal.QueryArr (productQueryArr', runSimpleQueryArr')+import           Opaleye.Internal.QueryArr (productQueryArr, runSimpleQueryArr') import           Opaleye.Internal.PackMap (run, extractAttr) import           Opaleye.Internal.PrimQuery (PrimQuery' (Exists)) import           Opaleye.Internal.Tag (fresh)@@ -13,7 +13,7 @@ -- -- This operation is equivalent to Postgres's @EXISTS@ operator. exists :: Select a -> Select (Field SqlBool)-exists q = productQueryArr' $ \() -> do+exists q = productQueryArr $ do   (_, query) <- runSimpleQueryArr' q ()   tag <- fresh   let (result, [(binding, ())]) = run (extractAttr "exists" tag ())

@@ -46,30 +46,33 @@ -- `Opaleye.Aggregate.arrayAgg` and `Opaleye.Aggregate.stringAgg`. -- -- You can either apply it to an aggregation of multiple columns, in--- which case it will apply to all aggregation functions in there, or you--- can apply it to a single column, and then compose the aggregations--- afterwards. Examples:+-- which case it will apply to all aggregation functions in there ----- > x :: Aggregator (Column a, Column b) (Column (PGArray a), Column (PGArray a))--- > x = (,) <$> orderAggregate (asc snd) (lmap fst arrayAggGrouped)--- >         <*> orderAggregate (desc snd) (lmap fst arrayAggGrouped)+-- Example: --+-- > x :: Aggregator (Column a, Column b) (Column (PGArray a), Column (PGArray b))+-- > x = orderAggregate (asc snd) $ p2 (arrayAgg, arrayAgg)+-- -- This will generate: -- -- @--- SELECT array_agg(a ORDER BY b ASC), array_agg(a ORDER BY b DESC)+-- SELECT array_agg(a ORDER BY b ASC), array_agg(b ORDER BY b ASC) -- FROM (SELECT a, b FROM ...) -- @ ----- Or:+-- Or you can apply it to a single column, and then compose the aggregations+-- afterwards. ----- > x :: Aggregator (Column a, Column b) (Column (PGArray a), Column (PGArray b))--- > x = orderAggregate (asc snd) $ p2 (arrayAggGrouped, arrayAggGrouped)+-- Example: --+-- > x :: Aggregator (Column a, Column b) (Column (PGArray a), Column (PGArray a))+-- > x = (,) <$> orderAggregate (asc snd) (lmap fst arrayAgg)+-- >         <*> orderAggregate (desc snd) (lmap fst arrayAgg)+-- -- This will generate: -- -- @--- SELECT array_agg(a ORDER BY b ASC), array_agg(b ORDER BY b ASC)+-- SELECT array_agg(a ORDER BY b ASC), array_agg(a ORDER BY b DESC) -- FROM (SELECT a, b FROM ...) -- @ 

@@ -40,7 +40,7 @@  sameTypeBinOpHelper :: PQ.BinOp -> Binaryspec columns columns'                     -> Q.Query columns -> Q.Query columns -> Q.Query columns'-sameTypeBinOpHelper binop binaryspec q1 q2 = Q.productQueryArr' $ \() -> do+sameTypeBinOpHelper binop binaryspec q1 q2 = Q.productQueryArr $ do   (columns1, primQuery1) <- Q.runSimpleQueryArr' q1 ()   (columns2, primQuery2) <- Q.runSimpleQueryArr' q2 () 

@@ -29,6 +29,7 @@ import           Data.Functor                    ((<$>))  import qualified Database.PostgreSQL.Simple.Range as R+import           Database.PostgreSQL.Simple.Newtypes ( Aeson, getAeson )  toFields :: D.Default ToFields haskells fields          => haskells -> fields@@ -134,11 +135,17 @@ instance D.Default ToFields LBS.ByteString (Field T.SqlJsonb) where   def = toToFields T.sqlLazyJSONB +instance (Ae.ToJSON a) => D.Default ToFields (Aeson a) (Field T.SqlJson) where+  def = toToFields $ T.sqlValueJSON . getAeson+ instance D.Default ToFields Ae.Value (Field T.SqlJsonb) where   def = toToFields T.sqlValueJSONB  instance D.Default ToFields haskell (F.Field_ n sql) => D.Default ToFields (Maybe haskell) (Maybe (F.Field_ n sql)) where   def = toToFields (toFields <$>)++instance (Ae.ToJSON a) => D.Default ToFields (Aeson a) (F.Field T.SqlJsonb) where+  def = toToFields $ T.sqlValueJSONB . getAeson  instance (D.Default ToFields a (F.Field_ n b), T.IsSqlType b)          => D.Default ToFields [a] (F.Field (T.SqlArray_ n b)) where

@@ -48,7 +48,7 @@              -> ((columnsA, columnsB) -> Field T.PGBool)              -> Q.Query (returnedColumnsA, returnedColumnsB) joinExplicit uA uB returnColumnsA returnColumnsB joinType-             qA qB cond = Q.productQueryArr' $ \() -> do+             qA qB cond = Q.productQueryArr $ do   (columnsA, primQueryA) <- Q.runSimpleQueryArr' qA ()   (columnsB, primQueryB) <- Q.runSimpleQueryArr' qB () 

@@ -21,6 +21,6 @@ -- enforce those restrictions through its type system so it's very -- easy to create queries that fail at run time using this operation. forUpdate :: Q.Select a -> Q.Select a-forUpdate s = Q.productQueryArr' $ \() -> do+forUpdate s = Q.productQueryArr $ do   (a, query) <- Q.runSimpleQueryArr' s ()   pure (a, PQ.ForUpdate query)

@@ -14,17 +14,19 @@ import           Control.Arrow (first)  optimize :: PQ.PrimQuery' a -> PQ.PrimQuery' a-optimize = mergeProduct . removeUnit+optimize = PQ.foldPrimQuery (noSingletonProduct+                             `PQ.composePrimQueryFold` mergeProduct+                             `PQ.composePrimQueryFold` removeUnit) -removeUnit :: PQ.PrimQuery' a -> PQ.PrimQuery' a-removeUnit = PQ.foldPrimQuery PQ.primQueryFoldDefault { PQ.product   = product }+removeUnit :: PQ.PrimQueryFoldP a (PQ.PrimQuery' a) (PQ.PrimQuery' a)+removeUnit = PQ.primQueryFoldDefault { PQ.product   = product }   where product pqs = PQ.Product pqs'           where pqs' = case NEL.nonEmpty (NEL.filter (not . PQ.isUnit . snd) pqs) of                          Nothing -> return (pure PQ.Unit)                          Just xs -> xs -mergeProduct :: PQ.PrimQuery' a -> PQ.PrimQuery' a-mergeProduct = PQ.foldPrimQuery PQ.primQueryFoldDefault { PQ.product   = product }+mergeProduct :: PQ.PrimQueryFoldP a (PQ.PrimQuery' a) (PQ.PrimQuery' a)+mergeProduct = PQ.primQueryFoldDefault { PQ.product   = product }   where product pqs pes = PQ.Product pqs' (pes ++ pes')           where pqs' = pqs >>= queries                 queries (lat, PQ.Product qs _) = fmap (first (lat <>)) qs@@ -33,6 +35,12 @@                 conds (_lat, PQ.Product _ cs) = cs                 conds _ = [] +noSingletonProduct :: PQ.PrimQueryFoldP a (PQ.PrimQuery' a) (PQ.PrimQuery' a)+noSingletonProduct = PQ.primQueryFoldDefault { PQ.product = product }+  where product pqs conds = case (NEL.uncons pqs, conds) of+          (((PQ.NonLateral, x), Nothing), []) -> x+          _ -> PQ.Product pqs conds+ removeEmpty :: PQ.PrimQuery' a -> Maybe (PQ.PrimQuery' b) removeEmpty = PQ.foldPrimQuery PQ.PrimQueryFold {     PQ.unit      = return PQ.Unit@@ -64,6 +72,7 @@   , PQ.relExpr   = return .: PQ.RelExpr   , PQ.rebind    = \b -> fmap . PQ.Rebind b   , PQ.forUpdate = fmap PQ.ForUpdate+  , PQ.with      = \recursive name cols -> liftA2 (PQ.With recursive name cols)   }   where -- If only the first argument is Just, do n1 on it         -- If only the second argument is Just, do n2 on it

@@ -1,3 +1,5 @@+{-# LANGUAGE LambdaCase #-}+ module Opaleye.Internal.PrimQuery where  import           Prelude hiding (product)@@ -45,6 +47,9 @@   mappend = (<>)   mempty = NonLateral +data Recursive = NonRecursive | Recursive+  deriving Show+ aLeftJoin :: HPQ.PrimExpr -> PrimQuery -> PrimQueryArr aLeftJoin cond primQuery' = PrimQueryArr $ \lat primQueryL ->   Join LeftJoin cond (NonLateral, primQueryL) (lat, primQuery')@@ -157,42 +162,46 @@                   -- ForUpdate in the future                   --                   -- https://www.postgresql.org/docs/current/sql-select.html#SQL-FOR-UPDATE-SHARE+                  | With Recursive Symbol [Symbol] (PrimQuery' a) (PrimQuery' a)                  deriving Show  type PrimQuery = PrimQuery' ()-type PrimQueryFold = PrimQueryFold' ()+type PrimQueryFold p = PrimQueryFold' () p -data PrimQueryFold' a p = PrimQueryFold-  { unit              :: p-  , empty             :: a -> p-  , baseTable         :: TableIdentifier -> Bindings HPQ.PrimExpr -> p-  , product           :: NEL.NonEmpty (Lateral, p) -> [HPQ.PrimExpr] -> p+type PrimQueryFold' a p = PrimQueryFoldP a p p++data PrimQueryFoldP a p p' = PrimQueryFold+  { unit              :: p'+  , empty             :: a -> p'+  , baseTable         :: TableIdentifier -> Bindings HPQ.PrimExpr -> p'+  , product           :: NEL.NonEmpty (Lateral, p) -> [HPQ.PrimExpr] -> p'   , aggregate         :: Bindings (Maybe                              (HPQ.AggrOp, [HPQ.OrderExpr], HPQ.AggrDistinct),                                    HPQ.Symbol)                       -> p-                      -> p+                      -> p'   , distinctOnOrderBy :: Maybe (NEL.NonEmpty HPQ.PrimExpr)                       -> [HPQ.OrderExpr]                       -> p-                      -> p-  , limit             :: LimitOp -> p -> p+                      -> p'+  , limit             :: LimitOp -> p -> p'   , join              :: JoinType                       -> HPQ.PrimExpr                       -> (Lateral, p)                       -> (Lateral, p)-                      -> p-  , semijoin          :: SemijoinType -> p -> p -> p-  , exists            :: Symbol -> p -> p-  , values            :: [Symbol] -> NEL.NonEmpty [HPQ.PrimExpr] -> p+                      -> p'+  , semijoin          :: SemijoinType -> p -> p -> p'+  , exists            :: Symbol -> p -> p'+  , values            :: [Symbol] -> NEL.NonEmpty [HPQ.PrimExpr] -> p'   , binary            :: BinOp                       -> (p, p)-                      -> p-  , label             :: String -> p -> p-  , relExpr           :: HPQ.PrimExpr -> Bindings HPQ.PrimExpr -> p+                      -> p'+  , label             :: String -> p -> p'+  , relExpr           :: HPQ.PrimExpr -> Bindings HPQ.PrimExpr -> p'     -- ^ A relation-valued expression-  , rebind            :: Bool -> Bindings HPQ.PrimExpr -> p -> p-  , forUpdate         :: p -> p+  , rebind            :: Bool -> Bindings HPQ.PrimExpr -> p -> p'+  , forUpdate         :: p -> p'+  , with              :: Recursive -> Symbol -> [Symbol] -> p -> p -> p'   }  @@ -214,28 +223,69 @@   , exists            = Exists   , rebind            = Rebind   , forUpdate         = ForUpdate+  , with              = With   } +dimapPrimQueryFold :: (q -> p)+                   -> (p' -> q')+                   -> PrimQueryFoldP a p p'+                   -> PrimQueryFoldP a q q'+dimapPrimQueryFold self g f = PrimQueryFold+  { unit = g (unit f)+  , empty = g . empty f+  , 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))+  , 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'))+  , semijoin = \j p1 p2 -> g (semijoin f j (self p1) (self p2))+  , exists = \s p -> g (exists f s (self p))+  , values = \ss nel -> g (values f ss nel)+  , binary = \bo (p1, p2) -> g (binary f bo (self p1, self p2))+  , label = \l p -> g (label f l (self p))+  , relExpr = \pe bs -> g (relExpr f pe bs)+  , rebind = \s bs p -> g (rebind f s bs (self p))+  , forUpdate = \p -> g (forUpdate f (self p))+  , with = \r s ss p1 p2 -> g (with f r s ss (self p1) (self p2))+  }++applyPrimQueryFoldF ::+  PrimQueryFoldP a (PrimQuery' a) p -> PrimQuery' a -> p+applyPrimQueryFoldF f = \case+  Unit -> unit f+  Empty a -> empty f a+  BaseTable ti syms -> baseTable f ti syms+  Product qs pes -> product f qs pes+  Aggregate aggrs q -> aggregate f aggrs 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+  Semijoin j q1 q2 -> semijoin f j q1 q2+  Values ss pes -> values f ss pes+  Binary binop (q1, q2) -> binary f binop (q1, q2)+  Label l pq -> label f l pq+  RelExpr pe syms -> relExpr f pe syms+  Exists s q -> exists f s q+  Rebind star pes q -> rebind f star pes q+  ForUpdate q -> forUpdate f q+  With recursive name cols a b -> with f recursive name cols a b++primQueryFoldF ::+  PrimQueryFoldP a p p' -> (PrimQuery' a -> p) -> PrimQuery' a -> p'+primQueryFoldF g self = applyPrimQueryFoldF (dimapPrimQueryFold self id g)+ foldPrimQuery :: PrimQueryFold' a p -> PrimQuery' a -> p-foldPrimQuery f = fix fold-  where fold self primQ = case primQ of-          Unit                        -> unit              f-          Empty a                     -> empty             f a-          BaseTable ti syms           -> baseTable         f ti syms-          Product qs pes              -> product           f (fmap (fmap self) qs) pes-          Aggregate aggrs q           -> aggregate         f aggrs (self q)-          DistinctOnOrderBy dxs oxs q -> distinctOnOrderBy f dxs oxs (self q)-          Limit op q                  -> limit             f op (self q)-          Join j cond q1 q2           -> join              f j cond (fmap self q1) (fmap self q2)-          Semijoin j q1 q2            -> semijoin          f j (self q1) (self q2)-          Values ss pes               -> values            f ss pes-          Binary binop (q1, q2)       -> binary            f binop (self q1, self q2)-          Label l pq                  -> label             f l (self pq)-          RelExpr pe syms             -> relExpr           f pe syms-          Exists s q                  -> exists            f s (self q)-          Rebind star pes q           -> rebind            f star pes (self q)-          ForUpdate q                 -> forUpdate         f (self q)-        fix g = let x = g x in x+foldPrimQuery f = fix (primQueryFoldF f)+  where fix g = let x = g x in x++-- Would be nice to show that this is associative+composePrimQueryFold ::+  PrimQueryFoldP a (PrimQuery' a) q ->+  PrimQueryFoldP a p (PrimQuery' a) ->+  PrimQueryFoldP a p q+composePrimQueryFold = fmapPrimQueryFold . applyPrimQueryFoldF+  where fmapPrimQueryFold = dimapPrimQueryFold id  times :: Lateral -> PrimQuery -> PrimQuery -> PrimQuery times lat q q' = Product (pure q NEL.:| [(lat, q')]) []

@@ -13,8 +13,9 @@                                               SelectValues,                                               SelectBinary,                                               SelectLabel,-                                              SelectExists),-                                       From, Join, Semijoin, Values, Binary, Label, Exists)+                                              SelectExists,+                                              SelectWith),+                                       From, Join, Semijoin, Values, Binary, Label, Exists, With)  import qualified Opaleye.Internal.PrimQuery as PQ import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ@@ -42,6 +43,7 @@ ppSql (SelectBinary v)   = ppSelectBinary v ppSql (SelectLabel v)    = ppSelectLabel v ppSql (SelectExists v)   = ppSelectExists v+ppSql (SelectWith r)     = ppWith r  ppDistinctOn :: Maybe (NEL.NonEmpty HSql.SqlExpr) -> Doc ppDistinctOn = maybe mempty $ \nel ->@@ -108,6 +110,20 @@   text "SELECT EXISTS"   <+> ppTable (Sql.sqlSymbol (Sql.existsBinding e), Sql.existsTable e) +ppRecursive :: Sql.Recursive -> Doc+ppRecursive Sql.Recursive = text "RECURSIVE"+ppRecursive Sql.NonRecursive = mempty++ppWith :: With -> Doc+ppWith w+  =  text "WITH" <+> ppRecursive (Sql.wRecursive w)+  <+> HPrint.ppTable (Sql.wTable w)+  <+> parens (HPrint.commaV unColumn (Sql.wCols w))+  <+> text "AS"+  $$ parens (ppSql (Sql.wWith w))+  $$ ppSql (Sql.wSelect w)+  where unColumn (HSql.SqlColumn col) = text col+ ppJoinType :: Sql.JoinType -> Doc ppJoinType Sql.LeftJoin = text "LEFT OUTER JOIN" ppJoinType Sql.RightJoin = text "RIGHT OUTER JOIN"@@ -150,6 +166,7 @@   SelectBinary slb      -> parens (ppSelectBinary slb)   SelectLabel sll       -> parens (ppSelectLabel sll)   SelectExists saj      -> parens (ppSelectExists saj)+  SelectWith w          -> parens (ppWith w)   `ppAs`   Just alias 

@@ -33,6 +33,9 @@ type QueryArr = SelectArr type Query = SelectArr () +productQueryArr :: State Tag (a, PQ.PrimQuery) -> Query a+productQueryArr f = productQueryArr' (\() -> f)+ productQueryArr' :: (a -> State Tag (b, PQ.PrimQuery)) -> QueryArr a b productQueryArr' f = QueryArr $ \a -> do   (b, pq) <- f a@@ -52,11 +55,6 @@ runStateQueryArr (QueryArr f) a tag =   let ((b, pq), tag') = runState (f a) tag   in (b, pq, tag')--stateQueryArr :: (a -> Tag -> (b, PQ.PrimQueryArr, Tag)) -> QueryArr a b-stateQueryArr f = QueryArr $ \a -> state $ \tag ->-  let (b, pq, tag') = f a tag-  in ((b, pq), tag')  runSimpleQueryArrStart :: QueryArr a b -> a -> (b, PQ.PrimQuery, Tag) runSimpleQueryArrStart q a =

@@ -17,6 +17,7 @@   (FieldParser, fromField, pgArrayFieldParser, optionalField) import           Database.PostgreSQL.Simple.FromRow (fromRow, fieldWith) import           Database.PostgreSQL.Simple.Types (fromPGArray, Only(..))+import           Database.PostgreSQL.Simple.Newtypes ( Aeson )  import           Opaleye.Internal.Column (Field_, Field, FieldNullable,                                           Nullability(Nullable, NonNullable))@@ -276,6 +277,9 @@ instance DefaultFromField T.SqlJson Ae.Value where   defaultFromField = fromPGSFromField +instance (Ae.FromJSON a, Typeable a) => DefaultFromField T.SqlJson (Aeson a) where+  defaultFromField = fromPGSFromField+ instance DefaultFromField T.SqlJsonb String where   defaultFromField = fromPGSFieldParser jsonbFieldParser @@ -292,6 +296,9 @@   defaultFromField = fromPGSFieldParser jsonbFieldLazyByteParser  instance DefaultFromField T.SqlJsonb Ae.Value where+  defaultFromField = fromPGSFromField++instance (Ae.FromJSON a, Typeable a) => DefaultFromField T.SqlJsonb (Aeson a) where   defaultFromField = fromPGSFromField  -- No CI String instance since postgresql-simple doesn't define FromField (CI String)

@@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}  module Opaleye.Internal.Sql where @@ -30,6 +31,7 @@             | SelectBinary Binary             | SelectLabel Label             | SelectExists Exists+            | SelectWith With             deriving Show  data SelectAttrs =@@ -80,7 +82,16 @@ data BinOp = Except | ExceptAll | Union | UnionAll | Intersect | IntersectAll deriving Show data Lateral = Lateral | NonLateral deriving Show data LockStrength = Update deriving Show+data Recursive = NonRecursive | Recursive deriving Show+data With = With {+  wTable     :: HSql.SqlTable, -- The name of the result, i.e. WITH <name> AS+  wCols      :: [HSql.SqlColumn],+  wRecursive :: Recursive,+  wWith      :: Select,+  wSelect    :: Select+} deriving Show + data Label = Label {   lLabel  :: String,   lSelect :: Select@@ -111,6 +122,7 @@   , PQ.exists            = exists   , PQ.rebind            = rebind   , PQ.forUpdate         = forUpdate+  , PQ.with              = with   }  exists :: Symbol -> Select -> Select@@ -248,6 +260,15 @@   bSelect1 = select1,   bSelect2 = select2   }++with :: PQ.Recursive -> Symbol -> [Symbol]-> Select -> Select -> Select+with recursive name cols wWith wSelect = SelectWith $ With {..}+  where+   wTable = HSql.SqlTable Nothing (sqlSymbol name)+   wRecursive = case recursive of+     PQ.NonRecursive -> NonRecursive+     PQ.Recursive -> Recursive+   wCols = map (HSql.SqlColumn . sqlSymbol) cols  joinType :: PQ.JoinType -> JoinType joinType PQ.LeftJoin = LeftJoin

@@ -39,7 +39,7 @@ -- -- widgetTable :: Table (Widget (Maybe (Field SqlInt4)) (Field SqlText) (Field SqlText) --                              (Field SqlInt4) (Field SqlFloat8))---                      (Widget (Field SqlText) (Field SqlText) (Field SqlText)+--                      (Widget (Field SqlInt4) (Field SqlText) (Field SqlText) --                              (Field SqlInt4) (Field SqlFloat8)) -- widgetTable = table \"widgetTable\" --                      (pWidget Widget { wid      = tableField \"id\"

@@ -57,7 +57,7 @@ -} orderBy :: O.Order a -> S.Select a -> S.Select a orderBy os q =-  Q.productQueryArr' $ \() -> do+  Q.productQueryArr $ do     a_pq <- Q.runSimpleQueryArr' q ()     pure (O.orderByU os a_pq) @@ -116,7 +116,7 @@ @ -} limit :: Int -> S.Select a -> S.Select a-limit n a = Q.productQueryArr' $ \() -> do+limit n a = Q.productQueryArr $ do   a_pq <- Q.runSimpleQueryArr' a ()   pure (O.limit' n a_pq) @@ -128,7 +128,7 @@ 'offset' with 'limit'. -} offset :: Int -> S.Select a -> S.Select a-offset n a = Q.productQueryArr' $ \() -> do+offset n a = Q.productQueryArr $ do   a_pq <- Q.runSimpleQueryArr' a ()   pure (O.offset' n a_pq) @@ -190,7 +190,7 @@                    -> (a -> b)                    -> S.Select a                    -> S.Select a-distinctOnExplicit unpack proj q = Q.productQueryArr' $ \() -> do+distinctOnExplicit unpack proj q = Q.productQueryArr $ do   a_pq <- Q.runSimpleQueryArr' q ()   pure (O.distinctOn unpack proj a_pq) @@ -199,6 +199,6 @@                      -> O.Order a                      -> S.Select a                      -> S.Select a-distinctOnByExplicit unpack proj ord q = Q.productQueryArr' $ \() -> do+distinctOnByExplicit unpack proj ord q = Q.productQueryArr $ do   a_pq <- Q.runSimpleQueryArr' q ()   pure (O.distinctOnBy unpack proj ord a_pq)

@@ -132,7 +132,7 @@                     -> Table a tablefields                     -- ^                     -> S.Select fields-selectTableExplicit cm table' = Q.productQueryArr' $ \() -> do+selectTableExplicit cm table' = Q.productQueryArr $ do   t0 <- Tag.fresh   let (retwires, primQ) = T.queryTable cm table' t0   pure (retwires, primQ)

@@ -34,7 +34,7 @@                      -> V.ValuesspecUnsafe fields fields'                      -> [fields] -> S.Select fields' valuesUnsafeExplicit unpack valuesspec fields =-  Q.productQueryArr' $ \() -> do+  Q.productQueryArr $ do   t <- Tag.fresh   pure (V.valuesU unpack valuesspec fields ((), t)) @@ -60,7 +60,7 @@ valuesExplicit :: V.Valuesspec fields fields'                -> [fields] -> S.Select fields' valuesExplicit valuesspec fields =-  Q.productQueryArr' $ \() -> do+  Q.productQueryArr $ do     t <- Tag.fresh     pure (V.valuesUSafe valuesspec fields ((), t)) 

@@ -0,0 +1,100 @@+{-# LANGUAGE FlexibleContexts #-}++module Opaleye.With+  ( with,+    withRecursive,++    -- * Explicit versions+    withExplicit,+    withRecursiveExplicit,+  )+where++import Control.Monad.Trans.State.Strict (State)+import Data.Profunctor.Product.Default (Default, def)+import Opaleye.Binary (unionAllExplicit)+import Opaleye.Internal.Binary (Binaryspec (..))+import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ+import Opaleye.Internal.PackMap (PackMap (..))+import qualified Opaleye.Internal.PackMap as PM+import qualified Opaleye.Internal.PrimQuery as PQ+import Opaleye.Internal.QueryArr (Select, productQueryArr, runSimpleQueryArr')+import qualified Opaleye.Internal.Sql as Sql+import qualified Opaleye.Internal.Tag as Tag+import Opaleye.Internal.Unpackspec (Unpackspec (..), runUnpackspec)++with :: Default Unpackspec a a => Select a -> (Select a -> Select b) -> Select b+with = withExplicit def++-- | @withRecursive s f@ is the smallest set of rows @r@ such that+--+-- @+-- r == s \`'unionAll'\` (r >>= f)+-- @+withRecursive :: Default Binaryspec a a => Select a -> (a -> Select a) -> Select a+withRecursive = withRecursiveExplicit def++withExplicit :: Unpackspec a a -> Select a -> (Select a -> Select b) -> Select b+withExplicit unpackspec rhsSelect bodySelect = productQueryArr $ do+  withG unpackspec PQ.NonRecursive (\_ -> rhsSelect) bodySelect++withRecursiveExplicit :: Binaryspec a a -> Select a -> (a -> Select a) -> Select a+withRecursiveExplicit binaryspec base recursive = productQueryArr $ do+  let bodySelect selectCte = selectCte+  let rhsSelect selectCte = unionAllExplicit binaryspec base (selectCte >>= recursive)++  withG unpackspec PQ.Recursive rhsSelect bodySelect+  where+    unpackspec = binaryspecToUnpackspec binaryspec++withG ::+  Unpackspec a a ->+  PQ.Recursive ->+  (Select a -> Select a) ->+  (Select a -> Select b) ->+  State Tag.Tag (b, PQ.PrimQuery)+withG unpackspec recursive rhsSelect bodySelect = do+  (selectCte, withCte) <- freshCte unpackspec++  let rhsSelect' = rhsSelect selectCte+  let bodySelect' = bodySelect selectCte++  (_, rhsQ) <- runSimpleQueryArr' rhsSelect' ()+  bodyQ <- runSimpleQueryArr' bodySelect' ()++  pure (withCte recursive rhsQ bodyQ)++freshCte ::+  Unpackspec a a ->+  State+    Tag.Tag+    ( Select a,+      PQ.Recursive -> PQ.PrimQuery -> (b, PQ.PrimQuery) -> (b, PQ.PrimQuery)+    )+freshCte unpackspec = do+  cteName <- HPQ.Symbol "cte" <$> Tag.fresh++  -- TODO: Make a function that explicitly ignores its argument+  (cteColumns, cteBindings) <- do+    startTag <- Tag.fresh+    pure $+      PM.run $+        runUnpackspec unpackspec (PM.extractAttr "cte" startTag) (error "freshCte")++  let selectCte = productQueryArr $ do+        tag <- Tag.fresh+        let (renamedCte, renameCte) =+              PM.run $+                runUnpackspec unpackspec (PM.extractAttr "cte_renamed" tag) cteColumns++        pure (renamedCte, PQ.BaseTable (PQ.TableIdentifier Nothing (Sql.sqlSymbol cteName)) renameCte)++  pure+    ( selectCte,+      \recursive withQ (withedCols, withedQ) ->+        (withedCols, PQ.With recursive cteName (map fst cteBindings) withQ withedQ)+    )++binaryspecToUnpackspec :: Binaryspec a a -> Unpackspec a a+binaryspecToUnpackspec (Binaryspec (PackMap spec)) =+  Unpackspec $ PackMap $ \f a -> spec (\(pe, _) -> f pe) (a, a)