git.iko.soy/rel8
on 60cbc6a help sign in
rel8/src/Rel8/Query/Evaluate.hs
83 lines 2.6 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 Debug.Trace
18import Prelude
20-- opaleye
21import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
22import qualified Opaleye.Internal.PackMap as Opaleye
23import qualified Opaleye.Internal.PrimQuery as Opaleye
24import qualified Opaleye.Internal.QueryArr as Opaleye
25import qualified Opaleye.Internal.Tag as Opaleye
26import qualified Opaleye.Internal.Unpackspec as Opaleye
28-- rel8
29import Rel8.Expr ( Expr )
30import Rel8.Query ( Query( Query ) )
31import Rel8.Table ( Table )
32import Rel8.Table.Opaleye ( unpackspec )
34-- semigroupoids
35import Data.Functor.Apply ( Apply )
36import Data.Functor.Bind ( Bind, (>>-) )
38-- transformers
39import Control.Monad.Trans.State.Strict ( State, get, put, runState )
42type Evaluations :: Type
43data Evaluations = Evaluations
44 { tag :: !Opaleye.Tag
45 , bindings :: !(Endo (Opaleye.Bindings Opaleye.PrimExpr))
46 }
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.
55type Evaluate :: Type -> Type
56newtype Evaluate a = Evaluate (State Evaluations a)
57 deriving newtype (Functor, Apply, Applicative, Monad)
60instance Bind Evaluate where
61 (>>-) = (>>=)
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.
67eval :: Table Expr a => a -> Evaluate a
68eval 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'
78-- | 'evaluate' runs an 'Evaluate' inside the 'Query' monad.
79evaluate :: Evaluate a -> Query a
80evaluate (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')