Add support for two forms of PostgreSQL WITH syntax; loop and `ma…

…terialize`

rel8.cabal

@@ -112,6 +112,8 @@ library
     Rel8.Query.Indexed
     Rel8.Query.Limit
     Rel8.Query.List
+    Rel8.Query.Loop
+    Rel8.Query.Materialize
     Rel8.Query.Maybe
     Rel8.Query.Null
     Rel8.Query.Opaleye

src/Rel8.hs

@@ -246,6 +246,12 @@ module Rel8
   , without
   , withoutBy
 
+    -- ** @WITH@
+  , materialize
+
+    -- ** @WITH RECURSIVE@
+  , loop
+
     -- ** Aggregation
   , Aggregate
   , Aggregates
@@ -382,6 +388,8 @@ import Rel8.Query.Filter
 import Rel8.Query.Indexed
 import Rel8.Query.Limit
 import Rel8.Query.List
+import Rel8.Query.Loop
+import Rel8.Query.Materialize
 import Rel8.Query.Maybe
 import Rel8.Query.Null
 import Rel8.Query.Order

src/Rel8/Query/Loop.hs

@@ -0,0 +1,32 @@
+{-# language FlexibleContexts #-}
+
+module Rel8.Query.Loop
+  ( loop
+  ) where
+
+-- base
+import Prelude
+
+-- opaleye
+import Opaleye.With ( withRecursiveExplicit )
+
+-- rel8
+import Rel8.Expr ( Expr )
+import Rel8.Query ( Query )
+import Rel8.Query.Opaleye ( fromOpaleye, toOpaleye )
+import Rel8.Table ( Table )
+import Rel8.Table.Opaleye ( binaryspec )
+
+
+-- | 'loop' allows the construction of recursive queries, using Postgres'
+-- [@WITH RECURSIVE@](https://www.postgresql.org/docs/current/queries-with.html#QUERIES-WITH-RECURSIVE)
+-- under the hood. The first argument to 'loop' is what the Postgres
+-- documentation refers to as the \"non-recursive term\" and the second
+-- argument is the \"recursive term\", which is defined in terms of the result
+-- of the \"non-recursive term\".
+loop :: Table Expr a => Query a -> (a -> Query a) -> Query a
+loop base recurse =
+  fromOpaleye $ withRecursiveExplicit binaryspec base' recurse'
+  where
+    base' = toOpaleye base
+    recurse' = toOpaleye . recurse

src/Rel8/Query/Materialize.hs

@@ -0,0 +1,36 @@
+{-# language FlexibleContexts #-}
+
+module Rel8.Query.Materialize
+  ( materialize
+  ) where
+
+-- base
+import Prelude
+
+-- opaleye
+import Opaleye.With ( withExplicit )
+
+-- rel8
+import Rel8.Expr ( Expr )
+import Rel8.Query ( Query )
+import Rel8.Query.Opaleye ( fromOpaleye, toOpaleye )
+import Rel8.Table ( Table )
+import Rel8.Table.Opaleye ( unpackspec )
+
+
+-- | 'materialize' takes a 'Query' and fully evaluates it and caches the
+-- results thereof, and returns a new 'Query' that simply looks up these
+-- cached results. It's usually best not to use this and to let the Postgres
+-- optimizer decide for itself what's best, but if you know what you're doing
+-- this can sometimes help to nudge it in a particular direction.
+--
+-- 'materialize' is currently implemented in terms of Postgres'
+-- [@WITH](https://www.postgresql.org/docs/current/queries-with.html) syntax.
+-- Note that on newer versions of PostgreSQL starting with version 12, @WITH@
+-- doesn't always automatically materialize if the results of the query aren't
+-- used more than once. We reserve the right to change the implementation of
+-- 'materialize' to use the newer @WITH foo AS MATERIALIZED bar@ syntax
+-- introduced in PostgreSQL 12 in the future.
+materialize :: Table Expr a => Query a -> Query (Query a)
+materialize query = fromOpaleye $
+  withExplicit unpackspec (toOpaleye query) (pure . fromOpaleye)

src/Rel8/Statement/Create.hs

@@ -0,0 +1,22 @@
+{-# language LambdaCase #-}
+
+module Rel8.Statement.Create
+  ( Create(..)
+  , ppCreate
+  )
+where
+
+-- base
+import Prelude ()
+
+-- pretty
+import Text.PrettyPrint ( Doc, text )
+
+
+data Create = Create | CreateOrReplace
+
+
+ppCreate :: Create -> Doc
+ppCreate = \case
+  Create -> text "CREATE"
+  CreateOrReplace -> text "CREATE OR REPLACE"

src/Rel8/Statement/Index.hs

@@ -0,0 +1,80 @@
+{-# language FlexibleContexts #-}
+{-# language MonoLocalBinds #-}
+
+module Rel8.Statement.Index
+  ( createIndex
+  , createOrReplaceIndex
+  )
+where
+
+-- base
+import Prelude
+
+-- hasql
+import qualified Hasql.Decoders as Hasql
+import qualified Hasql.Encoders as Hasql
+import qualified Hasql.Statement as Hasql
+
+-- rel8
+import Rel8.Query ( Query )
+import Rel8.Schema.Name ( Name )
+import Rel8.Schema.Table ( TableSchema )
+import Rel8.Statement.Create ( Create(..), ppCreate )
+import Rel8.Statement.Insert ( ppInto )
+import Rel8.Statement.Select ( ppSelect )
+import Rel8.Table (Table)
+import Rel8.Table.Projection (Projecting, Projection)
+
+-- pretty
+import Text.PrettyPrint ( Doc, (<+>), ($$), text )
+
+-- text
+import qualified Data.Text as Text
+import Data.Text.Encoding ( encodeUtf8 )
+
+
+createIndex :: (Table Name names, Projecting names index)
+  => TableSchema names -> Projection names index -> Hasql.Statement () ()
+createIndex =
+  createIndexGeneric Create
+
+
+createOrReplaceIndex :: (Table Name names, Projecting names index)
+  => TableSchema names -> Projection names index -> Hasql.Statement () ()
+createOrReplaceIndex =
+  createIndexGeneric CreateOrReplace
+
+
+createIndexGeneric :: (Table Name names, Projecting names index)
+  => Create -> TableSchema names -> Projection names index -> Hasql.Statement () ()
+createIndexGeneric create table index = undefined
+
+
+
+
+{-
+createIndexGeneric :: Selects names exprs
+  => Create -> TableSchema names -> Query exprs -> Hasql.Statement () ()
+createIndexGeneric create schema query =
+  Hasql.Statement bytes params decode prepare
+  where
+    bytes = encodeUtf8 (Text.pack sql)
+    params = Hasql.noParams
+    decode = Hasql.noResult
+    prepare = False
+    sql = show doc
+    doc = ppCreate schema query create materialization
+
+
+ppCreate :: Selects names exprs
+  => TableSchema names -> Query exprs -> Create -> Materialization -> Doc
+ppCreate schema query create materialization =
+  ppCreate create <+> materialized <+> text "VIEW" <+>
+  ppInto schema $$
+  text "AS" <+>
+  ppSelect query
+  where
+    materialized = case materialization of
+      Materialized -> text "MATERIALIZED"
+      NonMaterialized -> mempty
+-}

src/Rel8/Tabulate.hs

@@ -25,6 +25,9 @@ module Rel8.Tabulate
   , distinct
   , order
 
+    -- * Materialize
+  , materialize
+
     -- ** Magic 'Tabulation's
     -- $magic
   , count
@@ -91,6 +94,7 @@ import Rel8.Query ( Query )
 import qualified Rel8.Query.Exists as Q ( exists, present, absent )
 import Rel8.Query.Filter ( where_ )
 import Rel8.Query.List ( catNonEmptyTable )
+import qualified Rel8.Query.Materialize as Q
 import qualified Rel8.Query.Maybe as Q ( optional )
 import Rel8.Query.Opaleye ( mapOpaleye, unsafePeekQuery )
 import Rel8.Query.Rebind ( rebind )
@@ -630,6 +634,16 @@ difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
 difference a b = a <* absent b
 
 
+materialize :: (Table Expr k, Table Expr a)
+  => Tabulation k a -> Query (Tabulation k a)
+materialize tabulation = case peek tabulation of
+  Tabulation query -> do
+    (_, equery) <- query mempty
+    case equery of
+      Left as -> liftQuery <$> Q.materialize as
+      Right kas -> fromQuery <$> Q.materialize kas
+
+
 -- | 'Tabulation's can be produced with either 'fromQuery' or 'liftQuery', and
 -- in some cases we might want to treat these differently. 'peek' uses
 -- 'unsafePeekQuery' to determine which type of 'Tabulation' we have.