opaleye 0.7.2.0 → 0.7.3.0

raw patch · 24 files changed

+294/−137 lines, 24 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• Doc/Tutorial/TutorialManipulation.lhs +1/−1
• Test/Test.hs +22/−3
• opaleye.cabal +2/−2
• src/Opaleye/Aggregate.hs +20/−0
• src/Opaleye/Field.hs +7/−3
• src/Opaleye/FunctionalJoin.hs +10/−1
• src/Opaleye/Internal/JSONBuildObjectFields.hs +4/−1
• src/Opaleye/Internal/Join.hs +8/−8
• src/Opaleye/Internal/Label.hs +0/−7
• src/Opaleye/Internal/Locking.hs +1/−2
• src/Opaleye/Internal/MaybeFields.hs +12/−13
• src/Opaleye/Internal/Operators.hs +3/−1
• src/Opaleye/Internal/Optimize.hs +1/−1
• src/Opaleye/Internal/PrimQuery.hs +7/−11
• src/Opaleye/Internal/Print.hs +9/−8
• src/Opaleye/Internal/QueryArr.hs +44/−19
• src/Opaleye/Internal/Rebind.hs +15/−0
• src/Opaleye/Internal/RunQuery.hs +56/−2
• src/Opaleye/Internal/Sql.hs +8/−11
• src/Opaleye/Join.hs +44/−38
• src/Opaleye/Label.hs +2/−2
• src/Opaleye/Lateral.hs +5/−0
• src/Opaleye/Operators.hs +8/−3

@@ -1,3 +1,8 @@+## 0.7.3.0++* Added DefaultFromField SqlJson(b) instances for Strict/Lazy+  Text/ByteString. Thanks to Nathan Jaremko.+ ## 0.7.2.0  * Added `jsonAgg`, `jsonBuildObject` and `jsonBuildObjectField`.  Thanks

@@ -137,7 +137,7 @@ >   , uReturning  = rCount >   } -SET "id" = DEFAULT,+SET "id" = "id",     "x" = ("x") + ("y"),     "y" = ("x") - ("y"),     "s" = "s"

@@ -19,6 +19,7 @@ import qualified Data.Profunctor.Product          as PP import qualified Data.Profunctor.Product.Default  as D import qualified Data.String                      as String+import qualified Data.ByteString                  as SBS import qualified Data.Text                        as T import qualified Data.Time                        as Time import qualified Database.PostgreSQL.Simple       as PGS@@ -516,8 +517,8 @@                                    minimum (map snd table6data))]   where q = O.aggregate (PP.p2 (O.arrayAgg, O.min)) table6Q -testStringJsonAggregate :: Test-testStringJsonAggregate =+testValueJsonAggregate :: Test+testValueJsonAggregate =   it "" $     testH       q@@ -533,6 +534,23 @@         $ O.jsonBuildObjectField "summary" firstCol           <> O.jsonBuildObjectField "details" secondCol +testByteStringJsonAggregate :: Test+testByteStringJsonAggregate =+  it "" $+    testH+      q+      ( \((res : _) :: [SBS.ByteString]) ->+          Just res `shouldBe` r+      )+  where+    r :: Maybe SBS.ByteString = Just "[{\"summary\" : \"xy\", \"details\" : \"a\"}, {\"summary\" : \"z\", \"details\" : \"a\"}, {\"summary\" : \"more text\", \"details\" : \"a\"}]"+    q = O.aggregate O.jsonAgg $ do+      (firstCol, secondCol) <- O.selectTable table6+      return+        . O.jsonBuildObject+        $ O.jsonBuildObjectField "summary" firstCol+          <> O.jsonBuildObjectField "details" secondCol+ testStringJsonAggregateWithJoin :: Test testStringJsonAggregateWithJoin =   it "" $@@ -1312,7 +1330,8 @@         testAggregateFunction         testAggregateProfunctor         testStringArrayAggregate-        testStringJsonAggregate+        testValueJsonAggregate+        testByteStringJsonAggregate         testStringJsonAggregateWithJoin         testStringAggregate         testOverwriteAggregateOrdered

@@ -1,6 +1,6 @@ name:            opaleye copyright:       Copyright (c) 2014-2018 Purely Agile Limited; 2019-2021 Tom Ellis-version:         0.7.2.0+version:         0.7.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@@ -85,7 +85,6 @@                    Opaleye.Internal.Inferrable,                    Opaleye.Internal.Join,                    Opaleye.Internal.JSONBuildObjectFields,-                   Opaleye.Internal.Label,                    Opaleye.Internal.Lateral,                    Opaleye.Internal.Map,                    Opaleye.Internal.Manipulation,@@ -99,6 +98,7 @@                    Opaleye.Internal.PrimQuery,                    Opaleye.Internal.Print,                    Opaleye.Internal.QueryArr,+                   Opaleye.Internal.Rebind,                    Opaleye.Internal.RunQuery,                    Opaleye.Internal.RunQueryExternal,                    Opaleye.Internal.Sql,

@@ -146,6 +146,26 @@ arrayAgg :: Aggregator (C.Column a) (C.Column (T.SqlArray a)) arrayAgg = A.makeAggr HPQ.AggrArr +{-|+Aggregates values, including nulls, as a JSON array++An example usage:++@+import qualified Opaleye as O++O.aggregate O.jsonAgg $ do+    (firstCol, secondCol) <- O.selectTable table6+    return+      . O.jsonBuildObject+      $ O.jsonBuildObjectField "summary" firstCol+        <> O.jsonBuildObjectField "details" secondCol+@++The above query, when executed, will return JSON of the following form from postgres:++@"[{\\"summary\\" : \\"xy\\", \\"details\\" : \\"a\\"}, {\\"summary\\" : \\"z\\", \\"details\\" : \\"a\\"}, {\\"summary\\" : \\"more text\\", \\"details\\" : \\"a\\"}]"@+-} jsonAgg :: Aggregator (C.Column a) (C.Column T.SqlJson) jsonAgg = A.makeAggr HPQ.JsonArr 

@@ -17,16 +17,20 @@  module Opaleye.Field (   Field_,-  Nullability(..),-  FieldNullable,   Field,+  FieldNullable,+  Nullability(..),+  -- * Coercing fields+  unsafeCoerceField,+  -- * Working with @NULL@+  -- | Instead of working with @NULL@ you are recommended to use+  -- "Opaleye.MaybeFields" instead.   Opaleye.Field.null,   isNull,   matchNullable,   fromNullable,   toNullable,   maybeToNullable,-  unsafeCoerceField   ) where  import qualified Opaleye.Column   as C

@@ -6,10 +6,19 @@ {-# LANGUAGE MultiParamTypeClasses #-}  module Opaleye.FunctionalJoin (+  -- * Full outer join+  fullJoinF,+  -- * Other joins+  -- ** Inner join+  -- | It is recommended that instead of @joinF@ you use+  -- 'Opaleye.Operators.restrict' directly (along with @do@+  -- notatation, 'Control.Applicative.<*>', or arrow notation).   joinF,+  -- ** Left/right joins+  -- | It is recommended that instead of @leftJoinF@ and @rightJoinF@+  -- you use 'Opaleye.Join.optional'.   leftJoinF,   rightJoinF,-  fullJoinF,   ) where  import           Control.Applicative             ((<$>), (<*>))

@@ -24,6 +24,7 @@   mempty = JSONBuildObjectFields mempty   mappend = (<>) +-- | Given a label and a column, generates a pair for use with @jsonBuildObject@ jsonBuildObjectField :: String                      -- ^ Field name                      -> Column a@@ -31,7 +32,9 @@                      -> JSONBuildObjectFields jsonBuildObjectField f (Column v) = JSONBuildObjectFields [(f, v)] --- | Create an 'SqlJson' object from a collection of fields+-- | Create an 'SqlJson' object from a collection of fields.+--+--   Note: This is implemented as a variadic function in postgres, and as such, is limited to 50 arguments, or 25 key-value pairs. jsonBuildObject :: JSONBuildObjectFields -> Column SqlJson jsonBuildObject (JSONBuildObjectFields jbofs) = Column $ FunExpr "json_build_object" args   where

@@ -63,24 +63,26 @@           nullableColumnsB = returnColumnsB newColumnsB            Column cond' = cond (columnsA, columnsB)-          primQueryR = PQ.Join joinType cond' ljPEsA ljPEsB primQueryA primQueryB+          primQueryR = PQ.Join joinType cond'+                               (PQ.NonLateral, (PQ.Rebind True ljPEsA primQueryA))+                               (PQ.NonLateral, (PQ.Rebind True ljPEsB primQueryB))  leftJoinAExplicit :: U.Unpackspec a a                   -> NullMaker a nullableA                   -> Q.Query a                   -> Q.QueryArr (a -> Column T.PGBool) nullableA leftJoinAExplicit uA nullmaker rq =-  Q.QueryArr $ \(p, primQueryL, t1) ->+  Q.QueryArr $ \(p, t1) ->     let (columnsR, primQueryR, t2) = Q.runSimpleQueryArr rq ((), t1)         (newColumnsR, ljPEsR) = PM.run $ U.runUnpackspec uA (extractLeftJoinFields 2 t2) columnsR         renamedNullable = toNullable nullmaker newColumnsR         Column cond = p newColumnsR     in ( renamedNullable-       , PQ.Join+       , \lat primQueryL -> PQ.Join            PQ.LeftJoin            cond-           []-           --- ^ I am reasonably confident that we don't need any+           (PQ.NonLateral, primQueryL)+           --- ^ I am reasonably confident that we don't need to rebind any            --- column names here.  Columns that can become NULL need            --- to be written here so that we can wrap them.  If we            --- don't constant columns can avoid becoming NULL.@@ -90,9 +92,7 @@            --- Report about the "avoiding NULL" bug:            ---            ---     https://github.com/tomjaguarpaw/haskell-opaleye/issues/223-           ljPEsR-           primQueryL-           primQueryR+           (lat, (PQ.Rebind True ljPEsR primQueryR))        , T.next t2)  optionalRestrict :: D.Default U.Unpackspec a a

@@ -1,7 +0,0 @@-module Opaleye.Internal.Label where--import qualified Opaleye.Internal.Tag as T-import qualified Opaleye.Internal.PrimQuery as PQ--label' :: String -> (a, PQ.PrimQuery, T.Tag) -> (a, PQ.PrimQuery, T.Tag)-label' l (x, q, t) = (x, PQ.Label l q, t)

@@ -21,5 +21,4 @@ -- 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.QueryArr ((\(a, pq, t) -> (a, PQ.ForUpdate pq, t)) . Q.runQueryArr s)+forUpdate = Q.mapPrimQuery PQ.ForUpdate

@@ -22,6 +22,7 @@                                               runInferrable) import qualified Opaleye.Internal.PrimQuery as PQ import qualified Opaleye.Internal.QueryArr as IQ+import qualified Opaleye.Internal.Rebind as Rebind import qualified Opaleye.Internal.RunQuery as RQ import qualified Opaleye.Internal.Tag as Tag import qualified Opaleye.Internal.Unpackspec as U@@ -124,25 +125,23 @@   where a `implies` b = Opaleye.Internal.Operators.not a .|| b  optional :: SelectArr i a -> SelectArr i (MaybeFields a)-optional = Opaleye.Internal.Lateral.laterally optionalSelect+optional = Opaleye.Internal.Lateral.laterally (optionalInternal (MaybeFields . isNotNull))+  where isNotNull = Opaleye.Internal.Operators.not . Opaleye.Field.isNull++optionalInternal :: (Field (Opaleye.Column.Nullable SqlBool) -> a -> r) -> Select a -> Select r+optionalInternal f = IQ.QueryArr . go   where     -- This is basically a left join on TRUE, but Shane (@duairc)     -- wrote it to ensure that we don't need an Unpackspec a a.-    optionalSelect :: Select a -> Select (MaybeFields a)-    optionalSelect = IQ.QueryArr . go--    go query ((), left, tag) = (MaybeFields present a, join, Tag.next tag')+    go query arg = (r, join, Tag.next tag')       where-        (MaybeFields t a, right, tag') =-          IQ.runSimpleQueryArr (justFields <$> query) ((), tag)--        present = isNotNull (IC.unsafeCoerceColumn t')+        (r, right, tag') = flip IQ.runSimpleQueryArr arg $ proc () -> do+          a <- query -< ()+          true_ <- Rebind.rebind -< Opaleye.Column.toNullable (IC.Column true)+          returnA -< f true_ a -        (t', bindings) =-          PM.run (U.runUnpackspec U.unpackspecField (PM.extractAttr "maybe" tag') t)-        join = PQ.Join PQ.LeftJoin true [] bindings left right+        join lat left = PQ.Join PQ.LeftJoin true (PQ.NonLateral, left) (lat, right)     true = HPQ.ConstExpr (HPQ.BoolLit True)-    isNotNull = Opaleye.Internal.Operators.not . Opaleye.Field.isNull   -- | An example to demonstrate how the functionality of (lateral)

@@ -23,7 +23,9 @@  restrict :: S.SelectArr (F.Field T.SqlBool) () restrict = QA.QueryArr f where-  f (Column predicate, primQ, t0) = ((), PQ.restrict predicate primQ, t0)+  -- A where clause can always refer to columns defined by the query+  -- it references so needs no special treatment on LATERAL.+  f (Column predicate, t0) = ((), \_ -> PQ.restrict predicate, t0)  infix 4 .== (.==) :: forall columns. D.Default EqPP columns columns

@@ -47,7 +47,7 @@   , PQ.aggregate = fmap . PQ.Aggregate   , PQ.distinctOnOrderBy = \mDistinctOns -> fmap . PQ.DistinctOnOrderBy mDistinctOns   , PQ.limit     = fmap . PQ.Limit-  , PQ.join      = \jt pe pes1 pes2 pq1 pq2 -> PQ.Join jt pe pes1 pes2 <$> pq1 <*> pq2+  , PQ.join      = \jt pe pq1 pq2 -> PQ.Join jt pe <$> sequence pq1 <*> sequence pq2   , PQ.semijoin  = liftA2 . PQ.Semijoin   , PQ.exists    = fmap . PQ.Exists   , PQ.values    = return .: PQ.Values

@@ -76,10 +76,8 @@                   | Limit     LimitOp (PrimQuery' a)                   | Join      JoinType                               HPQ.PrimExpr-                              (Bindings HPQ.PrimExpr)-                              (Bindings HPQ.PrimExpr)-                              (PrimQuery' a)-                              (PrimQuery' a)+                              (Lateral, PrimQuery' a)+                              (Lateral, PrimQuery' a)                   | Semijoin  SemijoinType (PrimQuery' a) (PrimQuery' a)                   | Exists    Symbol (PrimQuery' a)                   | Values    [Symbol] (NEL.NonEmpty [HPQ.PrimExpr])@@ -117,10 +115,8 @@   , limit             :: LimitOp -> p -> p   , join              :: JoinType                       -> HPQ.PrimExpr-                      -> Bindings HPQ.PrimExpr-                      -> Bindings HPQ.PrimExpr-                      -> p-                      -> p+                      -> (Lateral, p)+                      -> (Lateral, p)                       -> p   , semijoin          :: SemijoinType -> p -> p -> p   , exists            :: Symbol -> p -> p@@ -166,7 +162,7 @@           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 pe1 pe2 q1 q2   -> join              f j cond pe1 pe2 (self q1) (self q2)+          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)@@ -177,8 +173,8 @@           ForUpdate q                 -> forUpdate         f (self q)         fix g = let x = g x in x -times :: PrimQuery -> PrimQuery -> PrimQuery-times q q' = Product (pure q NEL.:| [pure q']) []+times :: Lateral -> PrimQuery -> PrimQuery -> PrimQuery+times lat q q' = Product (pure q NEL.:| [(lat, q')]) []  restrict :: HPQ.PrimExpr -> PrimQuery -> PrimQuery restrict cond primQ = Product (return (pure primQ)) [cond]

@@ -64,9 +64,9 @@ ppSelectJoin :: Join -> Doc ppSelectJoin j = text "SELECT *"                  $$  text "FROM"-                 $$  ppTable (tableAlias 1 s1)+                 $$  ppTable_tableAlias (1, s1)                  $$  ppJoinType (Sql.jJoinType j)-                 $$  ppTable (tableAlias 2 s2)+                 $$  ppTable_tableAlias (2, s2)                  $$  text "ON"                  $$  HPrint.ppSqlExpr (Sql.jCond j)   where (s1, s2) = Sql.jTables j@@ -127,12 +127,13 @@ ppTables :: [(Sql.Lateral, Select)] -> Doc ppTables [] = empty ppTables ts = text "FROM" <+> HPrint.commaV ppTable_tableAlias (zip [1..] ts)-  where ppTable_tableAlias :: (Int, (Sql.Lateral, Select)) -> Doc-        ppTable_tableAlias (i, (lat, select)) =-          lateral lat $ ppTable (tableAlias i select)-        lateral = \case-            Sql.NonLateral -> id-            Sql.Lateral -> (text "LATERAL" $$)++ppTable_tableAlias :: (Int, (Sql.Lateral, Select)) -> Doc+ppTable_tableAlias (i, (lat, select)) =+  lateral lat $ ppTable (tableAlias i select)+  where lateral = \case+          Sql.NonLateral -> id+          Sql.Lateral -> (text "LATERAL" $$)  tableAlias :: Int -> Select -> (TableAlias, Select) tableAlias i select = ("T" ++ show i, select)

@@ -23,30 +23,55 @@  -- Ideally this should be wrapped in a monad which automatically -- increments the Tag, but I couldn't be bothered to do that.+--+-- The function 'Lateral -> PrimQuery -> PrimQuery' represents a+-- select arrow in the following way:+--+--    Lateral+-- -- ^ Whether to join me laterally+-- -> PrimQuery+-- -- ^ The query that I will be joined after.  If I refer to columns+-- -- in here in a way that is only valid when I am joined laterally,+-- -- then Lateral must be passed in as the argument above.+-- -> PrimQuery+-- -- ^ The result after joining me+--+-- It is *always* valid to pass Lateral as the first argument.  So why+-- wouldn't we do that?  Because we don't want to generate lateral+-- subqueries if they are not needed; it might have performance+-- implications.  Even though there is good evidence that it *doesn't*+-- have performance implications+-- (https://github.com/tomjaguarpaw/haskell-opaleye/pull/480) we still+-- want to be cautious.  -- | A parametrised 'Select'.  A @SelectArr a b@ accepts an argument -- of type @a@. -- -- @SelectArr a b@ is analogous to a Haskell function @a -> [b]@.-newtype SelectArr a b = QueryArr ((a, PQ.PrimQuery, Tag) -> (b, PQ.PrimQuery, Tag))+newtype SelectArr a b = QueryArr ((a, Tag) -> (b, PQ.Lateral -> PQ.PrimQuery -> PQ.PrimQuery, Tag))  type QueryArr = SelectArr type Query = SelectArr ()  productQueryArr :: ((a, Tag) -> (b, PQ.PrimQuery, Tag)) -> QueryArr a b productQueryArr f = QueryArr g-  where g (a0, primQuery, t0) = (a1, PQ.times primQuery primQuery', t1)+  where g (a0, t0) = (a1, \lat primQuery -> PQ.times lat primQuery primQuery', t1)           where (a1, primQuery', t1) = f (a0, t0)  {-# DEPRECATED simpleQueryArr "Use 'productQueryArr' instead. Its name indicates better what it actually does" #-} simpleQueryArr :: ((a, Tag) -> (b, PQ.PrimQuery, Tag)) -> QueryArr a b simpleQueryArr = productQueryArr -runQueryArr :: QueryArr a b -> (a, PQ.PrimQuery, Tag) -> (b, PQ.PrimQuery, Tag)+mapPrimQuery :: (PQ.PrimQuery -> PQ.PrimQuery) -> SelectArr a b -> SelectArr a b+mapPrimQuery f sa =+  QueryArr ((\(b, pqf, t) -> (b, \lat -> f . pqf lat, t)) . runQueryArr sa)++runQueryArr :: QueryArr a b -> (a, Tag) -> (b, PQ.Lateral -> PQ.PrimQuery -> PQ.PrimQuery, Tag) runQueryArr (QueryArr f) = f +-- Unit defines no columns so joining it non-LATERAL is OK. runSimpleQueryArr :: QueryArr a b -> (a, Tag) -> (b, PQ.PrimQuery, Tag)-runSimpleQueryArr f (a, t) = runQueryArr f (a, PQ.Unit, t)+runSimpleQueryArr f = (\(b, pqf, t) -> (b, pqf PQ.NonLateral PQ.Unit, t)) . runQueryArr f  runSimpleQueryArrStart :: QueryArr a b -> a -> (b, PQ.PrimQuery, Tag) runSimpleQueryArrStart q a = runSimpleQueryArr q (a, Tag.start)@@ -77,12 +102,10 @@ lateral :: (i -> Select a) -> SelectArr i a lateral f = QueryArr qa   where-    qa (i, primQueryL, tag) = (a, primQueryJoin, tag')+    qa (i, tag) = (a, primQueryJoin, tag')       where-        (a, primQueryR, tag') = runSimpleQueryArr (f i) ((), tag)-        primQueryJoin = PQ.Product ((PQ.NonLateral, primQueryL)-                                    :| [(PQ.Lateral, primQueryR)])-                                   []+        (a, primQueryR, tag') = runQueryArr (f i) ((), tag)+        primQueryJoin _ = primQueryR PQ.Lateral  -- | Convert an arrow argument into a function argument so that it can -- be applied inside @do@-notation rather than arrow notation.@@ -99,20 +122,22 @@ arrowApply = lateral (\(f, i) -> viaLateral f i)  instance C.Category QueryArr where-  id = QueryArr id-  QueryArr f . QueryArr g = QueryArr (f . g)+  id = arr id+  QueryArr f . QueryArr g = QueryArr (\(a, t) ->+                                        let (b, pqf, t') = g (a, t)+                                            (c, pqf', t'') = f (b, t')+                                        in (c, \lat -> pqf' lat . pqf lat, t''))  instance Arr.Arrow QueryArr where-  arr f   = QueryArr (first3 f)-  first f = QueryArr g-    where g ((b, d), primQ, t0) = ((c, d), primQ', t1)-            where (c, primQ', t1) = runQueryArr f (b, primQ, t0)+  arr f   = QueryArr (\(a, t) -> (f a, const id, t))+  first (QueryArr f) = QueryArr g+    where g ((b, d), t0) = first3 (\c -> (c, d)) (f (b, t0))  instance Arr.ArrowChoice QueryArr where-  left f = QueryArr g-    where g (e, primQ, t0) = case e of-            Left a -> first3 Left (runQueryArr f (a, primQ, t0))-            Right b -> (Right b, primQ, t0)+  left (QueryArr f) = QueryArr g+    where g (e, t0) = case e of+            Left a -> first3 Left (f (a, t0))+            Right b -> (Right b, const id, t0)  instance Arr.ArrowApply QueryArr where   app = arrowApply

@@ -0,0 +1,15 @@+{-# LANGUAGE FlexibleContexts #-}++module Opaleye.Internal.Rebind where++import Data.Profunctor.Product.Default (Default, def)+import Opaleye.Internal.Unpackspec (Unpackspec, runUnpackspec)+import Opaleye.Internal.QueryArr (SelectArr(QueryArr))+import qualified Opaleye.Internal.PackMap as PM+import qualified Opaleye.Internal.PrimQuery as PQ+import qualified Opaleye.Internal.Tag as Tag++rebind :: Default Unpackspec a a => SelectArr a a+rebind = QueryArr (\(a, tag) ->+                     let (b, bindings) = PM.run (runUnpackspec def (PM.extractAttr "rebind" tag) a)+                     in (b, \_ -> PQ.Rebind True bindings, Tag.next tag))

@@ -34,7 +34,9 @@ import qualified Data.Aeson as Ae import qualified Data.CaseInsensitive as CI import qualified Data.Text as ST+import qualified Data.Text.Encoding as STE import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Encoding as LTE import qualified Data.ByteString as SBS import qualified Data.ByteString.Lazy as LBS import qualified Data.Time as Time@@ -254,12 +256,36 @@ instance DefaultFromField T.SqlJson String where   defaultFromField = fieldParserQueryRunnerColumn jsonFieldParser +instance DefaultFromField T.SqlJson ST.Text where+  defaultFromField = fieldParserQueryRunnerColumn jsonFieldTextParser++instance DefaultFromField T.SqlJson LT.Text where+  defaultFromField = fieldParserQueryRunnerColumn jsonFieldLazyTextParser++instance DefaultFromField T.SqlJson SBS.ByteString where+  defaultFromField = fieldParserQueryRunnerColumn jsonFieldByteParser++instance DefaultFromField T.SqlJson LBS.ByteString where+  defaultFromField = fieldParserQueryRunnerColumn jsonFieldLazyByteParser+ instance DefaultFromField T.SqlJson Ae.Value where   defaultFromField = fromPGSFromField  instance DefaultFromField T.SqlJsonb String where   defaultFromField = fieldParserQueryRunnerColumn jsonbFieldParser +instance DefaultFromField T.SqlJsonb ST.Text where+  defaultFromField = fieldParserQueryRunnerColumn jsonbFieldTextParser++instance DefaultFromField T.SqlJsonb LT.Text where+  defaultFromField = fieldParserQueryRunnerColumn jsonbFieldLazyTextParser++instance DefaultFromField T.SqlJsonb SBS.ByteString where+  defaultFromField = fieldParserQueryRunnerColumn jsonbFieldByteParser++instance DefaultFromField T.SqlJsonb LBS.ByteString where+  defaultFromField = fieldParserQueryRunnerColumn jsonbFieldLazyByteParser+ instance DefaultFromField T.SqlJsonb Ae.Value where   defaultFromField = fromPGSFromField @@ -327,6 +353,22 @@ jsonFieldParser  = jsonFieldTypeParser (String.fromString "json") jsonbFieldParser = jsonFieldTypeParser (String.fromString "jsonb") +jsonFieldTextParser, jsonbFieldTextParser :: FieldParser ST.Text+jsonFieldTextParser  = jsonFieldTypeTextParser (String.fromString "json")+jsonbFieldTextParser = jsonFieldTypeTextParser (String.fromString "jsonb")++jsonFieldLazyTextParser, jsonbFieldLazyTextParser :: FieldParser LT.Text+jsonFieldLazyTextParser  = jsonFieldTypeLazyTextParser (String.fromString "json")+jsonbFieldLazyTextParser = jsonFieldTypeLazyTextParser (String.fromString "jsonb")++jsonFieldByteParser, jsonbFieldByteParser :: FieldParser SBS.ByteString+jsonFieldByteParser  = jsonFieldTypeByteParser (String.fromString "json")+jsonbFieldByteParser = jsonFieldTypeByteParser (String.fromString "jsonb")++jsonFieldLazyByteParser, jsonbFieldLazyByteParser :: FieldParser LBS.ByteString+jsonFieldLazyByteParser  = jsonFieldTypeLazyByteParser (String.fromString "json")+jsonbFieldLazyByteParser = jsonFieldTypeLazyByteParser (String.fromString "jsonb")+ -- typenames, not type Oids are used in order to avoid creating -- a dependency on 'Database.PostgreSQL.LibPQ' --@@ -334,15 +376,27 @@ -- --     https://github.com/tomjaguarpaw/haskell-opaleye/issues/329 jsonFieldTypeParser :: SBS.ByteString -> FieldParser String-jsonFieldTypeParser jsonTypeName field mData = do+jsonFieldTypeParser = (fmap . fmap . fmap . fmap) IPT.strictDecodeUtf8 jsonFieldTypeByteParser++jsonFieldTypeTextParser :: SBS.ByteString -> FieldParser ST.Text+jsonFieldTypeTextParser = (fmap . fmap . fmap . fmap) STE.decodeUtf8 jsonFieldTypeByteParser++jsonFieldTypeLazyTextParser :: SBS.ByteString -> FieldParser LT.Text+jsonFieldTypeLazyTextParser = (fmap . fmap . fmap . fmap) (LTE.decodeUtf8 . LBS.fromStrict) jsonFieldTypeByteParser++jsonFieldTypeByteParser :: SBS.ByteString -> FieldParser SBS.ByteString+jsonFieldTypeByteParser jsonTypeName field mData = do     ti <- typeInfo field     if TI.typname ti == jsonTypeName        then convert        else returnError Incompatible field "types incompatible"   where     convert = case mData of-        Just bs -> pure $ IPT.strictDecodeUtf8 bs+        Just bs -> pure bs         _       -> returnError UnexpectedNull field ""++jsonFieldTypeLazyByteParser :: SBS.ByteString -> FieldParser LBS.ByteString+jsonFieldTypeLazyByteParser = (fmap . fmap . fmap . fmap) LBS.fromStrict jsonFieldTypeByteParser  -- } 

@@ -53,7 +53,7 @@  data Join = Join {   jJoinType   :: JoinType,-  jTables     :: (Select, Select),+  jTables     :: ((Lateral, Select), (Lateral, Select)),   jCond       :: HSql.SqlExpr   }                 deriving Show@@ -220,19 +220,16 @@  join :: PQ.JoinType      -> HPQ.PrimExpr-     -> PQ.Bindings HPQ.PrimExpr-     -> PQ.Bindings HPQ.PrimExpr-     -> Select-     -> Select+     -> (PQ.Lateral, Select)+     -> (PQ.Lateral, Select)      -> Select-join j cond pes1 pes2 s1 s2 =+join j cond s1 s2 =   SelectJoin Join { jJoinType = joinType j-                  , jTables   = (selectFrom pes1 s1, selectFrom pes2 s2)+                  , jTables   = (Arr.first lat s1, Arr.first lat s2)                   , jCond     = sqlExpr cond }-  where selectFrom pes s = SelectFrom $ newSelect {-            attrs  = SelectAttrsStar (ensureColumns (map sqlBinding pes))-          , tables = oneTable s-          }+  where lat = \case+          PQ.Lateral -> Lateral+          PQ.NonLateral -> NonLateral  semijoin :: PQ.SemijoinType -> Select -> Select -> Select semijoin t q1 q2 = SelectSemijoin (Semijoin (semijoinType t) q1 q2)

@@ -28,53 +28,24 @@ -- and more composable: -- -- - Inner joins: use 'Opaleye.Operators.restrict' directly (along---   with 'Control.Applicative.<*>' or arrow notation)+--   with @do@ notatation, 'Control.Applicative.<*>', or arrow notation) ----- - Left/right joins: use 'optionalRestrict'+-- - Left/right joins: use 'optional' ----- - Lateral left/right joins: use 'optional'+-- We suspect the following do not have real world use cases.  If you+-- have one then we'd love to hear about it. Please [open a new issue+-- on the Opaleye+-- project](http://github.com/tomjaguarpaw/haskell-opaleye/issues/new)+-- and tell us about it.) --+-- - Left/right joins which really must not use @LATERAL@: use 'optionalRestrict'+-- -- - Full outer joins: use 'Opaleye.FunctionalJoin.fullJoinF' (If you --   have a real-world use case for full outer joins then we'd love to --   hear about it. Please [open a new issue on the Opaleye --   project](http://github.com/tomjaguarpaw/haskell-opaleye/issues/new) --   and tell us about it.) --- | Convenient access to left/right join functionality.  Performs a--- @LEFT JOIN@ under the hood and has behaviour equivalent to the--- following Haskell function:------ @--- optionalRestrict :: [a] -> (a -> Bool) -> [Maybe a]--- optionalRestrict xs p =---    case filter p xs of []  -> [Nothing]---                        xs' -> map Just xs'--- @------ For example,------ @--- > let l = [1, 10, 100, 1000] :: [Field SqlInt4]--- > 'Opaleye.RunSelect.runSelect' conn (proc () -> optionalRestrict ('Opaleye.Values.valuesSafe' l) -\< (.> 100000)) :: IO [Maybe Int]--- [Nothing]------ > 'Opaleye.RunSelect.runSelect' conn (proc () -> optionalRestrict ('Opaleye.Values.valuesSafe' l) -\< (.> 15)) :: IO [Maybe Int]--- [Just 100,Just 1000]--- @------ See the documentation of 'leftJoin' for how to use--- 'optionalRestrict' to replace 'leftJoin' (and by symmetry,--- 'rightJoin').-optionalRestrict :: D.Default U.Unpackspec a a-                 => S.Select a-                 -- ^ Input query-                 -> S.SelectArr (a -> F.Field T.SqlBool) (M.MaybeFields a)-                 -- ^ If any rows of the input query satisfy the-                 -- condition then return them (wrapped in \"Just\").-                 -- If none of them satisfy the condition then return a-                 -- single row of \"Nothing\"-optionalRestrict = J.optionalRestrict- -- | NB Opaleye exports @Opaleye.Table.'Opaleye.Table.optional'@ from -- the top level.  If you want this @optional@ you will have to import -- it from this module.@@ -124,6 +95,41 @@          -- the input query has no rows in which case a single row of          -- \"Nothing\" optional = M.optional++-- | Convenient access to left/right join functionality.  Performs a+-- @LEFT JOIN@ under the hood and has behaviour equivalent to the+-- following Haskell function:+--+-- @+-- optionalRestrict :: [a] -> (a -> Bool) -> [Maybe a]+-- optionalRestrict xs p =+--    case filter p xs of []  -> [Nothing]+--                        xs' -> map Just xs'+-- @+--+-- For example,+--+-- @+-- > let l = [1, 10, 100, 1000] :: [Field SqlInt4]+-- > 'Opaleye.RunSelect.runSelect' conn (proc () -> optionalRestrict ('Opaleye.Values.valuesSafe' l) -\< (.> 100000)) :: IO [Maybe Int]+-- [Nothing]+--+-- > 'Opaleye.RunSelect.runSelect' conn (proc () -> optionalRestrict ('Opaleye.Values.valuesSafe' l) -\< (.> 15)) :: IO [Maybe Int]+-- [Just 100,Just 1000]+-- @+--+-- See the documentation of 'leftJoin' for how to use+-- 'optionalRestrict' to replace 'leftJoin' (and by symmetry,+-- 'rightJoin').+optionalRestrict :: D.Default U.Unpackspec a a+                 => S.Select a+                 -- ^ Input query+                 -> S.SelectArr (a -> F.Field T.SqlBool) (M.MaybeFields a)+                 -- ^ If any rows of the input query satisfy the+                 -- condition then return them (wrapped in \"Just\").+                 -- If none of them satisfy the condition then return a+                 -- single row of \"Nothing\"+optionalRestrict = J.optionalRestrict  -- * Direct access to joins (not recommended) 

@@ -2,10 +2,10 @@   label   ) where -import qualified Opaleye.Internal.Label as L+import qualified Opaleye.Internal.PrimQuery as PQ import qualified Opaleye.Internal.QueryArr as Q import qualified Opaleye.Select            as S  -- | Add a commented label to the generated SQL. label :: String -> S.SelectArr a b -> S.SelectArr a b-label l a = Q.QueryArr (L.label' l . Q.runQueryArr a)+label = Q.mapPrimQuery . PQ.Label

@@ -1,3 +1,8 @@+-- | You will only need this module if you are using the arrow+-- ('Opaleye.Select.SelectArr') interface to Opaleye.  It is not+-- needed when working only with 'Opaleye.Select.Select's and using+-- the monadic (@do@ notation) interface.+ module Opaleye.Lateral   ( lateral   , viaLateral

@@ -156,13 +156,17 @@ {-| Add a @WHERE EXISTS@ clause to the current query. -} restrictExists :: S.SelectArr a b -> S.SelectArr a () restrictExists criteria = QueryArr f where-  f (a, primQ, t0) = ((), PQ.Semijoin PQ.Semi primQ existsQ, t1) where+  -- A where exists clause can always refer to columns defined by the+  -- query it references so needs no special treatment on LATERAL.+  f (a, t0) = ((), \_ primQ -> PQ.Semijoin PQ.Semi primQ existsQ, t1) where     (_, existsQ, t1) = runSimpleQueryArr criteria (a, t0)  {-| Add a @WHERE NOT EXISTS@ clause to the current query. -} restrictNotExists :: S.SelectArr a b -> S.SelectArr a () restrictNotExists criteria = QueryArr f where-  f (a, primQ, t0) = ((), PQ.Semijoin PQ.Anti primQ existsQ, t1) where+  -- A where exists clause can always refer to columns defined by the+  -- query it references so needs no special treatment on LATERAL.+  f (a, t0) = ((), \_ primQ -> PQ.Semijoin PQ.Anti primQ existsQ, t1) where     (_, existsQ, t1) = runSimpleQueryArr criteria (a, t0)  infix 4 .==@@ -496,5 +500,6 @@   restrict  -< p a   A.returnA -< a -now :: Column T.SqlTimestamptz+-- | Current date and time (start of current transaction)+now :: F.Field T.SqlTimestamptz now = Column $ HPQ.FunExpr "now" []