diff --git a/Rel8.hs b/Rel8.hs index 413e6af..99baee9 100644 --- a/Rel8.hs +++ b/Rel8.hs @@ -32,6 +32,7 @@ module Rel8 , queryTable , leftJoin , leftJoinA + , fullJoin , unionAll , exceptAll , O.restrictExists, O.restrictNotExists @@ -57,7 +58,8 @@ module Rel8 , countRows, Aggregate -- * Tables - , MaybeTable, isTableNull + , MaybeTable, isTableNull, maybeTable + , TheseTable, theseTable , Col(..) -- * Expressions @@ -248,6 +250,26 @@ leftJoinA q = pqR , O.next t') + +-------------------------------------------------------------------------------- +-- | Take the @FULL OUTER JOIN@ of two queries. +fullJoin + :: (Table left a, Table right b, Predicate bool) + => (left -> right -> Expr bool) -- ^ The condition to join upon. + -> O.Query left -- ^ The left table + -> O.Query right -- ^ The right table + -> O.Query (TheseTable left right) +fullJoin condition l r = uncurry TheseTable <$> + O.fullJoinExplicit + unpackColumns + unpackColumns + (O.NullMaker (\(tag, t) -> MaybeTable tag t)) + (O.NullMaker (\(tag, t) -> MaybeTable tag t)) + (liftA2 (,) (pure (lit (Just False))) l) + (liftA2 (,) (pure (lit (Just False))) r) + (\((_, a), (_, b)) -> exprToColumn (toNullable (condition a b))) + + -- | Take only distinct rows in a 'O.Query'. This maps to grouping by every -- column in the table. distinct :: Table table haskell => O.Query table -> O.Query table diff --git a/Rel8/Internal/Aggregate.hs b/Rel8/Internal/Aggregate.hs index 16f3bfa..3682781 100644 --- a/Rel8/Internal/Aggregate.hs +++ b/Rel8/Internal/Aggregate.hs @@ -11,6 +11,7 @@ import Data.Int (Int16, Int32, Int64) import Data.Scientific (Scientific) import Data.Text (Text) import Data.Time (UTCTime, LocalTime) +import Data.Vector (Vector) import qualified Opaleye.Aggregate as O import qualified Opaleye.Internal.HaskellDB.PrimQuery as O import qualified Opaleye.Internal.QueryArr as O @@ -101,7 +102,7 @@ boolAnd :: Expr Bool -> Aggregate Bool boolAnd (Expr a) = Aggregate (Just (O.AggrBoolAnd, [], O.AggrAll)) a -- | Aggregate with @array_agg@. -arrayAgg :: Expr a -> Aggregate [a] +arrayAgg :: Expr a -> Aggregate (Vector a) arrayAgg (Expr a) = Aggregate (Just (O.AggrArr, [], O.AggrAll)) a -- | Aggregate with @string_agg@. diff --git a/Rel8/Internal/DBType.hs b/Rel8/Internal/DBType.hs index 0e9f855..0387d9a 100644 --- a/Rel8/Internal/DBType.hs +++ b/Rel8/Internal/DBType.hs @@ -22,6 +22,7 @@ import Control.Category ((.)) import Data.Aeson (Value) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as LazyByteString +import Data.CaseInsensitive (CI) import Data.Foldable (toList) import Data.Functor.Contravariant (Contravariant(..)) import Data.Int (Int16, Int32, Int64) @@ -109,6 +110,10 @@ instance DBType a => instance DBType Text where dbTypeInfo = typeInfoFromOpaleye O.pgStrictText +-- | ci text +instance DBType (CI Text) where + dbTypeInfo = typeInfoFromOpaleye O.pgCiStrictText + -- | text instance a ~ Char => DBType [a] where dbTypeInfo = contramap pack dbTypeInfo @@ -125,6 +130,10 @@ instance DBType UTCTime where instance DBType LazyText.Text where dbTypeInfo = typeInfoFromOpaleye O.pgLazyText +-- | ci text +instance DBType (CI LazyText.Text) where + dbTypeInfo = typeInfoFromOpaleye O.pgCiLazyText + -- | bytea instance DBType LazyByteString.ByteString where dbTypeInfo = typeInfoFromOpaleye O.pgLazyByteString diff --git a/Rel8/Internal/Operators.hs b/Rel8/Internal/Operators.hs index 6c06ebb..583b57a 100644 --- a/Rel8/Internal/Operators.hs +++ b/Rel8/Internal/Operators.hs @@ -6,6 +6,7 @@ module Rel8.Internal.Operators where +import Data.CaseInsensitive (CI) import Data.Int (Int16, Int32, Int64) import Data.Text (Text) import Data.Time (UTCTime, Day) @@ -68,6 +69,7 @@ instance DBEq Int16 where instance DBEq Int32 where instance DBEq Int64 where instance DBEq Text where +instance DBEq (CI Text) where instance DBEq UTCTime where instance DBEq Day where @@ -98,6 +100,7 @@ instance DBOrd Int16 where instance DBOrd Int32 where instance DBOrd Int64 where instance DBOrd Text where +instance DBOrd (CI Text) where instance DBOrd UTCTime where instance DBOrd Day where diff --git a/Rel8/Internal/Table.hs b/Rel8/Internal/Table.hs index fd9b153..4e2c2af 100644 --- a/Rel8/Internal/Table.hs +++ b/Rel8/Internal/Table.hs @@ -21,10 +21,11 @@ import Control.Applicative import Control.Lens (Iso', from, iso, view) import Control.Monad (replicateM_) import Data.Aeson (FromJSON, ToJSON) +import Data.Bifunctor import Data.Foldable (traverse_) import Data.Functor.Identity import Data.Functor.Product -import Data.Functor.Rep (Representable, index, mzipWithRep, tabulate, pureRep) +import Data.Functor.Rep (Representable, index, liftR3, mzipWithRep, tabulate, pureRep) import qualified Data.Functor.Rep as Representable import Data.Maybe (fromMaybe) import Data.Profunctor (dimap) @@ -38,6 +39,7 @@ import qualified Opaleye.Aggregate as O import qualified Opaleye.Column as O import qualified Opaleye.Internal.Aggregate as O import qualified Opaleye.Internal.Binary as O +import qualified Opaleye.Internal.Column as O import qualified Opaleye.Internal.HaskellDB.PrimQuery as O import qualified Opaleye.Internal.PackMap as O import qualified Opaleye.Internal.QueryArr as O @@ -50,6 +52,7 @@ import Prelude hiding (not, id) import Rel8.Internal.DBType import Rel8.Internal.Expr import Rel8.Internal.Types +import Data.These ( These( This, That, These ) ) type family MkRowF a :: * -> * where MkRowF (M1 i c f) = MkRowF f @@ -181,6 +184,76 @@ f $? MaybeTable _ x = toNullable (f x) isTableNull :: MaybeTable a -> Expr Bool isTableNull (MaybeTable tag _) = nullable (lit True) (\_ -> lit False) tag + +maybeTable :: Table b haskell + => b -> (a -> b) -> MaybeTable a -> b +maybeTable b f (MaybeTable tag a) = + view (from expressions) $ mzipWithRep (ifNull tag) + (view expressions b) + (view expressions (f a)) + where + ifNull :: Expr (Maybe Bool) -> O.PrimExpr -> O.PrimExpr -> O.PrimExpr + ifNull conditional true false = unColumn $ O.matchNullable + (O.Column true) + (\_ -> O.Column false) + (exprToColumn conditional) + where + unColumn (O.Column result) = result + + +-------------------------------------------------------------------------------- +-- | A pair of 'Table's where at most one might be @null@. This is the result of +-- an @FULL OUTER JOIN@ between tables. +data TheseTable a b = TheseTable (MaybeTable a) (MaybeTable b) + deriving (Functor) + + +instance Bifunctor TheseTable where + bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b) + + +-- | The result of a full outer join is a pair of tables, but one of the tables +-- may be entirely @null@ sometimes. +instance (Table exprA a, Table exprB b) => Table (TheseTable exprA exprB) (These a b) where + type RowF (TheseTable exprA exprB) = + Product (RowF (MaybeTable exprA)) (RowF (MaybeTable exprB)) + + expressions = dimap back (fmap forth) + where + back (TheseTable a b) = + Pair (view expressions a) (view expressions b) + forth (Pair a b) = + TheseTable (view (from expressions) a) (view (from expressions) b) + + rowParser = do + ma <- rowParser + mb <- rowParser + case (ma, mb) of + (Just a, Just b) -> pure $ These a b + (Just a, _) -> pure $ This a + (_, Just b) -> pure $ That b + _ -> empty + + +theseTable :: Table c haskell + => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable a b -> c +theseTable f g h (TheseTable (MaybeTable aNull a) (MaybeTable bNull b)) = + view (from expressions) $ liftR3 go + (view expressions (f a)) + (view expressions (g b)) + (view expressions (h a b)) + where + ifNull :: Expr (Maybe Bool) -> O.PrimExpr -> O.PrimExpr -> O.PrimExpr + ifNull conditional true false = unColumn $ O.matchNullable + (O.Column true) + (\_ -> O.Column false) + (exprToColumn conditional) + where + unColumn (O.Column result) = result + + go this that these = ifNull bNull this (ifNull aNull that these) + + -------------------------------------------------------------------------------- -- | Eliminate 'Maybe' from the type of an 'Expr'. Like 'maybe' for Haskell -- values. diff --git a/rel8.cabal b/rel8.cabal index 9a9ba83..c271323 100644 --- a/rel8.cabal +++ b/rel8.cabal @@ -48,6 +48,7 @@ library build-depends: aeson , base >=4.9 && <4.14 , bytestring + , case-insensitive , contravariant , exceptions , free @@ -63,6 +64,7 @@ library , streaming-postgresql-simple , tagged >=0.8 && <0.9 , text + , these , time , transformers , unliftio >= 0.2.7.0 && < 0.3