Merge branch 'master' of github.com:circuithub/rel8 into debug

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

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@.

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

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
 

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.

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