From 397ef4da6f67d753921757db4c0229eb22d0d2e3 Mon Sep 17 00:00:00 2001
From: Oliver Charles <ollie@ocharles.org.uk>
Date: Tue, 28 Jan 2020 10:11:21 +0000
Subject: [PATCH] catNulls, but the type don't fit

---
 src/Rel8.hs            |  2 +-
 src/Rel8/MonadQuery.hs | 47 ++++++++++++++++++++++--------------------
 src/Rel8/Tests.hs      |  8 ++++---
 3 files changed, 31 insertions(+), 26 deletions(-)

diff --git a/src/Rel8.hs b/src/Rel8.hs
index 8e3d1f2..85bdba4 100644
--- a/src/Rel8.hs
+++ b/src/Rel8.hs
@@ -19,7 +19,7 @@ module Rel8
   , Table
   , each
   , where_
-  -- , filterMap
+  , catNulls
   , limit
   , offset
   , union
diff --git a/src/Rel8/MonadQuery.hs b/src/Rel8/MonadQuery.hs
index 502d9e1..89ba8a1 100644
--- a/src/Rel8/MonadQuery.hs
+++ b/src/Rel8/MonadQuery.hs
@@ -16,7 +16,7 @@
 
 module Rel8.MonadQuery where
 
-import Control.Applicative ( liftA2 )
+import Control.Applicative ( Const(..), liftA2 )
 import Data.Functor.Identity
 import Numeric.Natural
 import Rel8.Column
@@ -293,27 +293,30 @@ where_ x =
     ( (), Opaleye.restrict ( toPrimExpr x ) left, t )
 
 
--- filterMap
---   :: forall a nullA b nullB m
---    . ( Compatible nullA ( Null ( Expr m ) ) a ( Expr m )
---      , Compatible b ( Expr m ) nullB ( Null ( Expr m ) )
---      , Table a, Table b, Context a ~ Context b
---      , Table nullA, Table nullB, Context nullA ~ Context nullB
---      , MonadQuery m
---      )
---   => ( nullA -> nullB ) -> m a -> m b
--- filterMap f q = do
---   x <-
---     q
+catNulls
+  :: forall a b m
+   . ( MonadQuery m
+     , Context a ~ Expr m
+     , Context b ~ Expr m
+     , MapTable NotNull a ~ b
+     , Recontextualise a NotNull
+     )
+  => m a -> m b
+catNulls q = do
+  x <-
+    q
 
---   let
---     y =
---       f ( mapTable ( mapC liftNull ) x )
+  let
+    allNotNull :: [ Expr m Bool ]
+    allNotNull =
+      getConst
+        ( runIdentity
+            <$> traverseTable
+                  @Id
+                  ( traverseC ( \expr -> Const [ isNull ( retype expr ) ] ) )
+                  ( Identity x )
+        )
 
---     allNotNull :: [ Expr m Bool ]
---     allNotNull =
---       getConst ( traverseTable @nullB ( traverseC ( \expr -> Const [ isNull expr ] ) ) y )
+  where_ ( and_ allNotNull )
 
---   where_ ( and_ allNotNull )
-
---   return ( mapTable ( mapC retype ) y )
+  return ( mapTable @NotNull ( mapC retype ) x )
diff --git a/src/Rel8/Tests.hs b/src/Rel8/Tests.hs
index 2b4138f..dba6a94 100644
--- a/src/Rel8/Tests.hs
+++ b/src/Rel8/Tests.hs
@@ -13,6 +13,7 @@ import Data.Monoid
 import Database.PostgreSQL.Simple ( Connection )
 import GHC.Generics
 import Rel8
+import Rel8.Column
 
 
 data Part f =
@@ -262,9 +263,10 @@ select_maybeTable :: Connection -> IO [ Maybe ( HasNull Identity ) ]
 select_maybeTable c =
   select c maybeTableQ
 
--- filterMapTest :: MonadQuery m => m _
--- filterMapTest =
---   filterMap nullId ( each hasNull )
+
+catNullsTest :: MonadQuery m => m ( NotNull ( Expr m ) Int32 )
+catNullsTest =
+  catNulls ( nullId <$> each hasNull )
 
 
 unionTest :: MonadQuery m => m ( Part ( Expr m ) )