From 2f7cf86a0b99c84e0fba134e361148d1224ea905 Mon Sep 17 00:00:00 2001
From: Raveline <adrien.duclos@scrive.com>
Date: Tue, 27 Aug 2024 14:04:38 +0200
Subject: [PATCH] Make recursive associative in an or-like fashion

---
 .../PostgreSQL/PQTypes/SQL/Builder.hs         | 38 +++++++------------
 test/Main.hs                                  |  9 ++++-
 2 files changed, 20 insertions(+), 27 deletions(-)

diff --git a/src/Database/PostgreSQL/PQTypes/SQL/Builder.hs b/src/Database/PostgreSQL/PQTypes/SQL/Builder.hs
index 7918824..b1983af 100644
--- a/src/Database/PostgreSQL/PQTypes/SQL/Builder.hs
+++ b/src/Database/PostgreSQL/PQTypes/SQL/Builder.hs
@@ -132,7 +132,6 @@ module Database.PostgreSQL.PQTypes.SQL.Builder
   , sqlUnion
   , sqlUnionAll
   , checkAndRememberMaterializationSupport
-  , checkAndRememberRecursiveSupport
 
   , sqlSelect
   , sqlSelect2
@@ -452,16 +451,6 @@ checkAndRememberMaterializationSupport = do
     fetchOne runIdentity
   liftIO $ writeIORef withMaterializedSupported (isRight res)
 
--- This function has to be called as one of first things in your program
--- for the library to make sure that it is aware if the "WITH RECURSIVE"
--- clause is supported by your PostgreSQL version.
-checkAndRememberRecursiveSupport :: (MonadDB m, MonadIO m, MonadMask m) => m ()
-checkAndRememberRecursiveSupport = do
-  res :: Either DBException Int64 <- try . withNewConnection $ do
-    runSQL01_ "WITH RECURSIVE t(n) AS (SELECT (1 :: bigint)) SELECT n FROM t LIMIT 1"
-    fetchOne runIdentity
-  liftIO $ writeIORef withRecursiveSupported (isRight res)
-
 withMaterializedSupported :: IORef Bool
 {-# NOINLINE withMaterializedSupported #-}
 withMaterializedSupported = unsafePerformIO $ newIORef False
@@ -470,20 +459,12 @@ isWithMaterializedSupported :: Bool
 {-# NOINLINE isWithMaterializedSupported #-}
 isWithMaterializedSupported = unsafePerformIO $ readIORef withMaterializedSupported
 
-withRecursiveSupported :: IORef Bool
-{-# NOINLINE withRecursiveSupported #-}
-withRecursiveSupported = unsafePerformIO $ newIORef False
-
-isWithRecursiveSupported :: Bool
-{-# NOINLINE isWithRecursiveSupported #-}
-isWithRecursiveSupported = unsafePerformIO $ readIORef withRecursiveSupported
-
 materializedClause :: Materialized -> SQL
 materializedClause Materialized = if isWithMaterializedSupported then "MATERIALIZED" else ""
 materializedClause NonMaterialized = if isWithMaterializedSupported then "NOT MATERIALIZED" else ""
 
 recursiveClause :: Recursive -> SQL
-recursiveClause Recursive = if isWithRecursiveSupported then "WITH RECURSIVE" else "WITH"
+recursiveClause Recursive = "WITH RECURSIVE"
 recursiveClause NonRecursive = "WITH"
 
 instance Sqlable SqlUpdate where
@@ -559,21 +540,28 @@ sqlDelete table refine =
 data Materialized = Materialized | NonMaterialized
 data Recursive = Recursive | NonRecursive
 
+-- This instance guarantees that once a single CTE has
+-- been marked as recursive, the whole "WITH" block will
+-- get the RECURSIVE keyword associated to it.
+instance Semigroup Recursive where
+  _ <> Recursive = Recursive
+  Recursive <> _ = Recursive
+  _ <> _ = NonRecursive
+
 class SqlWith a where
   sqlWith1 :: a -> SQL -> SQL -> Materialized -> Recursive -> a
 
-
 instance SqlWith SqlSelect where
-  sqlWith1 cmd name sql mat recurse = cmd { sqlSelectWith = sqlSelectWith cmd ++ [(name,sql,mat)], sqlSelectRecursiveWith = recurse }
+  sqlWith1 cmd name sql mat recurse = cmd { sqlSelectWith = sqlSelectWith cmd ++ [(name,sql,mat)], sqlSelectRecursiveWith = recurse <> sqlSelectRecursiveWith cmd }
 
 instance SqlWith SqlInsertSelect where
-  sqlWith1 cmd name sql mat recurse = cmd { sqlInsertSelectWith = sqlInsertSelectWith cmd ++ [(name,sql,mat)], sqlInsertSelectRecursiveWith = recurse }
+  sqlWith1 cmd name sql mat recurse = cmd { sqlInsertSelectWith = sqlInsertSelectWith cmd ++ [(name,sql,mat)], sqlInsertSelectRecursiveWith = recurse <> sqlInsertSelectRecursiveWith cmd }
 
 instance SqlWith SqlUpdate where
-  sqlWith1 cmd name sql mat recurse = cmd { sqlUpdateWith = sqlUpdateWith cmd ++ [(name,sql,mat)], sqlUpdateRecursiveWith = recurse }
+  sqlWith1 cmd name sql mat recurse = cmd { sqlUpdateWith = sqlUpdateWith cmd ++ [(name,sql,mat)], sqlUpdateRecursiveWith = recurse <> sqlUpdateRecursiveWith cmd }
 
 instance SqlWith SqlDelete where
-  sqlWith1 cmd name sql mat recurse = cmd { sqlDeleteWith = sqlDeleteWith cmd ++ [(name,sql,mat)], sqlDeleteRecursiveWith = recurse }
+  sqlWith1 cmd name sql mat recurse = cmd { sqlDeleteWith = sqlDeleteWith cmd ++ [(name,sql,mat)], sqlDeleteRecursiveWith = recurse <> sqlDeleteRecursiveWith cmd }
 
 sqlWith :: (MonadState v m, SqlWith v, Sqlable s) => SQL -> s -> m ()
 sqlWith name sql = modify (\cmd -> sqlWith1 cmd name (toSQLCommand sql) NonMaterialized NonRecursive)
diff --git a/test/Main.hs b/test/Main.hs
index 6338e46..9730e87 100644
--- a/test/Main.hs
+++ b/test/Main.hs
@@ -1282,8 +1282,6 @@ testSqlWith step = do
 
 testSqlWithRecursive :: HasCallStack => (String -> TestM ()) -> TestM ()
 testSqlWithRecursive step = do
-  step "Checking recursive support"
-  checkAndRememberRecursiveSupport
   step "Running WITH RECURSIVE tests"
   testPass
   where 
@@ -1318,6 +1316,13 @@ testSqlWithRecursive step = do
                   sqlResult "child.cartel_boss_id"
                   sqlJoinOn "rcartel rcartel1" "child.cartel_boss_id = rcartel1.cartel_member_id"
               ]
+        -- This dummy with is not actually used
+        -- It's just here to test that further "sqlWith" do not remove the RECURSIVE
+        -- keyword when actually producing the SQL
+        sqlWith "lcartel" $ do
+          sqlSelect "rcartel c" $ do
+            sqlResult "c.cartel_member_id"
+            sqlResult "c.cartel_boss_id"
         sqlResult "member.firstname"
         sqlResult "member.lastname"
         sqlResult "boss.firstname"