opaleye 0.5.1.1 → 0.5.2.0

raw patch · 24 files changed

+414/−123 lines, 24 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• Test/Test.hs +26/−1
• opaleye.cabal +5/−4
• src/Opaleye.hs +17/−0
• src/Opaleye/Binary.hs +1/−1
• src/Opaleye/Column.hs +2/−2
• src/Opaleye/FunctionalJoin.hs +141/−0
• src/Opaleye/Internal/Column.hs +7/−3
• src/Opaleye/Internal/HaskellDB/PrimQuery.hs +3/−2
• src/Opaleye/Internal/HaskellDB/Sql.hs +1/−1
• src/Opaleye/Internal/HaskellDB/Sql/Default.hs +4/−1
• src/Opaleye/Internal/HaskellDB/Sql/Print.hs +1/−1
• src/Opaleye/Internal/Join.hs +23/−8
• src/Opaleye/Internal/Operators.hs +22/−0
• src/Opaleye/Internal/Optimize.hs +1/−1
• src/Opaleye/Internal/PrimQuery.hs +23/−14
• src/Opaleye/Internal/Print.hs +5/−2
• src/Opaleye/Internal/RunQuery.hs +4/−0
• src/Opaleye/Internal/Sql.hs +16/−4
• src/Opaleye/Join.hs +57/−52
• src/Opaleye/Manipulation.hs +22/−22
• src/Opaleye/Operators.hs +20/−2
• src/Opaleye/RunQuery.hs +2/−2
• src/Opaleye/Table.hs +4/−0

@@ -1,3 +1,10 @@+## 0.5.2.0++* Added `Opaleye.FunctionalJoin`+* Fixed handling of `BinExpr OpIn _ (ListExpr _)` in `defaultSqlExpr`.+* `in_` now actually uses the SQL `IN` operator.+* Added support for `ILIKE`+ ## 0.5.1.0  * Added

@@ -346,6 +346,16 @@           O.restrict -< fst t .== 1           Arr.returnA -< t +testIn :: Test+testIn = testG query expected+  where query = proc () -> do+          t <- table1Q -< ()+          O.restrict -< O.in_ [O.pgInt4 100, O.pgInt4 200] (snd t)+          O.restrict -< O.not (O.in_ [] (fst t)) -- Making sure empty lists work.+          Arr.returnA -< t+        expected = \r ->+          filter (flip elem [100, 200] . snd) (L.sort table1data) == L.sort r+ testNum :: Test testNum = testG query expected   where query :: Query (Column O.PGInt4)@@ -596,6 +606,20 @@                    , ((1, 50), ((Just 1, Just 100), (Just 1, Just 50)))                    , ((1, 50), ((Just 1, Just 200), (Just 1, Just 50))) ] +testLeftJoinF :: Test+testLeftJoinF = testG q (== expected)+  where q = O.leftJoinF (,)+                        (\x -> (x, (-1, -2)))+                        (\l r -> fst l .== fst r)+                        table1Q+                        table3Q++        expected :: [((Int, Int), (Int, Int))]+        expected = [ ((1, 100), (1, 50))+                   , ((1, 100), (1, 50))+                   , ((1, 200), (1, 50))+                   , ((2, 300), (-1, -2)) ]+ testThreeWayProduct :: Test testThreeWayProduct = testG q (== expected)   where q = A.liftA3 (,,) table1Q table2Q table3Q@@ -835,10 +859,11 @@             testDistinct, testAggregate, testAggregate0, testAggregateFunction,             testAggregateProfunctor, testStringArrayAggregate, testStringAggregate,             testOrderBy, testOrderBy2, testOrderBySame, testLimit, testOffset,-            testLimitOffset, testOffsetLimit, testDistinctAndAggregate,+            testLimitOffset, testOffsetLimit, testDistinctAndAggregate, testIn,             testDoubleDistinct, testDoubleAggregate, testDoubleLeftJoin,             testDoubleValues, testDoubleUnionAll,             testLeftJoin, testLeftJoinNullable, testThreeWayProduct, testValues,+            testLeftJoinF,             testValuesEmpty, testUnionAll, testTableFunctor, testUpdate,             testKeywordColNames, testInsertSerial, testInQuery, testAtTimeZone,             testStringArrayAggregateOrdered, testMultipleAggregateOrdered,

@@ -1,6 +1,6 @@ name:            opaleye copyright:       Copyright (c) 2014-2016 Purely Agile Limited-version:         0.5.1.1+version:         0.5.2.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@@ -13,10 +13,10 @@ maintainer:      Purely Agile category:        Database build-type:      Simple-cabal-version:   >= 1.10+cabal-version:   >= 1.18 extra-doc-files: *.md,                  Doc/*.md-tested-with:     GHC==7.10.1, GHC==7.8.4, GHC==7.6.3+tested-with:     GHC==8.0.1, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3  source-repository head   type:     git@@ -52,6 +52,7 @@                    Opaleye.Column,                    Opaleye.Constant,                    Opaleye.Distinct,+                   Opaleye.FunctionalJoin,                    Opaleye.Join,                    Opaleye.Label,                    Opaleye.Manipulation,@@ -99,7 +100,7 @@   other-modules: QuickCheck   hs-source-dirs: Test   build-depends:-    aeson >= 0.6 && < 0.12,+    aeson >= 0.6 && < 1.1,     base >= 4 && < 5,     containers,     contravariant,

@@ -1,8 +1,24 @@+-- | An SQL-generating DSL targeting PostgreSQL.  Allows Postgres+--   queries to be written within Haskell in a typesafe and composable+--   fashion.+--+-- You might like to look at+--+-- * <https://github.com/tomjaguarpaw/haskell-opaleye/blob/master/Doc/Tutorial/TutorialBasic.lhs Basic tutorial>+--+-- * <https://github.com/tomjaguarpaw/haskell-opaleye/blob/master/Doc/Tutorial/TutorialManipulation.lhs Manipulation tutorial>+--+-- * <https://github.com/tomjaguarpaw/haskell-opaleye/blob/master/Doc/Tutorial/TutorialAdvanced.lhs Advanced tutorial>+--+-- * If you are confused about the @Default@ typeclass, then+-- the <https://github.com/tomjaguarpaw/haskell-opaleye/blob/master/Doc/Tutorial/DefaultExplanation.lhs Default explanation>+ module Opaleye ( module Opaleye.Aggregate                , module Opaleye.Binary                , module Opaleye.Column                , module Opaleye.Constant                , module Opaleye.Distinct+               , module Opaleye.FunctionalJoin                , module Opaleye.Join                , module Opaleye.Label                , module Opaleye.Manipulation@@ -21,6 +37,7 @@ import Opaleye.Column import Opaleye.Constant import Opaleye.Distinct+import Opaleye.FunctionalJoin import Opaleye.Join import Opaleye.Label import Opaleye.Manipulation

@@ -23,7 +23,7 @@ -- functions would allow violation of SQL's scoping rules and lead to -- invalid queries. ----- `unionAll` is very close to being the @<|>@ operator of a+-- `unionAll` is very close to being the @\<|\>@ operator of a -- @Control.Applicative.Alternative@ instance but it fails to work -- only because of the typeclass constraint it has. 

@@ -3,8 +3,8 @@ -- Please note that numeric 'Column' types are instances of 'Num', so -- you can use '*', '/', '+', '-' on them. -module Opaleye.Column (module Opaleye.Column,-                       Column,+module Opaleye.Column (Column,+                       module Opaleye.Column,                        Nullable,                        unsafeCast,                        unsafeCoerce,

@@ -0,0 +1,141 @@+-- | Left, right, and full outer joins.+--+-- The interface in this module is much nicer than the standard \"make+-- missing rows NULL\" interface that SQL provides.  If you really+-- want the standard interface then use "Opaleye.Join".++{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Opaleye.FunctionalJoin where++import           Control.Applicative             ((<$>), (<*>))+import           Control.Arrow                   ((<<<))++import qualified Data.Profunctor.Product.Default as D+import qualified Data.Profunctor.Product         as PP++import qualified Opaleye.Column                  as C+import           Opaleye.Internal.Column         (Column, Nullable)+import qualified Opaleye.Internal.Join           as IJ+import qualified Opaleye.Internal.Operators      as IO+import qualified Opaleye.Internal.Unpackspec     as IU+import qualified Opaleye.Join                    as J+import qualified Opaleye.PGTypes                 as T+import qualified Opaleye.Operators               as O+import           Opaleye.QueryArr                (Query)++joinF :: (columnsL -> columnsR -> columnsResult)+      -- ^ Calculate result columns from input columns+      -> (columnsL -> columnsR -> Column T.PGBool)+      -- ^ Condition on which to join+      -> Query columnsL+      -- ^ Left query+      -> Query columnsR+      -- ^ Right query+      -> Query columnsResult+joinF f cond l r =+  fmap (uncurry f) (O.keepWhen (uncurry cond) <<< ((,) <$> l <*> r))++leftJoinF :: (D.Default IO.IfPP columnsResult columnsResult,+              D.Default IU.Unpackspec columnsL columnsL,+              D.Default IU.Unpackspec columnsR columnsR)+          => (columnsL -> columnsR -> columnsResult)+          -- ^ Calculate result row from input rows for rows in the+          -- right query satisfying the join condition+          -> (columnsL -> columnsResult)+          -- ^ Calculate result row from input row when there are /no/+          -- rows in the right query satisfying the join condition+          -> (columnsL -> columnsR -> Column T.PGBool)+          -- ^ Condition on which to join+          -> Query columnsL+          -- ^ Left query+          -> Query columnsR+          -- ^ Right query+          -> Query columnsResult+leftJoinF f fL cond l r = fmap ret j+  where a1 = fmap (\x -> (x, T.pgBool True))+        j  = J.leftJoinExplicit D.def+                                D.def+                                (PP.p2 ((IJ.NullMaker id), nullmakerBool))+                                l+                                (a1 r)+                                (\(l', (r', _)) -> cond l' r')++        ret (lr, (rr, rc)) = O.ifThenElseMany (C.isNull rc) (fL lr) (f lr rr)++        nullmakerBool :: IJ.NullMaker (Column T.PGBool)+                                      (Column (Nullable T.PGBool))+        nullmakerBool = D.def++rightJoinF :: (D.Default IO.IfPP columnsResult columnsResult,+               D.Default IU.Unpackspec columnsL columnsL,+               D.Default IU.Unpackspec columnsR columnsR)+           => (columnsL -> columnsR -> columnsResult)+           -- ^ Calculate result row from input rows for rows in the+           -- left query satisfying the join condition+           -> (columnsR -> columnsResult)+           -- ^ Calculate result row from input row when there are /no/+           -- rows in the left query satisfying the join condition+           -> (columnsL -> columnsR -> Column T.PGBool)+           -- ^ Condition on which to join+           -> Query columnsL+           -- ^ Left query+           -> Query columnsR+           -- ^ Right query+           -> Query columnsResult+rightJoinF f fR cond l r = fmap ret j+  where a1 = fmap (\x -> (x, T.pgBool True))+        j  = J.rightJoinExplicit D.def+                                 D.def+                                 (PP.p2 ((IJ.NullMaker id), nullmakerBool))+                                 (a1 l)+                                 r+                                 (\((l', _), r') -> cond l' r')++        ret ((lr, lc), rr) = O.ifThenElseMany (C.isNull lc) (fR rr) (f lr rr)++        nullmakerBool :: IJ.NullMaker (Column T.PGBool)+                                      (Column (Nullable T.PGBool))+        nullmakerBool = D.def++fullJoinF :: (D.Default IO.IfPP columnsResult columnsResult,+              D.Default IU.Unpackspec columnsL columnsL,+              D.Default IU.Unpackspec columnsR columnsR)+          => (columnsL -> columnsR -> columnsResult)+           -- ^ Calculate result row from input rows for rows in the+           -- left and right query satisfying the join condition+          -> (columnsL -> columnsResult)+           -- ^ Calculate result row from left input row when there+           -- are /no/ rows in the right query satisfying the join+           -- condition+          -> (columnsR -> columnsResult)+           -- ^ Calculate result row from right input row when there+           -- are /no/ rows in the left query satisfying the join+           -- condition+          -> (columnsL -> columnsR -> Column T.PGBool)+          -- ^ Condition on which to join+          -> Query columnsL+          -- ^ Left query+          -> Query columnsR+          -- ^ Right query+          -> Query columnsResult+fullJoinF f fL fR cond l r = fmap ret j+  where a1 = fmap (\x -> (x, T.pgBool True))+        j  = J.fullJoinExplicit D.def+                                D.def+                                (PP.p2 ((IJ.NullMaker id), nullmakerBool))+                                (PP.p2 ((IJ.NullMaker id), nullmakerBool))+                                (a1 l)+                                (a1 r)+                                (\((l', _), (r', _)) -> cond l' r')++        ret ((lr, lc), (rr, rc)) = O.ifThenElseMany (C.isNull lc)+                                     (fR rr)+                                     (O.ifThenElseMany (C.isNull rc)+                                        (fL lr)+                                        (f lr rr))++        nullmakerBool :: IJ.NullMaker (Column T.PGBool)+                                      (Column (Nullable T.PGBool))+        nullmakerBool = D.def

@@ -4,10 +4,14 @@  import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ -newtype Column a = Column HPQ.PrimExpr deriving Show+-- | A column of a @Query@, of type @pgType@.  For example 'Column'+-- @PGInt4@ is an @int4@ column and a 'Column' @PGText@ is a @text@+-- column.+newtype Column pgType = Column HPQ.PrimExpr deriving Show --- | Only used within a 'Column', to indicate that it can take null--- values.+-- | Only used within a 'Column', to indicate that it can be @NULL@.+-- For example, a 'Column' ('Nullable' @PGText@) can be @NULL@ but a+-- 'Column' @PGText@ cannot. data Nullable a = Nullable  unColumn :: Column a -> HPQ.PrimExpr

@@ -6,6 +6,7 @@  import qualified Opaleye.Internal.Tag as T import Data.ByteString (ByteString)+import qualified Data.List.NonEmpty as NEL  type TableName  = String type Attribute  = String@@ -23,7 +24,7 @@                 | AggrExpr  AggrOp PrimExpr [OrderExpr]                 | ConstExpr Literal                 | CaseExpr [(PrimExpr,PrimExpr)] PrimExpr-                | ListExpr [PrimExpr]+                | ListExpr (NEL.NonEmpty PrimExpr)                 | ParamExpr (Maybe Name) PrimExpr                 | FunExpr Name [PrimExpr]                 | CastExpr Name PrimExpr -- ^ Cast an expression to a given type.@@ -47,7 +48,7 @@  data BinOp      = (:==) | (:<) | (:<=) | (:>) | (:>=) | (:<>)                 | OpAnd | OpOr-                | OpLike | OpIn+                | OpLike | OpILike | OpIn                 | OpOther String                  | (:||)

@@ -41,7 +41,7 @@              | AggrFunSqlExpr String [SqlExpr] [(SqlExpr, SqlOrder)] -- ^ Aggregate functions separate from normal functions.              | ConstSqlExpr   String              | CaseSqlExpr    (NEL.NonEmpty (SqlExpr,SqlExpr)) SqlExpr-             | ListSqlExpr    [SqlExpr]+             | ListSqlExpr    (NEL.NonEmpty SqlExpr)              | ParamSqlExpr (Maybe SqlName) SqlExpr              | PlaceHolderSqlExpr              | ParensSqlExpr SqlExpr

@@ -100,6 +100,8 @@                 (paren leftE, rightE)               (OpOr, _, BinExpr OpAnd _ _) ->                 (leftE, paren rightE)+              (OpIn, _, ListExpr _) ->+                (leftE, rightE)               (_, ConstExpr _, ConstExpr _) ->                 (leftE, rightE)               (_, _, ConstExpr _) ->@@ -133,7 +135,7 @@                           in case NEL.nonEmpty cs' of                             Just nel -> CaseSqlExpr nel e'                             Nothing  -> e'-      ListExpr es      -> ListSqlExpr (map (sqlExpr gen) es)+      ListExpr es      -> ListSqlExpr (fmap (sqlExpr gen) es)       ParamExpr n _    -> ParamSqlExpr n PlaceHolderSqlExpr       FunExpr n exprs  -> FunSqlExpr n (map (sqlExpr gen) exprs)       CastExpr typ e1 -> CastSqlExpr typ (sqlExpr gen e1)@@ -150,6 +152,7 @@ showBinOp  OpAnd        = "AND" showBinOp  OpOr         = "OR" showBinOp  OpLike       = "LIKE"+showBinOp  OpILike      = "ILIKE" showBinOp  OpIn         = "IN" showBinOp  (OpOther s)  = s showBinOp  (:||)        = "||"

@@ -130,7 +130,7 @@                              <+> text "ELSE" <+> ppSqlExpr el <+> text "END"           where ppWhen (w,t) = text "WHEN" <+> ppSqlExpr w                                <+> text "THEN" <+> ppSqlExpr t-      ListSqlExpr es      -> parens (commaH ppSqlExpr es)+      ListSqlExpr es      -> parens (commaH ppSqlExpr (NEL.toList es))       ParamSqlExpr _ v -> ppSqlExpr v       PlaceHolderSqlExpr -> text "?"       CastSqlExpr typ e -> text "CAST" <> parens (ppSqlExpr e <+> text "AS" <+> text typ)

@@ -2,7 +2,10 @@  module Opaleye.Internal.Join where -import qualified Opaleye.Internal.Tag as T+import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ+import qualified Opaleye.Internal.PackMap             as PM+import qualified Opaleye.Internal.Tag                 as T+import qualified Opaleye.Internal.Unpackspec          as U import           Opaleye.Internal.Column (Column(Column), Nullable) import qualified Opaleye.Internal.QueryArr as Q import qualified Opaleye.Internal.PrimQuery as PQ@@ -21,29 +24,41 @@ toNullable (NullMaker f) = f  instance D.Default NullMaker (Column a) (Column (Nullable a)) where-  def = NullMaker C.unsafeCoerceColumn+  def = NullMaker C.toNullable  instance D.Default NullMaker (Column (Nullable a)) (Column (Nullable a)) where-  def = NullMaker C.unsafeCoerceColumn+  def = NullMaker id -joinExplicit :: (columnsA -> returnedColumnsA)+joinExplicit :: U.Unpackspec columnsA columnsA+             -> U.Unpackspec columnsB columnsB+             -> (columnsA -> returnedColumnsA)              -> (columnsB -> returnedColumnsB)              -> PQ.JoinType              -> Q.Query columnsA -> Q.Query columnsB              -> ((columnsA, columnsB) -> Column T.PGBool)              -> Q.Query (returnedColumnsA, returnedColumnsB)-joinExplicit returnColumnsA returnColumnsB joinType+joinExplicit uA uB returnColumnsA returnColumnsB joinType              qA qB cond = Q.simpleQueryArr q where   q ((), startTag) = ((nullableColumnsA, nullableColumnsB), primQueryR, T.next endTag)     where (columnsA, primQueryA, midTag) = Q.runSimpleQueryArr qA ((), startTag)           (columnsB, primQueryB, endTag) = Q.runSimpleQueryArr qB ((), midTag) -          nullableColumnsA = returnColumnsA columnsA-          nullableColumnsB = returnColumnsB columnsB+          (newColumnsA, ljPEsA) =+            PM.run (U.runUnpackspec uA (extractLeftJoinFields 1 endTag) columnsA)+          (newColumnsB, ljPEsB) =+            PM.run (U.runUnpackspec uB (extractLeftJoinFields 2 endTag) columnsB) +          nullableColumnsA = returnColumnsA newColumnsA+          nullableColumnsB = returnColumnsB newColumnsB+           Column cond' = cond (columnsA, columnsB)-          primQueryR = PQ.Join joinType cond' primQueryA primQueryB+          primQueryR = PQ.Join joinType cond' ljPEsA ljPEsB primQueryA primQueryB +extractLeftJoinFields :: Int+                      -> T.Tag+                      -> HPQ.PrimExpr+                      -> PM.PM [(HPQ.Symbol, HPQ.PrimExpr)] HPQ.PrimExpr+extractLeftJoinFields n = PM.extractAttr ("result" ++ show n ++ "_")  -- { Boilerplate instances 

@@ -39,6 +39,19 @@   def = EqPP C.unsafeEq  +newtype IfPP a b = IfPP (Column T.PGBool -> a -> a -> b)++ifExplict :: IfPP columns columns'+          -> Column T.PGBool+          -> columns+          -> columns+          -> columns'+ifExplict (IfPP f) = f++instance D.Default IfPP (Column a) (Column a) where+  def = IfPP C.unsafeIfThenElse++ -- This seems to be the only place we use ViewColumnMaker now. data RelExprMaker a b =   forall c. RelExprMaker {@@ -97,4 +110,13 @@                                     h vcmf vcmg cmf cmg     where h vcmg vcmf cmg cmf = RelExprMaker (vcmg ***! vcmf)                                              (cmg  ***! cmf)++instance Profunctor IfPP where+  dimap f g (IfPP h) = IfPP (\b a a' -> g (h b (f a) (f a')))++instance ProductProfunctor IfPP where+  empty = IfPP (\_ () () -> ())+  IfPP f ***! IfPP f' = IfPP (\b a a1 ->+                               (f b (fst a) (fst a1), f' b (snd a) (snd a1)))+ -- }

@@ -43,7 +43,7 @@   , PQ.aggregate = fmap . PQ.Aggregate   , PQ.order     = fmap . PQ.Order   , PQ.limit     = fmap . PQ.Limit-  , PQ.join      = \jt pe pq1 pq2 -> PQ.Join jt pe <$> pq1 <*> pq2+  , PQ.join      = \jt pe pes1 pes2 pq1 pq2 -> PQ.Join jt pe pes1 pes2 <$> pq1 <*> pq2   , PQ.values    = return .: PQ.Values   , PQ.binary    = \case       -- Some unfortunate duplication here

@@ -29,9 +29,7 @@ tiToSqlTable ti = HSql.SqlTable { HSql.sqlTableSchemaName = tiSchemaName ti                                 , HSql.sqlTableName       = tiTableName ti } ---- In the future it may make sense to introduce this datatype--- type Bindings a = [(Symbol, a)]+type Bindings a = [(Symbol, a)]  -- We use a 'NEL.NonEmpty' for Product because otherwise we'd have to check -- for emptiness explicity in the SQL generation phase.@@ -43,19 +41,24 @@ -- SQL so we remove it in 'Optimize' and set 'a = Void'. data PrimQuery' a = Unit                   | Empty     a-                  | BaseTable TableIdentifier [(Symbol, HPQ.PrimExpr)]+                  | BaseTable TableIdentifier (Bindings HPQ.PrimExpr)                   | Product   (NEL.NonEmpty (PrimQuery' a)) [HPQ.PrimExpr]-                  | Aggregate [(Symbol, (Maybe (HPQ.AggrOp, [HPQ.OrderExpr]), HPQ.PrimExpr))]+                  | Aggregate (Bindings (Maybe (HPQ.AggrOp, [HPQ.OrderExpr]), HPQ.PrimExpr))                               (PrimQuery' a)                   | Order     [HPQ.OrderExpr] (PrimQuery' a)                   | Limit     LimitOp (PrimQuery' a)-                  | Join      JoinType HPQ.PrimExpr (PrimQuery' a) (PrimQuery' a)+                  | Join      JoinType+                              HPQ.PrimExpr+                              (Bindings HPQ.PrimExpr)+                              (Bindings HPQ.PrimExpr)+                              (PrimQuery' a)+                              (PrimQuery' a)                   | Values    [Symbol] (NEL.NonEmpty [HPQ.PrimExpr])                   | Binary    BinOp-                              [(Symbol, (HPQ.PrimExpr, HPQ.PrimExpr))]+                              (Bindings (HPQ.PrimExpr, HPQ.PrimExpr))                               (PrimQuery' a, PrimQuery' a)                   | Label     String (PrimQuery' a)-                  | RelExpr   HPQ.PrimExpr [(Symbol, HPQ.PrimExpr)]+                  | RelExpr   HPQ.PrimExpr (Bindings HPQ.PrimExpr)                  deriving Show  type PrimQuery = PrimQuery' ()@@ -64,16 +67,22 @@ data PrimQueryFold' a p = PrimQueryFold   { unit      :: p   , empty     :: a -> p-  , baseTable :: TableIdentifier -> [(Symbol, HPQ.PrimExpr)] -> p+  , baseTable :: TableIdentifier -> (Bindings HPQ.PrimExpr) -> p   , product   :: NEL.NonEmpty p -> [HPQ.PrimExpr] -> p-  , aggregate :: [(Symbol, (Maybe (HPQ.AggrOp, [HPQ.OrderExpr]), HPQ.PrimExpr))] -> p -> p+  , aggregate :: (Bindings (Maybe (HPQ.AggrOp, [HPQ.OrderExpr]), HPQ.PrimExpr)) -> p -> p   , order     :: [HPQ.OrderExpr] -> p -> p   , limit     :: LimitOp -> p -> p-  , join      :: JoinType -> HPQ.PrimExpr -> p -> p -> p+  , join      :: JoinType+              -> HPQ.PrimExpr+              -> (Bindings HPQ.PrimExpr)+              -> (Bindings HPQ.PrimExpr)+              -> p+              -> p+              -> p   , values    :: [Symbol] -> (NEL.NonEmpty [HPQ.PrimExpr]) -> p-  , binary    :: BinOp -> [(Symbol, (HPQ.PrimExpr, HPQ.PrimExpr))] -> (p, p) -> p+  , binary    :: BinOp -> (Bindings (HPQ.PrimExpr, HPQ.PrimExpr)) -> (p, p) -> p   , label     :: String -> p -> p-  , relExpr   :: HPQ.PrimExpr -> [(Symbol, HPQ.PrimExpr)] -> p+  , relExpr   :: HPQ.PrimExpr -> (Bindings HPQ.PrimExpr) -> p     -- ^ A relation-valued expression   } @@ -104,7 +113,7 @@           Aggregate aggrs q         -> aggregate f aggrs (self q)           Order pes q               -> order     f pes (self q)           Limit op q                -> limit     f op (self q)-          Join j cond q1 q2         -> join      f j cond (self q1) (self q2)+          Join j cond pe1 pe2 q1 q2 -> join      f j cond pe1 pe2 (self q1) (self q2)           Values ss pes             -> values    f ss pes           Binary binop pes (q1, q2) -> binary    f binop pes (self q1, self q2)           Label l pq                -> label     f l (self pq)

@@ -25,6 +25,7 @@ ppSql :: Select -> Doc ppSql (SelectFrom s)   = ppSelectFrom s ppSql (Table table)    = HPrint.ppTable table+ppSql (RelExpr expr)   = HPrint.ppSqlExpr expr ppSql (SelectJoin j)   = ppSelectJoin j ppSql (SelectValues v) = ppSelectValues v ppSql (SelectBinary v) = ppSelectBinary v@@ -78,8 +79,10 @@ ppJoinType Sql.FullJoin = text "FULL OUTER JOIN"  ppAttrs :: Sql.SelectAttrs -> Doc-ppAttrs Sql.Star             = text "*"-ppAttrs (Sql.SelectAttrs xs) = (HPrint.commaV nameAs . NEL.toList) xs+ppAttrs Sql.Star                 = text "*"+ppAttrs (Sql.SelectAttrs xs)     = (HPrint.commaV nameAs . NEL.toList) xs+ppAttrs (Sql.SelectAttrsStar xs) =+  HPrint.commaV id ((map nameAs . NEL.toList) xs ++ [text "*"])  -- This is pretty much just nameAs from HaskellDB nameAs :: (HSql.SqlExpr, Maybe HSql.SqlColumn) -> Doc

@@ -72,6 +72,10 @@ instance Functor (QueryRunnerColumn u) where   fmap f ~(QueryRunnerColumn u fp) = QueryRunnerColumn u ((fmap . fmap . fmap) f fp) +-- | A 'QueryRunner' specifies how to convert Postgres values (@columns@)+--   into Haskell values (@haskells@).  Most likely you will never need+--   to create on of these or handle one directly.  It will be provided+--   for you by the 'D.Default' 'QueryRunner' instance. data QueryRunner columns haskells =   QueryRunner (U.Unpackspec columns ())               (columns -> RowParser haskells)

@@ -31,6 +31,7 @@ data SelectAttrs =     Star   | SelectAttrs (NEL.NonEmpty (HSql.SqlExpr, Maybe HSql.SqlColumn))+  | SelectAttrsStar (NEL.NonEmpty (HSql.SqlExpr, Maybe HSql.SqlColumn))   deriving Show  data From = From {@@ -155,10 +156,21 @@           PQ.OffsetOp n        -> (Nothing, Just n)           PQ.LimitOffsetOp l o -> (Just l, Just o) -join :: PQ.JoinType -> HPQ.PrimExpr -> Select -> Select -> Select-join j cond s1 s2 = SelectJoin Join { jJoinType = joinType j-                                    , jTables = (s1, s2)-                                    , jCond = sqlExpr cond }+join :: PQ.JoinType+     -> HPQ.PrimExpr+     -> PQ.Bindings HPQ.PrimExpr+     -> PQ.Bindings HPQ.PrimExpr+     -> Select+     -> Select+     -> Select+join j cond pes1 pes2 s1 s2 =+  SelectJoin Join { jJoinType = joinType j+                  , jTables   = (selectFrom pes1 s1, selectFrom pes2 s2)+                  , jCond     = sqlExpr cond }+  where selectFrom pes s = SelectFrom $ newSelect {+            attrs  = SelectAttrsStar (ensureColumns (map sqlBinding pes))+          , tables = [s]+          }  -- Postgres seems to name columns of VALUES clauses "column1", -- "column2", ... . I'm not sure to what extent it is customisable or

@@ -1,5 +1,11 @@--- | Left, right, and full outer joins.  If you want inner joins, just use 'restrict' instead.+-- | Left, right, and full outer joins. --+-- "Opaleye.FunctionalJoin" provides a much nicer, Haskelly, interface+-- to joins than this module, which sticks to the (horrible) standard+-- \"make missing rows NULL\" interface that SQL provides.+--+-- If you want inner joins, just use 'restrict' instead.+-- -- The use of the 'D.Default' typeclass means that the compiler will -- have trouble inferring types.  It is strongly recommended that you -- provide full type signatures when using the join functions.@@ -13,7 +19,9 @@ --          -> Query ((Column a, Column b), (Column (Nullable c), Column (Nullable d))) -- @ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}  module Opaleye.Join where @@ -26,63 +34,60 @@  import qualified Data.Profunctor.Product.Default as D -leftJoin  :: (D.Default U.Unpackspec columnsA columnsA,-              D.Default U.Unpackspec columnsB columnsB,-              D.Default J.NullMaker columnsB nullableColumnsB)-          => Query columnsA  -- ^ Left query-          -> Query columnsB  -- ^ Right query-          -> ((columnsA, columnsB) -> Column T.PGBool) -- ^ Condition on which to join-          -> Query (columnsA, nullableColumnsB) -- ^ Left join+leftJoin  :: (D.Default U.Unpackspec columnsL columnsL,+              D.Default U.Unpackspec columnsR columnsR,+              D.Default J.NullMaker columnsR nullableColumnsR)+          => Query columnsL  -- ^ Left query+          -> Query columnsR  -- ^ Right query+          -> ((columnsL, columnsR) -> Column T.PGBool) -- ^ Condition on which to join+          -> Query (columnsL, nullableColumnsR) -- ^ Left join leftJoin = leftJoinExplicit D.def D.def D.def -rightJoin  :: (D.Default U.Unpackspec columnsA columnsA,-               D.Default U.Unpackspec columnsB columnsB,-               D.Default J.NullMaker columnsA nullableColumnsA)-           => Query columnsA -- ^ Left query-           -> Query columnsB -- ^ Right query-           -> ((columnsA, columnsB) -> Column T.PGBool) -- ^ Condition on which to join-           -> Query (nullableColumnsA, columnsB) -- ^ Right join+rightJoin  :: (D.Default U.Unpackspec columnsL columnsL,+               D.Default U.Unpackspec columnsR columnsR,+               D.Default J.NullMaker columnsL nullableColumnsL)+           => Query columnsL -- ^ Left query+           -> Query columnsR -- ^ Right query+           -> ((columnsL, columnsR) -> Column T.PGBool) -- ^ Condition on which to join+           -> Query (nullableColumnsL, columnsR) -- ^ Right join rightJoin = rightJoinExplicit D.def D.def D.def  -fullJoin  :: (D.Default U.Unpackspec columnsA columnsA,-              D.Default U.Unpackspec columnsB columnsB,-              D.Default J.NullMaker columnsA nullableColumnsA,-              D.Default J.NullMaker columnsB nullableColumnsB)-          => Query columnsA -- ^ Left query-          -> Query columnsB -- ^ Right query-          -> ((columnsA, columnsB) -> Column T.PGBool) -- ^ Condition on which to join-          -> Query (nullableColumnsA, nullableColumnsB) -- ^ Full outer join+fullJoin  :: (D.Default U.Unpackspec columnsL columnsL,+              D.Default U.Unpackspec columnsR columnsR,+              D.Default J.NullMaker columnsL nullableColumnsL,+              D.Default J.NullMaker columnsR nullableColumnsR)+          => Query columnsL -- ^ Left query+          -> Query columnsR -- ^ Right query+          -> ((columnsL, columnsR) -> Column T.PGBool) -- ^ Condition on which to join+          -> Query (nullableColumnsL, nullableColumnsR) -- ^ Full outer join fullJoin = fullJoinExplicit D.def D.def D.def D.def --- We don't actually need the Unpackspecs any more, but I'm going to--- leave them here in case they're ever needed again.  I don't want to--- have to break the API to add them back.-leftJoinExplicit :: U.Unpackspec columnsA columnsA-                 -> U.Unpackspec columnsB columnsB-                 -> J.NullMaker columnsB nullableColumnsB-                 -> Query columnsA -> Query columnsB-                 -> ((columnsA, columnsB) -> Column T.PGBool)-                 -> Query (columnsA, nullableColumnsB)-leftJoinExplicit _ _ nullmaker =-  J.joinExplicit id (J.toNullable nullmaker) PQ.LeftJoin+leftJoinExplicit :: U.Unpackspec columnsL columnsL+                 -> U.Unpackspec columnsR columnsR+                 -> J.NullMaker columnsR nullableColumnsR+                 -> Query columnsL -> Query columnsR+                 -> ((columnsL, columnsR) -> Column T.PGBool)+                 -> Query (columnsL, nullableColumnsR)+leftJoinExplicit uA uB nullmaker =+  J.joinExplicit uA uB id (J.toNullable nullmaker) PQ.LeftJoin -rightJoinExplicit :: U.Unpackspec columnsA columnsA-                  -> U.Unpackspec columnsB columnsB-                  -> J.NullMaker columnsA nullableColumnsA-                  -> Query columnsA -> Query columnsB-                  -> ((columnsA, columnsB) -> Column T.PGBool)-                  -> Query (nullableColumnsA, columnsB)-rightJoinExplicit _ _ nullmaker =-  J.joinExplicit (J.toNullable nullmaker) id PQ.RightJoin+rightJoinExplicit :: U.Unpackspec columnsL columnsL+                  -> U.Unpackspec columnsR columnsR+                  -> J.NullMaker columnsL nullableColumnsL+                  -> Query columnsL -> Query columnsR+                  -> ((columnsL, columnsR) -> Column T.PGBool)+                  -> Query (nullableColumnsL, columnsR)+rightJoinExplicit uA uB nullmaker =+  J.joinExplicit uA uB (J.toNullable nullmaker) id PQ.RightJoin  -fullJoinExplicit :: U.Unpackspec columnsA columnsA-                 -> U.Unpackspec columnsB columnsB-                 -> J.NullMaker columnsA nullableColumnsA-                 -> J.NullMaker columnsB nullableColumnsB-                 -> Query columnsA -> Query columnsB-                 -> ((columnsA, columnsB) -> Column T.PGBool)-                 -> Query (nullableColumnsA, nullableColumnsB)-fullJoinExplicit _ _ nullmakerA nullmakerB =-  J.joinExplicit (J.toNullable nullmakerA) (J.toNullable nullmakerB) PQ.FullJoin+fullJoinExplicit :: U.Unpackspec columnsL columnsL+                 -> U.Unpackspec columnsR columnsR+                 -> J.NullMaker columnsL nullableColumnsL+                 -> J.NullMaker columnsR nullableColumnsR+                 -> Query columnsL -> Query columnsR+                 -> ((columnsL, columnsR) -> Column T.PGBool)+                 -> Query (nullableColumnsL, nullableColumnsR)+fullJoinExplicit uA uB nullmakerA nullmakerB =+  J.joinExplicit uA uB (J.toNullable nullmakerA) (J.toNullable nullmakerB) PQ.FullJoin

@@ -66,14 +66,14 @@ -- compiler will have trouble inferring types.  It is strongly -- recommended that you provide full type signatures when using -- @runInsertManyReturning@.-runInsertManyReturning :: (D.Default RQ.QueryRunner returned haskells)+runInsertManyReturning :: (D.Default RQ.QueryRunner columnsReturned haskells)                        => PGS.Connection                        -- ^                        -> T.Table columnsW columnsR                        -- ^ Table to insert into                        -> [columnsW]                        -- ^ Rows to insert-                       -> (columnsR -> returned)+                       -> (columnsR -> columnsReturned)                        -- ^ Function @f@ to apply to the inserted rows                        -> IO [haskells]                        -- ^ Returned rows after @f@ has been applied@@ -90,7 +90,7 @@           -- 'runUpdate' will update rows for which @f@ returns @TRUE@           -- and leave unchanged rows for which @f@ returns @FALSE@.           -> IO Int64-          -- ^ The number of updated rows+          -- ^ The number of rows updated runUpdate conn = PGS.execute_ conn . fromString .:. arrangeUpdateSql  @@ -100,7 +100,7 @@ -- that the compiler will have trouble inferring types.  It is -- strongly recommended that you provide full type signatures when -- using @runInsertReturning@.-runUpdateReturning :: (D.Default RQ.QueryRunner returned haskells)+runUpdateReturning :: (D.Default RQ.QueryRunner columnsReturned haskells)                    => PGS.Connection                    -- ^                    -> T.Table columnsW columnsR@@ -112,7 +112,7 @@                    -- update.  'runUpdate' will update rows for which                    -- @f@ returns @TRUE@ and leave unchanged rows for                    -- which @f@ returns @FALSE@.-                   -> (columnsR -> returned)+                   -> (columnsR -> columnsReturned)                    -- ^ Functon @g@ to apply to the updated rows                    -> IO [haskells]                    -- ^ Returned rows after @g@ has been applied@@ -128,18 +128,18 @@           -- 'runDelete' will delete rows for which @f@ returns @TRUE@           -- and leave unchanged rows for which @f@ returns @FALSE@.           -> IO Int64-          -- ^ The number of deleted rows+          -- ^ The number of rows deleted runDelete conn = PGS.execute_ conn . fromString .: arrangeDeleteSql  -- | You probably don't need this, but can just use -- 'runInsertReturning' instead.  You only need it if you want to run -- an INSERT RETURNING statement but need to be explicit about the -- 'QueryRunner'.-runInsertReturningExplicit :: RQ.QueryRunner returned haskells+runInsertReturningExplicit :: RQ.QueryRunner columnsReturned haskells                            -> PGS.Connection                            -> T.Table columnsW columnsR                            -> columnsW-                           -> (columnsR -> returned)+                           -> (columnsR -> columnsReturned)                            -> IO [haskells] runInsertReturningExplicit qr conn t =   runInsertManyReturningExplicit qr conn t . return@@ -148,11 +148,11 @@ -- 'runInsertManyReturning' instead.  You only need it if you want to -- run an UPDATE RETURNING statement but need to be explicit about the -- 'QueryRunner'.-runInsertManyReturningExplicit :: RQ.QueryRunner returned haskells+runInsertManyReturningExplicit :: RQ.QueryRunner columnsReturned haskells                                -> PGS.Connection                                -> T.Table columnsW columnsR                                -> [columnsW]-                               -> (columnsR -> returned)+                               -> (columnsR -> columnsReturned)                                -> IO [haskells] runInsertManyReturningExplicit qr conn t columns r =   case NEL.nonEmpty columns of@@ -170,12 +170,12 @@ -- 'runUpdateReturning' instead.  You only need it if you want to run -- an UPDATE RETURNING statement but need to be explicit about the -- 'QueryRunner'.-runUpdateReturningExplicit :: RQ.QueryRunner returned haskells+runUpdateReturningExplicit :: RQ.QueryRunner columnsReturned haskells                            -> PGS.Connection                            -> T.Table columnsW columnsR                            -> (columnsR -> columnsW)                            -> (columnsR -> Column PGBool)-                           -> (columnsR -> returned)+                           -> (columnsR -> columnsReturned)                            -> IO [haskells] runUpdateReturningExplicit qr conn t update cond r =   PGS.queryWith_ parser conn@@ -197,11 +197,11 @@ -- -- This will be deprecated in a future release.  Use -- 'runInsertManyReturning' instead.-runInsertReturning :: (D.Default RQ.QueryRunner returned haskells)+runInsertReturning :: (D.Default RQ.QueryRunner columnsReturned haskells)                    => PGS.Connection                    -> T.Table columnsW columnsR                    -> columnsW-                   -> (columnsR -> returned)+                   -> (columnsR -> columnsReturned)                    -> IO [haskells] runInsertReturning = runInsertReturningExplicit D.def @@ -265,10 +265,10 @@  -- | For internal use only.  Do not use.  Will be removed in a -- subsequent release.-arrangeInsertManyReturning :: U.Unpackspec returned ignored+arrangeInsertManyReturning :: U.Unpackspec columnsReturned ignored                            -> T.Table columnsW columnsR                            -> NEL.NonEmpty columnsW-                           -> (columnsR -> returned)+                           -> (columnsR -> columnsReturned)                            -> Sql.Returning HSql.SqlInsert arrangeInsertManyReturning unpackspec table columns returningf =   Sql.Returning insert returningSEs@@ -279,21 +279,21 @@  -- | For internal use only.  Do not use.  Will be removed in a -- subsequent release.-arrangeInsertManyReturningSql :: U.Unpackspec returned ignored+arrangeInsertManyReturningSql :: U.Unpackspec columnsReturned ignored                               -> T.Table columnsW columnsR                               -> NEL.NonEmpty columnsW-                              -> (columnsR -> returned)+                              -> (columnsR -> columnsReturned)                               -> String arrangeInsertManyReturningSql =   show . Print.ppInsertReturning .:: arrangeInsertManyReturning  -- | For internal use only.  Do not use.  Will be removed in a -- subsequent release.-arrangeUpdateReturning :: U.Unpackspec returned ignored+arrangeUpdateReturning :: U.Unpackspec columnsReturned ignored                        -> T.Table columnsW columnsR                        -> (columnsR -> columnsW)                        -> (columnsR -> Column PGBool)-                       -> (columnsR -> returned)+                       -> (columnsR -> columnsReturned)                        -> Sql.Returning HSql.SqlUpdate arrangeUpdateReturning unpackspec table updatef cond returningf =   Sql.Returning update returningSEs@@ -304,11 +304,11 @@  -- | For internal use only.  Do not use.  Will be removed in a -- subsequent release.-arrangeUpdateReturningSql :: U.Unpackspec returned ignored+arrangeUpdateReturningSql :: U.Unpackspec columnsReturned ignored                           -> T.Table columnsW columnsR                           -> (columnsR -> columnsW)                           -> (columnsR -> Column PGBool)-                          -> (columnsR -> returned)+                          -> (columnsR -> columnsReturned)                           -> String arrangeUpdateReturningSql =   show . Print.ppUpdateReturning .::. arrangeUpdateReturning

@@ -9,6 +9,7 @@  import qualified Control.Arrow as A import qualified Data.Foldable as F+import qualified Data.List.NonEmpty as NEL  import           Opaleye.Internal.Column (Column(Column), unsafeCase_,                                           unsafeIfThenElse, unsafeGt)@@ -91,9 +92,20 @@ case_ :: [(Column T.PGBool, Column a)] -> Column a -> Column a case_ = unsafeCase_ +-- | Monomorphic if\/then\/else.+--+-- This may be replaced by 'ifThenElseMany' in a future version. ifThenElse :: Column T.PGBool -> Column a -> Column a -> Column a ifThenElse = unsafeIfThenElse +-- | Polymorphic if\/then\/else.+ifThenElseMany :: D.Default O.IfPP columns columns+               => Column T.PGBool+               -> columns+               -> columns+               -> columns+ifThenElseMany = O.ifExplict D.def+ infixr 2 .||  -- | Boolean or@@ -119,6 +131,10 @@ like :: Column T.PGText -> Column T.PGText -> Column T.PGBool like = C.binOp HPQ.OpLike +-- | Postgres @ILIKE@ operator+ilike :: Column T.PGText -> Column T.PGText -> Column T.PGBool+ilike = C.binOp HPQ.OpILike+ charLength :: C.PGString a => Column a -> Column Int charLength (Column e) = Column (HPQ.FunExpr "char_length" [e]) @@ -132,7 +148,9 @@ -- product.  'in_' @validProducts@ is a function which checks whether -- a product is a valid product. in_ :: (Functor f, F.Foldable f) => f (Column a) -> Column a -> Column T.PGBool-in_ hs w = ors . fmap (w .==) $ hs+in_ fcas (Column a) = Column $ case NEL.nonEmpty (F.toList fcas) of+   Nothing -> HPQ.ConstExpr (HPQ.BoolLit False)+   Just xs -> HPQ.BinExpr HPQ.OpIn a (HPQ.ListExpr (fmap C.unColumn xs))  -- | True if the first argument occurs amongst the rows of the second, -- false otherwise.@@ -156,7 +174,7 @@         qj = Join.leftJoin (A.arr (const 1))                            (Distinct.distinct q')                            (uncurry (.==))-                          +         -- Check whether it is 'NULL'         qj' :: Query (Column T.PGBool)         qj' = A.arr (Opaleye.Operators.not

@@ -29,14 +29,14 @@ -- Example type specialization: -- -- @--- runQuery :: Query (Column 'Opaleye.PGTypes.PGInt4', Column 'Opaleye.PGTypes.PGText') -> IO [(Column Int, Column String)]+-- runQuery :: Query (Column 'Opaleye.PGTypes.PGInt4', Column 'Opaleye.PGTypes.PGText') -> IO [(Int, String)] -- @ -- -- Assuming the @makeAdaptorAndInstance@ splice has been run for the product type @Foo@: -- -- @ -- runQuery :: Query (Foo (Column 'Opaleye.PGTypes.PGInt4') (Column 'Opaleye.PGTypes.PGText') (Column 'Opaleye.PGTypes.PGBool')---          -> IO [(Foo (Column Int) (Column String) (Column Bool)]+--          -> IO [Foo Int String Bool] -- @ -- -- Opaleye types are converted to Haskell types based on instances of

@@ -40,11 +40,15 @@   f ((), t0) = (retwires, primQ, Tag.next t0) where     (retwires, primQ) = T.queryTable cm table t0 +-- | 'required' is for columns which are not 'optional'.  You must+-- provide them on writes. required :: String -> TableProperties (Column a) (Column a) required columnName = T.TableProperties   (T.required columnName)   (View (Column (HPQ.BaseTableAttrExpr columnName))) +-- | 'optional' is for columns that you can omit on writes, such as+--  columns which have defaults or which are SERIAL. optional :: String -> TableProperties (Maybe (Column a)) (Column a) optional columnName = T.TableProperties   (T.optional columnName)