@@ -0,0 +1,83 @@
1+{-# language DerivingStrategies #-}
2+{-# language FlexibleContexts #-}
3+{-# language GeneralizedNewtypeDeriving #-}
4+{-# language NamedFieldPuns #-}
5+{-# language StandaloneKindSignatures #-}
6+
7+module Rel8.Query.Evaluate
8+ ( Evaluate
9+ , eval
10+ , evaluate
11+ )
12+where
13+
14+-- base
15+import Data.Kind ( Type )
16+import Data.Monoid ( Endo ( Endo ), appEndo )
17+import Debug.Trace
18+import Prelude
19+
20+-- opaleye
21+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
22+import qualified Opaleye.Internal.PackMap as Opaleye
23+import qualified Opaleye.Internal.PrimQuery as Opaleye
24+import qualified Opaleye.Internal.QueryArr as Opaleye
25+import qualified Opaleye.Internal.Tag as Opaleye
26+import qualified Opaleye.Internal.Unpackspec as Opaleye
27+
28+-- rel8
29+import Rel8.Expr ( Expr )
30+import Rel8.Query ( Query( Query ) )
31+import Rel8.Table ( Table )
32+import Rel8.Table.Opaleye ( unpackspec )
33+
34+-- semigroupoids
35+import Data.Functor.Apply ( Apply )
36+import Data.Functor.Bind ( Bind, (>>-) )
37+
38+-- transformers
39+import Control.Monad.Trans.State.Strict ( State, get, put, runState )
40+
41+
42+type Evaluations :: Type
43+data Evaluations = Evaluations
44+ { tag :: !Opaleye.Tag
45+ , bindings :: !(Endo (Opaleye.Bindings Opaleye.PrimExpr))
46+ }
47+
48+
49+-- | Some PostgreSQL functions, such as 'Rel8.nextval', have side effects,
50+-- breaking the referential transparency we would otherwise enjoy.
51+--
52+-- To try to recover our ability to reason about such expressions, 'Rel8'
53+-- provides the 'Evaluate' monad, which allows us to control the evaluation
54+-- order of side-effects by sequencing them monadically.
55+type Evaluate :: Type -> Type
56+newtype Evaluate a = Evaluate (State Evaluations a)
57+ deriving newtype (Functor, Apply, Applicative, Monad)
58+
59+
60+instance Bind Evaluate where
61+ (>>-) = (>>=)
62+
63+
64+-- | 'eval' takes expressions that could potentially have side effects and
65+-- lifts them into the 'Evaluate' monad. The resulting expressions has no side
66+-- effetcs and can safely be reused.
67+eval :: Table Expr a => a -> Evaluate a
68+eval a = Evaluate $ do
69+ Evaluations {tag, bindings} <- get
70+ let
71+ tag' = Opaleye.next tag
72+ (a', bindings') = Opaleye.run $
73+ Opaleye.runUnpackspec unpackspec (Opaleye.extractAttr "eval" tag') a
74+ put Evaluations {tag = tag', bindings = bindings <> Endo (bindings' ++)}
75+ pure a'
76+
77+
78+-- | 'evaluate' runs an 'Evaluate' inside the 'Query' monad.
79+evaluate :: Evaluate a -> Query a
80+evaluate (Evaluate m) = Query $ Opaleye.QueryArr $ \(_, query, tag) ->
81+ case runState m (Evaluations tag mempty) of
82+ (a, Evaluations {tag = tag', bindings}) ->
83+ (a, Opaleye.Rebind True (traceShowId (appEndo bindings mempty)) query, tag')