ccc4620 · squeal · git.iko.soy

git.iko.soy/squeal

Merge pull request #146 from morphismtech/dev-fun

User defined function support

commitccc46209136e6d4d28848e0619a86c03f7dfff22 authorEitan Chatav <eitan.chatav@gmail.com> dateMon 16 Sep 2019, 19:55 (7 years ago) parenta3ac8dd b00ae4c

7 files changed+287−17

compare with dev

unifiedsplit

squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+171−1 squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs+74−8 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Comparison.hs+6−6 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Logic.hs+1−1 squeal-postgresql/src/Squeal/PostgreSQL/Expression/SetOf.hs+21 squeal-postgresql/src/Squeal/PostgreSQL/Expression/TextSearch.hs+1−1 squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+13

squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+171−1

@@ -19,6 +19,7 @@ Squeal data definition language.

1919 , GADTs

2020 , LambdaCase

2121 , MultiParamTypeClasses

22+ , OverloadedLabels

2223 , OverloadedStrings

2324 , RankNTypes

2425 , ScopedTypeVariables

@@ -48,6 +49,13 @@ module Squeal.PostgreSQL.Definition

4849 , createDomain

4950 , createTypeRange

5051 , createIndex

52+ , createFunction

53+ , createOrReplaceFunction

54+ , createSetFunction

55+ , createOrReplaceSetFunction

56+ , createBinaryOp

57+ , createLeftOp

58+ , createRightOp

5159 , TableConstraintExpression (..)

5260 , check

5361 , unique

@@ -56,12 +64,17 @@ module Squeal.PostgreSQL.Definition

5664 , ForeignKeyed

5765 , OnDeleteClause (..)

5866 , OnUpdateClause (..)

67+ , FunctionDefinition(..)

68+ , languageSqlExpr

69+ , languageSqlQuery

5970 -- ** Drop

6071 , dropSchema

6172 , dropTable

6273 , dropView

6374 , dropType

6475 , dropIndex

76+ , dropFunction

77+ , dropOperator

6578 -- ** Alter

6679 , alterTable

6780 , alterTableRename

@@ -576,6 +589,7 @@ DROP statements

576589dropSchema

577590 :: Has sch schemas schema

578591 => Alias sch

592+ -- ^ user defined schema

579593 -> Definition schemas (Drop sch schemas)

580594dropSchema sch = UnsafeDefinition $ "DROP SCHEMA" <+> renderSQL sch <> ";"

581595

@@ -1124,13 +1138,169 @@ instance RenderSQL IndexMethod where

11241138 Gin -> "gin"

11251139 Brin -> "brin"

11261140

1141+createFunction

1142+ :: ( Has sch schemas schema

1143+ , KnownSymbol fun

1144+ , SOP.SListI args )

1145+ => QualifiedAlias sch fun

1146+ -> NP (TypeExpression schemas) args

1147+ -> TypeExpression schemas ret

1148+ -> FunctionDefinition schemas args ('Returns ret)

1149+ -> Definition schemas (Alter sch (Create fun ('Function args ('Returns ret)) schema) schemas)

1150+createFunction fun args ret fundef = UnsafeDefinition $

1151+ "CREATE" <+> "FUNCTION" <+> renderSQL fun

1152+ <+> parenthesized (renderCommaSeparated renderSQL args)

1153+ <+> "RETURNS" <+> renderSQL ret <+> renderSQL fundef <> ";"

1154+

1155+createOrReplaceFunction

1156+ :: ( Has sch schemas schema

1157+ , Has fun schema ('Function args0 ret0)

1158+ , SOP.SListI args )

1159+ => QualifiedAlias sch fun

1160+ -> NP (TypeExpression schemas) args

1161+ -> TypeExpression schemas ret

1162+ -> FunctionDefinition schemas args ('Returns ret)

1163+ -> Definition schemas (Alter sch (Alter fun ('Function args ('Returns ret)) schema) schemas)

1164+createOrReplaceFunction fun args ret fundef = UnsafeDefinition $

1165+ "CREATE" <+> "OR" <+> "REPLACE" <+> "FUNCTION" <+> renderSQL fun

1166+ <+> parenthesized (renderCommaSeparated renderSQL args)

1167+ <+> "RETURNS" <+> renderSQL ret <+> renderSQL fundef <> ";"

1168+

1169+languageSqlExpr

1170+ :: Expression '[] '[] 'Ungrouped schemas args '[] ret

1171+ -> FunctionDefinition schemas args ('Returns ret)

1172+languageSqlExpr expr = UnsafeFunctionDefinition $

1173+ "language sql as"

1174+ <+> "$$" <+> renderSQL (values_ (expr `as` #ret)) <+> "$$"

1175+

1176+languageSqlQuery

1177+ :: Query '[] '[] schemas args rets

1178+ -> FunctionDefinition schemas args ('ReturnsTable rets)

1179+languageSqlQuery qry = UnsafeFunctionDefinition $

1180+ "language sql as" <+> "$$" <+> renderSQL qry <+> "$$"

1181+

1182+createSetFunction

1183+ :: ( Has sch schemas schema

1184+ , KnownSymbol fun

1185+ , SOP.SListI args

1186+ , SOP.SListI rets )

1187+ => QualifiedAlias sch fun

1188+ -> NP (TypeExpression schemas) args

1189+ -> NP (Aliased (TypeExpression schemas)) rets

1190+ -> FunctionDefinition schemas args ('ReturnsTable rets)

1191+ -> Definition schemas (Alter sch (Create fun ('Function args ('ReturnsTable rets)) schema) schemas)

1192+createSetFunction fun args rets fundef = UnsafeDefinition $

1193+ "CREATE" <+> "FUNCTION" <+> renderSQL fun

1194+ <+> parenthesized (renderCommaSeparated renderSQL args)

1195+ <+> "RETURNS" <+> "TABLE"

1196+ <+> parenthesized (renderCommaSeparated renderRet rets)

1197+ <+> renderSQL fundef <> ";"

1198+ where

1199+ renderRet :: Aliased (TypeExpression s) r -> ByteString

1200+ renderRet (ty `As` col) = renderSQL col <+> renderSQL ty

1201+

1202+createOrReplaceSetFunction

1203+ :: ( Has sch schemas schema

1204+ , Has fun schema ('Function args0 ret0)

1205+ , SOP.SListI args

1206+ , SOP.SListI rets )

1207+ => QualifiedAlias sch fun

1208+ -> NP (TypeExpression schemas) args

1209+ -> NP (Aliased (TypeExpression schemas)) rets

1210+ -> FunctionDefinition schemas args ('ReturnsTable rets)

1211+ -> Definition schemas (Alter sch (Alter fun ('Function args ('ReturnsTable rets)) schema) schemas)

1212+createOrReplaceSetFunction fun args rets fundef = UnsafeDefinition $

1213+ "CREATE" <+> "OR" <+> "REPLACE" <+> "FUNCTION" <+> renderSQL fun

1214+ <+> parenthesized (renderCommaSeparated renderSQL args)

1215+ <+> "RETURNS" <+> "TABLE"

1216+ <+> parenthesized (renderCommaSeparated renderRet rets)

1217+ <+> renderSQL fundef <> ";"

1218+ where

1219+ renderRet :: Aliased (TypeExpression s) r -> ByteString

1220+ renderRet (ty `As` col) = renderSQL col <+> renderSQL ty

1221+

1222+createBinaryOp

1223+ :: forall op fun sch schemas schema x y z.

1224+ ( Has sch schemas schema

1225+ , Has fun schema ('Function '[x,y] ('Returns z))

1226+ , KnownSymbol op )

1227+ => Alias fun

1228+ -> TypeExpression schemas x

1229+ -> TypeExpression schemas y

1230+ -> Definition schemas

1231+ (Alter sch (Create op ('Operator ('BinaryOp x y z)) schema) schemas)

1232+createBinaryOp fun x y = UnsafeDefinition $

1233+ "CREATE" <+> "OPERATOR" <+> renderSymbol @op

1234+ <+> parenthesized (commaSeparated opdef)

1235+ where

1236+ opdef =

1237+ [ "FUNCTION" <+> "=" <+> renderSQL fun

1238+ , "LEFTARG" <+> "=" <+> renderSQL x

1239+ , "RIGHTARG" <+> "=" <+> renderSQL y ]

1240+

1241+createLeftOp

1242+ :: forall op fun sch schemas schema x y.

1243+ ( Has sch schemas schema

1244+ , Has fun schema ('Function '[x] ('Returns y))

1245+ , KnownSymbol op )

1246+ => Alias fun

1247+ -> TypeExpression schemas x

1248+ -> Definition schemas

1249+ (Alter sch (Create op ('Operator ('LeftOp x y)) schema) schemas)

1250+createLeftOp fun x = UnsafeDefinition $

1251+ "CREATE" <+> "OPERATOR" <+> renderSymbol @op

1252+ <+> parenthesized (commaSeparated opdef)

1253+ where

1254+ opdef =

1255+ [ "FUNCTION" <+> "=" <+> renderSQL fun

1256+ , "RIGHTARG" <+> "=" <+> renderSQL x ]

1257+

1258+createRightOp

1259+ :: forall op fun sch schemas schema x y.

1260+ ( Has sch schemas schema

1261+ , Has fun schema ('Function '[x] ('Returns y))

1262+ , KnownSymbol op )

1263+ => Alias fun

1264+ -> TypeExpression schemas x

1265+ -> Definition schemas

1266+ (Alter sch (Create op ('Operator ('RightOp x y)) schema) schemas)

1267+createRightOp fun x = UnsafeDefinition $

1268+ "CREATE" <+> "OPERATOR" <+> renderSymbol @op

1269+ <+> parenthesized (commaSeparated opdef)

1270+ where

1271+ opdef =

1272+ [ "FUNCTION" <+> "=" <+> renderSQL fun

1273+ , "LEFTARG" <+> "=" <+> renderSQL x ]

1274+

1275+dropFunction

1276+ :: (Has sch schemas schema, Has fun schema ('Function args ret))

1277+ => QualifiedAlias sch fun

1278+ -- ^ name of the user defined function

1279+ -> Definition schemas (Alter sch (Drop fun schema) schemas)

1280+dropFunction fun = UnsafeDefinition $

1281+ "DROP" <+> "FUNCTION" <+> renderSQL fun <> ";"

1282+

1283+dropOperator

1284+ :: (Has sch schemas schema, Has op schema ('Operator oper))

1285+ => QualifiedAlias sch op

1286+ -- ^ name of the user defined operator

1287+ -> Definition schemas (Alter sch (Drop op schema) schemas)

1288+dropOperator op = UnsafeDefinition $

1289+ "DROP" <+> "OPERATOR" <+> renderSQL op <> ";"

1290+

1291+newtype FunctionDefinition schemas args ret = UnsafeFunctionDefinition

1292+ { renderFunctionDefinition :: ByteString }

1293+ deriving (Eq,Show,GHC.Generic,NFData)

1294+instance RenderSQL (FunctionDefinition schemas args ret) where

1295+ renderSQL = renderFunctionDefinition

1296+

11271297-- |

11281298-- >>> printSQL (dropIndex #ix :: Definition (Public '["ix" ::: 'Index]) (Public '[]))

11291299-- DROP INDEX "ix";

11301300dropIndex

11311301 :: (Has sch schemas schema, Has ix schema 'Index)

11321302 => QualifiedAlias sch ix

1133− -- ^ name of the user defined type

1303+ -- ^ name of the user defined index

11341304 -> Definition schemas (Alter sch (Drop ix schema) schemas)

11351305dropIndex ix = UnsafeDefinition $ "DROP" <+> "INDEX" <+> renderSQL ix <> ";"

11361306

squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs+74−8

@@ -35,15 +35,23 @@ module Squeal.PostgreSQL.Expression

3535 Expression (..)

3636 , Expr

3737 , (:-->)

38+ , FunctionDB

3839 , unsafeFunction

39− , unsafeUnaryOpL

40− , unsafeUnaryOpR

40+ , function

41+ , unsafeLeftOp

42+ , leftOp

43+ , unsafeRightOp

44+ , rightOp

4145 , Operator

46+ , OperatorDB

4247 , unsafeBinaryOp

48+ , binaryOp

4349 , FunctionVar

4450 , unsafeFunctionVar

4551 , FunctionN

52+ , FunctionNDB

4653 , unsafeFunctionN

54+ , functionN

4755 , PGSubset (..)

4856 , PGIntersect (..)

4957 -- * Re-export

@@ -137,6 +145,15 @@ type Operator x1 x2 y

137145 -> Expression outer commons grp schemas params from y

138146 -- ^ output

139147

148+type OperatorDB schemas x1 x2 y

149+ = forall outer commons grp params from

150+ . Expression outer commons grp schemas params from x1

151+ -- ^ left input

152+ -> Expression outer commons grp schemas params from x2

153+ -- ^ right input

154+ -> Expression outer commons grp schemas params from y

155+ -- ^ output

156+

140157-- | A @RankNType@ for functions with a single argument.

141158-- These could be either function calls or unary operators.

142159-- This is a subtype of the usual Haskell function type `Prelude.->`,

@@ -149,6 +166,13 @@ type (:-->) x y

149166 -> Expression outer commons grp schemas params from y

150167 -- ^ output

151168

169+type FunctionDB schemas x y

170+ = forall outer commons grp params from

171+ . Expression outer commons grp schemas params from x

172+ -- ^ input

173+ -> Expression outer commons grp schemas params from y

174+ -- ^ output

175+

152176{- | A @RankNType@ for functions with a fixed-length list of heterogeneous arguments.

153177Use the `*:` operator to end your argument lists, like so.

154178

@@ -162,6 +186,13 @@ type FunctionN xs y

162186 -> Expression outer commons grp schemas params from y

163187 -- ^ output

164188

189+type FunctionNDB schemas xs y

190+ = forall outer commons grp params from

191+ . NP (Expression outer commons grp schemas params from) xs

192+ -- ^ inputs

193+ -> Expression outer commons grp schemas params from y

194+ -- ^ output

195+

165196{- | A @RankNType@ for functions with a variable-length list of

166197homogeneous arguments and at least 1 more argument.

167198-}

@@ -287,15 +318,36 @@ unsafeBinaryOp :: ByteString -> Operator ty0 ty1 ty2

287318unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $

288319 renderSQL x <+> op <+> renderSQL y

289320

290−-- | >>> printSQL $ unsafeUnaryOpL "NOT" true

321+binaryOp

322+ :: forall op sch schemas schema x y z.

323+ ( Has sch schemas schema

324+ , Has op schema ('Operator ('BinaryOp x y z)) )

325+ => OperatorDB schemas x y z

326+binaryOp = unsafeBinaryOp $ renderSymbol @op

327+

328+-- | >>> printSQL $ unsafeLeftOp "NOT" true

291329-- (NOT TRUE)

292−unsafeUnaryOpL :: ByteString -> x :--> y

293−unsafeUnaryOpL op x = UnsafeExpression $ parenthesized $ op <+> renderSQL x

330+unsafeLeftOp :: ByteString -> x :--> y

331+unsafeLeftOp op x = UnsafeExpression $ parenthesized $ op <+> renderSQL x

332+

333+leftOp

334+ :: forall op sch schemas schema x y.

335+ ( Has sch schemas schema

336+ , Has op schema ('Operator ('LeftOp x y)) )

337+ => FunctionDB schemas x y

338+leftOp = unsafeLeftOp $ renderSymbol @op

294339

295−-- | >>> printSQL $ true & unsafeUnaryOpR "IS NOT TRUE"

340+-- | >>> printSQL $ true & unsafeRightOp "IS NOT TRUE"

296341-- (TRUE IS NOT TRUE)

297−unsafeUnaryOpR :: ByteString -> x :--> y

298−unsafeUnaryOpR op x = UnsafeExpression $ parenthesized $ renderSQL x <+> op

342+unsafeRightOp :: ByteString -> x :--> y

343+unsafeRightOp op x = UnsafeExpression $ parenthesized $ renderSQL x <+> op

344+

345+rightOp

346+ :: forall op sch schemas schema x y.

347+ ( Has sch schemas schema

348+ , Has op schema ('Operator ('RightOp x y)) )

349+ => FunctionDB schemas x y

350+rightOp = unsafeRightOp $ renderSymbol @op

299351

300352-- | >>> printSQL $ unsafeFunction "f" true

301353-- f(TRUE)

@@ -303,12 +355,26 @@ unsafeFunction :: ByteString -> x :--> y

303355unsafeFunction fun x = UnsafeExpression $

304356 fun <> parenthesized (renderSQL x)

305357

358+function

359+ :: (Has sch schemas schema, Has fun schema ('Function '[x] ('Returns y)))

360+ => QualifiedAlias sch fun

361+ -> FunctionDB schemas x y

362+function = unsafeFunction . renderSQL

363+

306364-- | >>> printSQL $ unsafeFunctionN "f" (currentTime :* localTimestamp :* false *: literal 'a')

307365-- f(CURRENT_TIME, LOCALTIMESTAMP, FALSE, E'a')

308366unsafeFunctionN :: SListI xs => ByteString -> FunctionN xs y

309367unsafeFunctionN fun xs = UnsafeExpression $

310368 fun <> parenthesized (renderCommaSeparated renderSQL xs)

311369

370+functionN

371+ :: ( Has sch schemas schema

372+ , Has fun schema ('Function xs ('Returns y))

373+ , SListI xs )

374+ => QualifiedAlias sch fun

375+ -> FunctionNDB schemas xs y

376+functionN = unsafeFunctionN . renderSQL

377+

312378instance ty `In` PGNum

313379 => Num (Expression outer commons grp schemas params from (null ty)) where

314380 (+) = unsafeBinaryOp "+"

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Comparison.hs+6−6

@@ -163,7 +163,7 @@ isNotDistinctFrom = unsafeBinaryOp "IS NOT DISTINCT FROM"

163163(TRUE IS TRUE)

164164-}

165165isTrue :: null0 'PGbool :--> null1 'PGbool

166−isTrue = unsafeUnaryOpR "IS TRUE"

166+isTrue = unsafeRightOp "IS TRUE"

167167

168168{- | is false or unknown

169169

@@ -171,7 +171,7 @@ isTrue = unsafeUnaryOpR "IS TRUE"

171171(TRUE IS NOT TRUE)

172172-}

173173isNotTrue :: null0 'PGbool :--> null1 'PGbool

174−isNotTrue = unsafeUnaryOpR "IS NOT TRUE"

174+isNotTrue = unsafeRightOp "IS NOT TRUE"

175175

176176{- | is false

177177

@@ -179,7 +179,7 @@ isNotTrue = unsafeUnaryOpR "IS NOT TRUE"

179179(TRUE IS FALSE)

180180-}

181181isFalse :: null0 'PGbool :--> null1 'PGbool

182−isFalse = unsafeUnaryOpR "IS FALSE"

182+isFalse = unsafeRightOp "IS FALSE"

183183

184184{- | is true or unknown

185185

@@ -187,7 +187,7 @@ isFalse = unsafeUnaryOpR "IS FALSE"

187187(TRUE IS NOT FALSE)

188188-}

189189isNotFalse :: null0 'PGbool :--> null1 'PGbool

190−isNotFalse = unsafeUnaryOpR "IS NOT FALSE"

190+isNotFalse = unsafeRightOp "IS NOT FALSE"

191191

192192{- | is unknown

193193

@@ -195,7 +195,7 @@ isNotFalse = unsafeUnaryOpR "IS NOT FALSE"

195195(TRUE IS UNKNOWN)

196196-}

197197isUnknown :: null0 'PGbool :--> null1 'PGbool

198−isUnknown = unsafeUnaryOpR "IS UNKNOWN"

198+isUnknown = unsafeRightOp "IS UNKNOWN"

199199

200200{- | is true or false

201201

@@ -203,4 +203,4 @@ isUnknown = unsafeUnaryOpR "IS UNKNOWN"

203203(TRUE IS NOT UNKNOWN)

204204-}

205205isNotUnknown :: null0 'PGbool :--> null1 'PGbool

206−isNotUnknown = unsafeUnaryOpR "IS NOT UNKNOWN"

206+isNotUnknown = unsafeRightOp "IS NOT UNKNOWN"

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Logic.hs+1−1

@@ -48,7 +48,7 @@ false = UnsafeExpression "FALSE"

4848-- | >>> printSQL $ not_ true

4949-- (NOT TRUE)

5050not_ :: null 'PGbool :--> null 'PGbool

51−not_ = unsafeUnaryOpL "NOT"

51+not_ = unsafeLeftOp "NOT"

5252

5353-- | >>> printSQL $ true .&& false

5454-- (TRUE AND FALSE)

squeal-postgresql/src/Squeal/PostgreSQL/Expression/SetOf.hs+21

@@ -26,8 +26,10 @@ module Squeal.PostgreSQL.Expression.SetOf

2626 , generateSeriesTimestamp

2727 , SetOfFunction

2828 , unsafeSetOfFunction

29+ , setOfFunction

2930 , SetOfFunctionN

3031 , unsafeSetOfFunctionN

32+ , setOfFunctionN

3133 ) where

3234

3335import GHC.TypeLits

@@ -58,6 +60,15 @@ unsafeSetOfFunction

5860unsafeSetOfFunction x = UnsafeFromClause $

5961 renderSymbol @fun <> parenthesized (renderSQL x)

6062

63+setOfFunction

64+ :: ( Has sch schemas schema

65+ , Has fun schema ('Function '[ty] ('ReturnsTable setof)) )

66+ => Alias fun

67+ -> ( forall outer commons params

68+ . Expression outer commons 'Ungrouped schemas params '[] ty

69+ -> FromClause outer commons schemas params '[fun ::: setof] )

70+setOfFunction _ = unsafeSetOfFunction

71+

6172{- |

6273A @RankNType@ for set returning functions with multiple argument.

6374-}

@@ -75,6 +86,16 @@ unsafeSetOfFunctionN

7586unsafeSetOfFunctionN xs = UnsafeFromClause $

7687 renderSymbol @fun <> parenthesized (renderCommaSeparated renderSQL xs)

7788

89+setOfFunctionN

90+ :: ( Has sch schemas schema

91+ , Has fun schema ('Function tys ('ReturnsTable setof))

92+ , SOP.SListI tys )

93+ => Alias fun

94+ -> ( forall outer commons params

95+ . NP (Expression outer commons 'Ungrouped schemas params '[]) tys

96+ -> FromClause outer commons schemas params '[fun ::: setof] )

97+setOfFunctionN _ = unsafeSetOfFunctionN

98+

7899{- | @generateSeries (start *: stop)@

79100

80101Generate a series of values, from @start@ to @stop@ with a step size of one

squeal-postgresql/src/Squeal/PostgreSQL/Expression/TextSearch.hs+1−1

@@ -56,7 +56,7 @@ import Squeal.PostgreSQL.Schema

5656

5757-- | negate a `Squeal.PostgreSQL.Expression.Type.tsquery`

5858(.!) :: null 'PGtsquery :--> null 'PGtsquery

59−(.!) = unsafeUnaryOpL "!!"

59+(.!) = unsafeLeftOp "!!"

6060

6161-- | `Squeal.PostgreSQL.Expression.Type.tsquery` followed by

6262-- `Squeal.PostgreSQL.Expression.Type.tsquery`

squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+13

@@ -44,6 +44,8 @@ module Squeal.PostgreSQL.Schema

4444 , ColumnsType

4545 , TableType

4646 , SchemumType (..)

47+ , OperatorType (..)

48+ , ReturnsType (..)

4749 , SchemaType

4850 , SchemasType

4951 , Public

@@ -367,8 +369,19 @@ data SchemumType

367369 | View RowType

368370 | Typedef PGType

369371 | Index

372+ | Function [NullityType] ReturnsType

373+ | Operator OperatorType

370374 | UnsafeSchemum Symbol

371375

376+data ReturnsType

377+ = Returns NullityType

378+ | ReturnsTable RowType

379+

380+data OperatorType

381+ = BinaryOp NullityType NullityType NullityType

382+ | LeftOp NullityType NullityType

383+ | RightOp NullityType NullityType

384+

372385{- | The schema of a database consists of a list of aliased,

373386user-defined `SchemumType`s.

374387