diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/Doc/Tutorial/TutorialManipulation.lhs b/Doc/Tutorial/TutorialManipulation.lhs --- a/Doc/Tutorial/TutorialManipulation.lhs +++ b/Doc/Tutorial/TutorialManipulation.lhs @@ -137,7 +137,7 @@ > , uReturning = rCount > } -SET "id" = DEFAULT, +SET "id" = "id", "x" = ("x") + ("y"), "y" = ("x") - ("y"), "s" = "s" diff --git a/Test/Test.hs b/Test/Test.hs --- a/Test/Test.hs +++ b/Test/Test.hs @@ -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 diff --git a/opaleye.cabal b/opaleye.cabal --- a/opaleye.cabal +++ b/opaleye.cabal @@ -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, diff --git a/src/Opaleye/Aggregate.hs b/src/Opaleye/Aggregate.hs --- a/src/Opaleye/Aggregate.hs +++ b/src/Opaleye/Aggregate.hs @@ -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 diff --git a/src/Opaleye/Field.hs b/src/Opaleye/Field.hs --- a/src/Opaleye/Field.hs +++ b/src/Opaleye/Field.hs @@ -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 diff --git a/src/Opaleye/FunctionalJoin.hs b/src/Opaleye/FunctionalJoin.hs --- a/src/Opaleye/FunctionalJoin.hs +++ b/src/Opaleye/FunctionalJoin.hs @@ -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 ((<$>), (<*>)) diff --git a/src/Opaleye/Internal/JSONBuildObjectFields.hs b/src/Opaleye/Internal/JSONBuildObjectFields.hs --- a/src/Opaleye/Internal/JSONBuildObjectFields.hs +++ b/src/Opaleye/Internal/JSONBuildObjectFields.hs @@ -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 diff --git a/src/Opaleye/Internal/Join.hs b/src/Opaleye/Internal/Join.hs --- a/src/Opaleye/Internal/Join.hs +++ b/src/Opaleye/Internal/Join.hs @@ -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 diff --git a/src/Opaleye/Internal/Label.hs b/src/Opaleye/Internal/Label.hs deleted file mode 100644 --- a/src/Opaleye/Internal/Label.hs +++ /dev/null @@ -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) diff --git a/src/Opaleye/Internal/Locking.hs b/src/Opaleye/Internal/Locking.hs --- a/src/Opaleye/Internal/Locking.hs +++ b/src/Opaleye/Internal/Locking.hs @@ -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 diff --git a/src/Opaleye/Internal/MaybeFields.hs b/src/Opaleye/Internal/MaybeFields.hs --- a/src/Opaleye/Internal/MaybeFields.hs +++ b/src/Opaleye/Internal/MaybeFields.hs @@ -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) diff --git a/src/Opaleye/Internal/Operators.hs b/src/Opaleye/Internal/Operators.hs --- a/src/Opaleye/Internal/Operators.hs +++ b/src/Opaleye/Internal/Operators.hs @@ -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 diff --git a/src/Opaleye/Internal/Optimize.hs b/src/Opaleye/Internal/Optimize.hs --- a/src/Opaleye/Internal/Optimize.hs +++ b/src/Opaleye/Internal/Optimize.hs @@ -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 diff --git a/src/Opaleye/Internal/PrimQuery.hs b/src/Opaleye/Internal/PrimQuery.hs --- a/src/Opaleye/Internal/PrimQuery.hs +++ b/src/Opaleye/Internal/PrimQuery.hs @@ -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] diff --git a/src/Opaleye/Internal/Print.hs b/src/Opaleye/Internal/Print.hs --- a/src/Opaleye/Internal/Print.hs +++ b/src/Opaleye/Internal/Print.hs @@ -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) diff --git a/src/Opaleye/Internal/QueryArr.hs b/src/Opaleye/Internal/QueryArr.hs --- a/src/Opaleye/Internal/QueryArr.hs +++ b/src/Opaleye/Internal/QueryArr.hs @@ -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 diff --git a/src/Opaleye/Internal/Rebind.hs b/src/Opaleye/Internal/Rebind.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Internal/Rebind.hs @@ -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)) diff --git a/src/Opaleye/Internal/RunQuery.hs b/src/Opaleye/Internal/RunQuery.hs --- a/src/Opaleye/Internal/RunQuery.hs +++ b/src/Opaleye/Internal/RunQuery.hs @@ -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 -- } diff --git a/src/Opaleye/Internal/Sql.hs b/src/Opaleye/Internal/Sql.hs --- a/src/Opaleye/Internal/Sql.hs +++ b/src/Opaleye/Internal/Sql.hs @@ -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) diff --git a/src/Opaleye/Join.hs b/src/Opaleye/Join.hs --- a/src/Opaleye/Join.hs +++ b/src/Opaleye/Join.hs @@ -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) diff --git a/src/Opaleye/Label.hs b/src/Opaleye/Label.hs --- a/src/Opaleye/Label.hs +++ b/src/Opaleye/Label.hs @@ -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 diff --git a/src/Opaleye/Lateral.hs b/src/Opaleye/Lateral.hs --- a/src/Opaleye/Lateral.hs +++ b/src/Opaleye/Lateral.hs @@ -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 diff --git a/src/Opaleye/Operators.hs b/src/Opaleye/Operators.hs --- a/src/Opaleye/Operators.hs +++ b/src/Opaleye/Operators.hs @@ -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" []