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