{-# language DuplicateRecordFields #-}
{-# language FlexibleContexts #-}
{-# language GADTs #-}
{-# language NamedFieldPuns #-}
{-# language RecordWildCards #-}
{-# language StandaloneKindSignatures #-}
{-# language StrictData #-}
module Rel8.Statement.Update
( Update(..)
, update
, ppUpdate
)
where
import Data.Kind ( Type )
import Prelude
import qualified Opaleye.Internal.Tag as Opaleye
import Text.PrettyPrint ( Doc, (<+>), ($$), text )
import Rel8.Expr ( Expr )
import Rel8.Query ( Query )
import Rel8.Schema.Name ( Selects )
import Rel8.Schema.Table ( TableSchema(..), ppTable )
import Rel8.Statement (Statement)
import Rel8.Statement.Returning (Returning, ppReturning, runReturning)
import Rel8.Statement.Set ( ppSet )
import Rel8.Statement.Using ( ppFrom )
import Rel8.Statement.Where ( ppWhere )
import Control.Monad.Trans.State.Strict (State)
type Update :: Type -> Type
data Update a where
Update :: Selects names exprs =>
{ ()
target :: TableSchema names
, ()
from :: Query from
, ()
set :: from -> exprs -> exprs
, ()
updateWhere :: from -> exprs -> Expr Bool
, ()
returning :: Returning names a
}
-> Update a
update :: Update a -> Statement a
update :: forall a. Update a -> Statement a
update statement :: Update a
statement@Update {Returning names a
$sel:returning:Update :: ()
returning :: Returning names a
returning} =
State Tag Doc -> Returning names a -> Statement a
forall names a. State Tag Doc -> Returning names a -> Statement a
runReturning (Update a -> State Tag Doc
forall a. Update a -> State Tag Doc
ppUpdate Update a
statement) Returning names a
returning
ppUpdate :: Update a -> State Opaleye.Tag Doc
ppUpdate :: forall a. Update a -> State Tag Doc
ppUpdate Update {TableSchema names
Query from
Returning names a
from -> exprs -> exprs
from -> exprs -> Expr Bool
$sel:target:Update :: ()
$sel:from:Update :: ()
$sel:set:Update :: ()
$sel:updateWhere:Update :: ()
$sel:returning:Update :: ()
target :: TableSchema names
from :: Query from
set :: from -> exprs -> exprs
updateWhere :: from -> exprs -> Expr Bool
returning :: Returning names a
..} = do
Maybe (Doc, from)
mfrom <- Query from -> State Tag (Maybe (Doc, from))
forall a. Query a -> State Tag (Maybe (Doc, a))
ppFrom Query from
from
Doc -> State Tag Doc
forall a. a -> StateT Tag Identity a
forall (f :: Context) a. Applicative f => a -> f a
pure (Doc -> State Tag Doc) -> Doc -> State Tag Doc
forall a b. (a -> b) -> a -> b
$ case Maybe (Doc, from)
mfrom of
Maybe (Doc, from)
Nothing ->
String -> Doc
text String
"UPDATE" Doc -> Doc -> Doc
<+> TableSchema names -> Doc
forall a. TableSchema a -> Doc
ppTable TableSchema names
target Doc -> Doc -> Doc
$$
TableSchema names -> (exprs -> exprs) -> Doc
forall names exprs.
Selects names exprs =>
TableSchema names -> (exprs -> exprs) -> Doc
ppSet TableSchema names
target exprs -> exprs
forall a. a -> a
id Doc -> Doc -> Doc
$$
String -> Doc
text String
"WHERE false"
Just (Doc
fromDoc, from
i) ->
String -> Doc
text String
"UPDATE" Doc -> Doc -> Doc
<+> TableSchema names -> Doc
forall a. TableSchema a -> Doc
ppTable TableSchema names
target Doc -> Doc -> Doc
$$
TableSchema names -> (exprs -> exprs) -> Doc
forall names exprs.
Selects names exprs =>
TableSchema names -> (exprs -> exprs) -> Doc
ppSet TableSchema names
target (from -> exprs -> exprs
set from
i) Doc -> Doc -> Doc
$$
Doc
fromDoc Doc -> Doc -> Doc
$$
TableSchema names -> (exprs -> Expr Bool) -> Doc
forall names exprs.
Selects names exprs =>
TableSchema names -> (exprs -> Expr Bool) -> Doc
ppWhere TableSchema names
target (from -> exprs -> Expr Bool
updateWhere from
i) Doc -> Doc -> Doc
$$
TableSchema names -> Returning names a -> Doc
forall names a. TableSchema names -> Returning names a -> Doc
ppReturning TableSchema names
target Returning names a
returning