git.iko.soy/rel8
on 29cdfdb help sign in
rel8/src/Rel8/Statement/Returning.hs
133 lines 3.9 kB history raw
1{-# language GADTs #-}
2{-# language LambdaCase #-}
3{-# language NamedFieldPuns #-}
4{-# language RankNTypes #-}
5{-# language ScopedTypeVariables #-}
6{-# language StandaloneKindSignatures #-}
7{-# language StrictData #-}
8{-# language TypeApplications #-}
10module Rel8.Statement.Returning
11 ( Returning( NumberOfRowsAffected, Projection )
12 , decodeReturning
13 , ppReturning
14 )
15where
17-- base
18import Control.Applicative ( liftA2 )
19import Data.Foldable ( toList )
20import Data.Int ( Int64 )
21import Data.Kind ( Type )
22import Data.List.NonEmpty ( NonEmpty )
23import Prelude
25-- hasql
26import qualified Hasql.Decoders as Hasql
28-- opaleye
29import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
30import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye
31import qualified Opaleye.Internal.Sql as Opaleye
33-- pretty
34import Text.PrettyPrint ( Doc, (<+>), text )
36-- rel8
37import Rel8.Schema.Name ( Selects )
38import Rel8.Schema.Table ( TableSchema(..) )
39import Rel8.Table.Opaleye ( castTable, exprs, view )
40import Rel8.Table.Serialize ( Serializable, parse )
42-- semigropuoids
43import Data.Functor.Apply ( Apply, (<.>) )
46-- | 'Rel8.Insert', 'Rel8.Update' and 'Rel8.Delete' all support returning either
47-- the number of rows affected, or the actual rows modified.
48type Returning :: Type -> Type -> Type
49data Returning names a where
50 Pure :: a -> Returning names a
51 Ap :: Returning names (a -> b) -> Returning names a -> Returning names b
53 -- | Return the number of rows affected.
54 NumberOfRowsAffected :: Returning names Int64
56 -- | 'Projection' allows you to project out of the affected rows, which can
57 -- be useful if you want to log exactly which rows were deleted, or to view
58 -- a generated id (for example, if using a column with an autoincrementing
59 -- counter via 'Rel8.nextval').
60 Projection :: (Selects names exprs, Serializable returning a)
61 => (exprs -> returning)
62 -> Returning names [a]
65instance Functor (Returning names) where
66 fmap f = \case
67 Pure a -> Pure (f a)
68 Ap g a -> Ap (fmap (f .) g) a
69 m -> Ap (Pure f) m
72instance Apply (Returning names) where
73 (<.>) = Ap
76instance Applicative (Returning names) where
77 pure = Pure
78 (<*>) = Ap
81projections :: ()
82 => TableSchema names -> Returning names a -> Maybe (NonEmpty Opaleye.PrimExpr)
83projections schema@TableSchema {columns} = \case
84 Pure _ -> Nothing
85 Ap f a -> projections schema f <> projections schema a
86 NumberOfRowsAffected -> Nothing
87 Projection f -> Just (exprs (castTable (f (view columns))))
90runReturning :: ()
91 => ((Int64 -> a) -> r)
92 -> (forall x. Hasql.Row x -> ([x] -> a) -> r)
93 -> Returning names a
94 -> r
95runReturning rowCount rowList = \case
96 Pure a -> rowCount (const a)
97 Ap fs as ->
98 runReturning
99 (\withCount ->
100 runReturning
101 (\withCount' -> rowCount (withCount <*> withCount'))
102 (\decoder -> rowList decoder . liftA2 withCount length64)
103 as)
104 (\decoder withRows ->
105 runReturning
106 (\withCount -> rowList decoder $ withRows <*> withCount . length64)
107 (\decoder' withRows' ->
108 rowList (liftA2 (,) decoder decoder') $
109 withRows <$> fmap fst <*> withRows' . fmap snd)
110 as)
111 fs
112 NumberOfRowsAffected -> rowCount id
113 Projection (_ :: exprs -> returning) -> rowList decoder' id
114 where
115 decoder' = parse @returning
116 where
117 length64 :: Foldable f => f x -> Int64
118 length64 = fromIntegral . length
121decodeReturning :: Returning names a -> Hasql.Result a
122decodeReturning = runReturning
123 (<$> Hasql.rowsAffected)
124 (\decoder withRows -> withRows <$> Hasql.rowList decoder)
127ppReturning :: TableSchema names -> Returning names a -> Doc
128ppReturning schema returning = case projections schema returning of
129 Nothing -> mempty
130 Just columns ->
131 text "RETURNING" <+> Opaleye.commaV Opaleye.ppSqlExpr (toList sqlExprs)
132 where
133 sqlExprs = Opaleye.sqlExpr <$> columns