diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/Test/Test.hs b/Test/Test.hs --- a/Test/Test.hs +++ b/Test/Test.hs @@ -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, diff --git a/opaleye.cabal b/opaleye.cabal --- a/opaleye.cabal +++ b/opaleye.cabal @@ -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, diff --git a/src/Opaleye.hs b/src/Opaleye.hs --- a/src/Opaleye.hs +++ b/src/Opaleye.hs @@ -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 +-- +-- * +-- +-- * +-- +-- * +-- +-- * If you are confused about the @Default@ typeclass, then +-- the + 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 diff --git a/src/Opaleye/Binary.hs b/src/Opaleye/Binary.hs --- a/src/Opaleye/Binary.hs +++ b/src/Opaleye/Binary.hs @@ -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. diff --git a/src/Opaleye/Column.hs b/src/Opaleye/Column.hs --- a/src/Opaleye/Column.hs +++ b/src/Opaleye/Column.hs @@ -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, diff --git a/src/Opaleye/FunctionalJoin.hs b/src/Opaleye/FunctionalJoin.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/FunctionalJoin.hs @@ -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 diff --git a/src/Opaleye/Internal/Column.hs b/src/Opaleye/Internal/Column.hs --- a/src/Opaleye/Internal/Column.hs +++ b/src/Opaleye/Internal/Column.hs @@ -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 diff --git a/src/Opaleye/Internal/HaskellDB/PrimQuery.hs b/src/Opaleye/Internal/HaskellDB/PrimQuery.hs --- a/src/Opaleye/Internal/HaskellDB/PrimQuery.hs +++ b/src/Opaleye/Internal/HaskellDB/PrimQuery.hs @@ -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 | (:||) diff --git a/src/Opaleye/Internal/HaskellDB/Sql.hs b/src/Opaleye/Internal/HaskellDB/Sql.hs --- a/src/Opaleye/Internal/HaskellDB/Sql.hs +++ b/src/Opaleye/Internal/HaskellDB/Sql.hs @@ -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 diff --git a/src/Opaleye/Internal/HaskellDB/Sql/Default.hs b/src/Opaleye/Internal/HaskellDB/Sql/Default.hs --- a/src/Opaleye/Internal/HaskellDB/Sql/Default.hs +++ b/src/Opaleye/Internal/HaskellDB/Sql/Default.hs @@ -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 (:||) = "||" diff --git a/src/Opaleye/Internal/HaskellDB/Sql/Print.hs b/src/Opaleye/Internal/HaskellDB/Sql/Print.hs --- a/src/Opaleye/Internal/HaskellDB/Sql/Print.hs +++ b/src/Opaleye/Internal/HaskellDB/Sql/Print.hs @@ -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) 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 @@ -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 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 @@ -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))) + -- } 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 @@ -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 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 @@ -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) 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 @@ -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 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 @@ -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) 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 @@ -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 diff --git a/src/Opaleye/Join.hs b/src/Opaleye/Join.hs --- a/src/Opaleye/Join.hs +++ b/src/Opaleye/Join.hs @@ -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 diff --git a/src/Opaleye/Manipulation.hs b/src/Opaleye/Manipulation.hs --- a/src/Opaleye/Manipulation.hs +++ b/src/Opaleye/Manipulation.hs @@ -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 diff --git a/src/Opaleye/Operators.hs b/src/Opaleye/Operators.hs --- a/src/Opaleye/Operators.hs +++ b/src/Opaleye/Operators.hs @@ -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 diff --git a/src/Opaleye/RunQuery.hs b/src/Opaleye/RunQuery.hs --- a/src/Opaleye/RunQuery.hs +++ b/src/Opaleye/RunQuery.hs @@ -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 diff --git a/src/Opaleye/Table.hs b/src/Opaleye/Table.hs --- a/src/Opaleye/Table.hs +++ b/src/Opaleye/Table.hs @@ -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)