git.iko.soy/squeal
on 9bcc261 help sign in
ddc9847
swap
2 ahead, 128 behind
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Parameter.hs+95
since splitsnapshots
unifiedsplit
@@ -14,7 +14,9 @@ Parameters, out-of-line data values
14 , FlexibleContexts
14 , FlexibleContexts
15 , FlexibleInstances
15 , FlexibleInstances
16 , FunctionalDependencies
16 , FunctionalDependencies
17+ , GADTs
17 , KindSignatures
18 , KindSignatures
19+ , LambdaCase
18 , MultiParamTypeClasses
20 , MultiParamTypeClasses
19 , OverloadedStrings
21 , OverloadedStrings
20 , RankNTypes
22 , RankNTypes
@@ -27,12 +29,22 @@ Parameters, out-of-line data values
27module Squeal.PostgreSQL.Expression.Parameter
29module Squeal.PostgreSQL.Expression.Parameter
28 ( HasParameter (parameter)
30 ( HasParameter (parameter)
29 , param
31 , param
32+ , params
33+ , insertParamsInto
34+ , insertParamsInto_
30 ) where
35 ) where
31
36
37+import Data.ByteString (ByteString)
38+import qualified Data.ByteString as ByteString
39+import qualified Data.ByteString.Char8 as Char8
40+import Data.Int (Int32)
41+import Generics.SOP (NP(..), hmap, SListI)
32import GHC.TypeLits
42import GHC.TypeLits
33
43
44+import Squeal.PostgreSQL.Alias
34import Squeal.PostgreSQL.Expression
45import Squeal.PostgreSQL.Expression
35import Squeal.PostgreSQL.Expression.Type
46import Squeal.PostgreSQL.Expression.Type
47+import Squeal.PostgreSQL.Manipulation
36import Squeal.PostgreSQL.Render
48import Squeal.PostgreSQL.Render
37import Squeal.PostgreSQL.Schema
49import Squeal.PostgreSQL.Schema
38
50
@@ -78,3 +90,86 @@ param
78 . (PGTyped schemas ty, HasParameter n params ty)
90 . (PGTyped schemas ty, HasParameter n params ty)
79 => Expression outer commons grp schemas params from ty -- ^ param
91 => Expression outer commons grp schemas params from ty -- ^ param
80param = parameter @n (pgtype @schemas)
92param = parameter @n (pgtype @schemas)
93+
94+class Insertable
95+ (schemas :: SchemasType)
96+ (params :: [NullityType])
97+ (row :: RowType)
98+ (columns :: ColumnsType)
99+ | columns -> params
100+ , columns -> row where
101+ params ::
102+ NP (Aliased (Optional (
103+ Expression '[] commons 'Ungrouped schemas params '[]
104+ ) ) ) columns
105+instance Insertable schemas '[] '[] '[] where params = Nil
106+instance
107+ ( KnownSymbol col
108+ , PGTyped schemas ty
109+ , SListI columns
110+ , Insertable schemas params row columns ) =>
111+ Insertable schemas params row (col ::: 'Def :=> ty ': columns) where
112+ params = Default `as` (Alias @col) :* (params @schemas)
113+instance
114+ ( KnownSymbol col
115+ , PGTyped schemas ty
116+ , SListI columns
117+ , Insertable schemas params row columns ) =>
118+ Insertable schemas (ty ': params) (col ::: ty ': row)
119+ (col ::: 'NoDef :=> ty ': columns) where
120+ params =
121+ Set (param @1) `as` (Alias @col)
122+ :* hmap (overValue paramPlus1) (params @schemas)
123+
124+overValue
125+ :: ( forall o c g s f x
126+ . Expression o c g s p0 f x -> Expression o c g s p1 f x )
127+ -> Aliased (Optional (
128+ Expression '[] commons 'Ungrouped schemas p0 '[]
129+ ) ) column
130+ -> Aliased (Optional (
131+ Expression '[] commons 'Ungrouped schemas p1 '[]
132+ ) ) column
133+overValue f = \case
134+ Set expr `As` alias -> Set (f expr) `as` alias
135+ Default `As` alias -> Default `as` alias
136+
137+paramPlus1
138+ :: Expression outer commons grp schemas params from ty
139+ -> Expression outer commons grp schemas (param ': params) from ty
140+paramPlus1 = UnsafeExpression . paramsPlus1_ . renderSQL
141+ where
142+ paramsPlus1_ :: ByteString -> ByteString
143+ paramsPlus1_ p =
144+ let
145+ (left_n, right) = ByteString.breakSubstring "::" p
146+ isDigit w = w - 48 <= 9
147+ (left, n) = ByteString.break isDigit left_n
148+ add1 = Char8.pack . show . (+ 1) . read @Int32 . Char8.unpack
149+ in
150+ left <> add1 n <> right
151+
152+insertParamsInto
153+ :: ( Has sch schemas schema
154+ , Has tab schema ('Table table)
155+ , columns ~ TableToColumns table
156+ , row0 ~ TableToRow table
157+ , SListI columns
158+ , SListI returning
159+ , Insertable schemas params row columns )
160+ => QualifiedAlias sch tab
161+ -> ConflictClause tab commons schemas params table
162+ -> ReturningClause commons schemas params '[tab ::: row0] returning
163+ -> Manipulation commons schemas params returning
164+insertParamsInto tab = insertInto tab (Values_ params)
165+
166+insertParamsInto_
167+ :: ( Has sch schemas schema
168+ , Has tab schema ('Table table)
169+ , columns ~ TableToColumns table
170+ , row0 ~ TableToRow table
171+ , SListI columns
172+ , Insertable schemas params row columns )
173+ => QualifiedAlias sch tab
174+ -> Manipulation commons schemas params '[]
175+insertParamsInto_ tab = insertInto_ tab (Values_ params)