@@ -8,7 +8,7 @@ Stability: experimental
88Squeal expressions are the atoms used to build statements.
99-}
1010
11−{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
11+{-# OPTIONS_GHC -fno-warn-redundant-constraints -fno-warn-unticked-promoted-constructors #-}
1212{-# LANGUAGE
1313 AllowAmbiguousTypes
1414 , ConstraintKinds
@@ -50,6 +50,7 @@ module Squeal.PostgreSQL.Expression
5050 , unsafeBinaryOp
5151 , unsafeUnaryOp
5252 , unsafeFunction
53+ , unsafeVariadicFunction
5354 , atan2_
5455 , cast
5556 , quot_
@@ -90,6 +91,7 @@ module Squeal.PostgreSQL.Expression
9091 , PGarrayOf
9192 , PGjsonKey
9293 , PGjson_
94+ , PGobjectpairs
9395 , (.->)
9496 , (.->>)
9597 , (.#>)
@@ -108,6 +110,10 @@ module Squeal.PostgreSQL.Expression
108110 , toJsonb
109111 , arrayToJson
110112 , rowToJson
113+ , jsonBuildArray
114+ , jsonbBuildArray
115+ , jsonBuildObject
116+ , jsonbBuildObject
111117 , jsonObjectKeys
112118 , jsonbObjectKeys
113119 -- ** Aggregation
@@ -506,12 +512,13 @@ unsafeFunction fun x = UnsafeExpression $
506512 fun <> parenthesized (renderExpression x)
507513
508514unsafeVariadicFunction
509− :: ByteString
515+ :: SListI elems
516+ => ByteString
510517 -- ^ function
511− -> [Expression schema relations grouping params xty]
512− -> Expression schema relations grouping params (yty)
518+ -> NP (Expression schema relations grouping params) elems
519+ -> Expression schema relations grouping params ret
513520unsafeVariadicFunction fun x = UnsafeExpression $
514− fun <> parenthesized (commaSeparated (map renderExpression x))
521+ fun <> parenthesized (commaSeparated (hcollapse (hmap (K . renderExpression) x)))
515522
516523instance PGNum ty
517524 => Num (Expression schema relations grouping params (nullity ty)) where
@@ -902,132 +909,119 @@ like
902909like = unsafeBinaryOp "LIKE"
903910
904911{-----------------------------------------
905−json and jsonb operators
906−see https://www.postgresql.org/docs/10/static/functions-json.html
912+ -- json and jsonb support
913+
914+See https://www.postgresql.org/docs/10/static/functions-json.html -- most
915+comments lifted directly from this page.
916+
917+Table 9.44: json and jsonb operators
907918-----------------------------------------}
908919
909920type PGjsonKey key = key `In` '[ 'PGint2, 'PGint4, 'PGtext ]
910921
911922type PGjson_ json = json `In` '[ 'PGjson, 'PGjsonb ]
912923
913−type Placeholder k
914− = 'Text "(_"
915− ':<>: 'Text "::"
916− ':<>: 'ShowType k ':<>:
917− 'Text ")"
918−
919−type ErrArrayOf arr ty = arr ':<>: 'Text " " ':<>: ty
920−type ErrPGfixarrayOf t = ErrArrayOf ('ShowType 'PGfixarray ':<>: 'Text " " ':<>: Placeholder Nat) t
924+type Placeholder k = 'Text "(_::" :<>: 'ShowType k :<>: 'Text ")"
925+type ErrArrayOf arr ty = arr :<>: 'Text " " :<>: ty
926+type ErrPGfixarrayOf t = ErrArrayOf ('ShowType 'PGfixarray :<>: 'Text " " :<>: Placeholder Nat) t
921927type ErrPGvararrayOf t = ErrArrayOf ('ShowType 'PGvararray) t
922928
923−type family PGarray arr :: Constraint where
924− PGarray ('PGvararray x) = ()
925− PGarray ('PGfixarray n x) = ()
926− PGarray val = TypeError
927− ('Text "Unsatisfied PGarrayOf constraint. Expected either: "
928− ':$$: 'Text " • " ':<>: ErrPGvararrayOf (Placeholder PGType)
929− ':$$: 'Text " • " ':<>: ErrPGfixarrayOf (Placeholder PGType)
930− ':$$: 'Text "But got: " ':<>: 'ShowType val)
931−
932−type family PGarrayOf arr ty :: Constraint where
933− PGarrayOf ('PGvararray x) ty = x ~ ty
934− PGarrayOf ('PGfixarray n x) ty = x ~ ty
935− PGarrayOf val ty = TypeError
936− ('Text "Unsatisfied PGarrayOf constraint. Expected either: "
937− ':$$: 'Text " • " ':<>: ErrPGvararrayOf ('ShowType ty)
938− ':$$: 'Text " • " ':<>: ErrPGfixarrayOf ('ShowType ty)
939− ':$$: 'Text "But got: " ':<>: 'ShowType val)
940−
941−type IsPGtextArray arr = PGarrayOf arr 'PGtext
929+type family PGarray name arr :: Constraint where
930+ PGarray name ('PGvararray x) = ()
931+ PGarray name ('PGfixarray n x) = ()
932+ PGarray name val = TypeError
933+ ('Text name :<>: 'Text ": Unsatisfied PGarrayOf constraint. Expected either: "
934+ :$$: 'Text " • " :<>: ErrPGvararrayOf (Placeholder PGType)
935+ :$$: 'Text " • " :<>: ErrPGfixarrayOf (Placeholder PGType)
936+ :$$: 'Text "But got: " :<>: 'ShowType val)
937+
938+type family PGarrayOf name arr ty :: Constraint where
939+ PGarrayOf name ('PGvararray x) ty = x ~ ty
940+ PGarrayOf name ('PGfixarray n x) ty = x ~ ty
941+ PGarrayOf name val ty = TypeError
942+ ( 'Text name :<>: 'Text "Unsatisfied PGarrayOf constraint. Expected either: "
943+ :$$: 'Text " • " :<>: ErrPGvararrayOf ( 'ShowType ty )
944+ :$$: 'Text " • " :<>: ErrPGfixarrayOf ( 'ShowType ty )
945+ :$$: 'Text "But got: " :<>: 'ShowType val)
946+
947+type IsPGtextArray name arr = PGarrayOf name arr 'PGtext
942948
943949-- | Get JSON value (object field or array element) at a key.
944950(.->)
945951 :: (PGjson_ json, PGjsonKey key)
946− => Expression schema relations grouping params (jnull json)
947− -> Expression schema relations grouping params (knull key)
952+ => Expression schema relations grouping params (nullity json)
953+ -> Expression schema relations grouping params (nullity key)
948954 -> Expression schema relations grouping params ('Null json)
949955(.->) = unsafeBinaryOp "->"
950956
951957-- | Get JSON value (object field or array element) at a key, as text.
952958(.->>)
953959 :: (PGjson_ json, PGjsonKey key)
954− => Expression schema relations grouping params (jnull json)
955− -> Expression schema relations grouping params (knull key)
960+ => Expression schema relations grouping params (nullity json)
961+ -> Expression schema relations grouping params (nullity key)
956962 -> Expression schema relations grouping params ('Null 'PGtext)
957963(.->>) = unsafeBinaryOp "->>"
958964
959965-- | Get JSON value at a specified path.
960966(.#>)
961− :: (PGjson_ json, IsPGtextArray path)
962− => Expression schema relations grouping params (jnull json)
963− -> Expression schema relations grouping params (knull path)
967+ :: (PGjson_ json, IsPGtextArray "(.#>)" path)
968+ => Expression schema relations grouping params (nullity json)
969+ -> Expression schema relations grouping params (nullity path)
964970 -> Expression schema relations grouping params ('Null json)
965971(.#>) = unsafeBinaryOp "#>"
966972
967973-- | Get JSON value at a specified path as text.
968974(.#>>)
969− :: (PGjson_ json, IsPGtextArray path)
970− => Expression schema relations grouping params (jnull json)
971− -> Expression schema relations grouping params (knull path)
975+ :: (PGjson_ json, IsPGtextArray "(.#>>)" path)
976+ => Expression schema relations grouping params (nullity json)
977+ -> Expression schema relations grouping params (nullity path)
972978 -> Expression schema relations grouping params ('Null 'PGtext)
973979(.#>>) = unsafeBinaryOp "#>>"
974980
975981-- Additional jsonb operators
976982
977−-- | Or operator for nulls; if either argument is null, then the result is null.
978−type family Null2 a b where
979− Null2 'Null a = 'Null
980− Null2 a 'Null = 'Null
981− Null2 'NotNull 'NotNull = 'NotNull
982−
983−-- | See 'Null2'
984−type family NullOfN xs where
985− NullOfN ('Null ty:xs) = 'Null
986− NullOfN (x:xs) = NullOfN xs
987− NullOfN '[] = 'NotNull
988−
989983-- | Does the left JSON value contain the right JSON path/value entries at the
990984-- top level?
991985(.@>)
992− :: Expression schema relations grouping params (null0 'PGjsonb)
993− -> Expression schema relations grouping params (null1 'PGjsonb)
994− -> Expression schema relations grouping params (Null2 null0 null1 'PGbool)
986+ :: Expression schema relations grouping params (nullity 'PGjsonb)
987+ -> Expression schema relations grouping params (nullity 'PGjsonb)
988+ -> Expression schema relations grouping params ('NotNull 'PGbool)
995989(.@>) = unsafeBinaryOp "@>"
996990
997991-- | Are the left JSON path/value entries contained at the top level within the
998992-- right JSON value?
999993(.<@)
1000− :: Expression schema relations grouping params (null0 'PGjsonb)
1001− -> Expression schema relations grouping params (null1 'PGjsonb)
1002− -> Expression schema relations grouping params (Null2 null0 null1 'PGbool)
994+ :: Expression schema relations grouping params (nullity 'PGjsonb)
995+ -> Expression schema relations grouping params (nullity 'PGjsonb)
996+ -> Expression schema relations grouping params ('NotNull 'PGbool)
1003997(.<@) = unsafeBinaryOp "<@"
1004998
1005999-- | Does the string exist as a top-level key within the JSON value?
10061000(.?)
1007− :: Expression schema relations grouping params (null0 'PGjsonb)
1008− -> Expression schema relations grouping params (null1 'PGtext)
1009− -> Expression schema relations grouping params (Null2 null0 null1 'PGbool)
1001+ :: Expression schema relations grouping params (nullity 'PGjsonb)
1002+ -> Expression schema relations grouping params (nullity 'PGtext)
1003+ -> Expression schema relations grouping params ('NotNull 'PGbool)
10101004(.?) = unsafeBinaryOp "?"
10111005
10121006-- | Do any of these array strings exist as top-level keys?
10131007(.?|)
1014− :: Expression schema relations grouping params (null0 'PGjsonb)
1015− -> Expression schema relations grouping params (null1 ('PGvararray 'PGtext))
1016− -> Expression schema relations grouping params (Null2 null0 null1 'PGbool)
1008+ :: Expression schema relations grouping params (nullity 'PGjsonb)
1009+ -> Expression schema relations grouping params (nullity ('PGvararray 'PGtext))
1010+ -> Expression schema relations grouping params ('NotNull 'PGbool)
10171011(.?|) = unsafeBinaryOp "?|"
10181012
10191013-- | Do all of these array strings exist as top-level keys?
10201014(.?&)
1021− :: Expression schema relations grouping params (null0 'PGjsonb)
1022− -> Expression schema relations grouping params (null1 ('PGvararray 'PGtext))
1023− -> Expression schema relations grouping params (Null2 null0 null1 'PGbool)
1015+ :: Expression schema relations grouping params (nullity 'PGjsonb)
1016+ -> Expression schema relations grouping params (nullity ('PGvararray 'PGtext))
1017+ -> Expression schema relations grouping params ('NotNull 'PGbool)
10241018(.?&) = unsafeBinaryOp "?&"
10251019
1026−-- | Concatenate two jsonb values into a new jsonb value
1020+-- | Concatenate two jsonb values into a new jsonb value.
10271021(.||.)
1028− :: Expression schema relations grouping params (null0 'PGjsonb)
1029− -> Expression schema relations grouping params (null1 'PGjsonb)
1030− -> Expression schema relations grouping params (Null2 null0 null1 'PGjsonb)
1022+ :: Expression schema relations grouping params (nullity 'PGjsonb)
1023+ -> Expression schema relations grouping params (nullity 'PGjsonb)
1024+ -> Expression schema relations grouping params (nullity 'PGjsonb)
10311025(.||.) = unsafeBinaryOp "||"
10321026
10331027-- | Delete a key or keys from a JSON object, or remove an array element.
@@ -1044,41 +1038,163 @@ type family NullOfN xs where
10441038-- count from the end). Throws an error if top level container is not an array.
10451039(.-.)
10461040 :: (key `In` '[ 'PGtext, 'PGvararray 'PGtext, 'PGint4, 'PGint2 ]) -- hlint error without parens here
1047− => Expression schema relations grouping params (null0 'PGjsonb)
1048− -> Expression schema relations grouping params (null1 key)
1049− -> Expression schema relations grouping params (Null2 null0 null1 'PGjsonb)
1041+ => Expression schema relations grouping params (nullity 'PGjsonb)
1042+ -> Expression schema relations grouping params (nullity key)
1043+ -> Expression schema relations grouping params (nullity 'PGjsonb)
10501044(.-.) = unsafeBinaryOp "-"
10511045
10521046-- | Delete the field or element with specified path (for JSON arrays, negative
10531047-- integers count from the end)
10541048(#-.)
1055− :: IsPGtextArray arrayty
1056− => Expression schema relations grouping params (null0 'PGjsonb)
1057− -> Expression schema relations grouping params (null1 arrayty)
1058− -> Expression schema relations grouping params (Null2 null0 null1 'PGjsonb)
1049+ :: IsPGtextArray "(#-.)" arrayty
1050+ => Expression schema relations grouping params (nullity 'PGjsonb)
1051+ -> Expression schema relations grouping params (nullity arrayty)
1052+ -> Expression schema relations grouping params (nullity 'PGjsonb)
10591053(#-.) = unsafeBinaryOp "#-"
10601054
1055+{-----------------------------------------
1056+Table 9.45: JSON creation functions
1057+-----------------------------------------}
1058+
1059+-- | Returns the value as json. Arrays and composites are converted
1060+-- (recursively) to arrays and objects; otherwise, if there is a cast from the
1061+-- type to json, the cast function will be used to perform the conversion;
1062+-- otherwise, a scalar value is produced. For any scalar type other than a
1063+-- number, a Boolean, or a null value, the text representation will be used, in
1064+-- such a fashion that it is a valid json value.
10611065toJson
10621066 :: Expression schema relations grouping params (nullity ty)
10631067 -> Expression schema relations grouping params (nullity 'PGjson)
10641068toJson = unsafeFunction "to_json"
10651069
1070+-- | Returns the value as jsonb. Arrays and composites are converted
1071+-- (recursively) to arrays and objects; otherwise, if there is a cast from the
1072+-- type to json, the cast function will be used to perform the conversion;
1073+-- otherwise, a scalar value is produced. For any scalar type other than a
1074+-- number, a Boolean, or a null value, the text representation will be used, in
1075+-- such a fashion that it is a valid jsonb value.
10661076toJsonb
10671077 :: Expression schema relations grouping params (nullity ty)
10681078 -> Expression schema relations grouping params (nullity 'PGjsonb)
10691079toJsonb = unsafeUnaryOp "to_jsonb"
10701080
1081+-- | Returns the array as a JSON array. A PostgreSQL multidimensional array
1082+-- becomes a JSON array of arrays. Line feeds will be added between dimension-1
1083+-- elements if pretty_bool is true.
10711084arrayToJson
1072− :: PGarray arr
1085+ :: PGarray "arrayToJson" arr
10731086 => Expression schema relations grouping params (nullity arr)
10741087 -> Expression schema relations grouping params (nullity 'PGjson)
10751088arrayToJson = unsafeFunction "array_to_json"
10761089
1090+-- | Returns the row as a JSON object. Line feeds will be added between level-1
1091+-- elements if pretty_bool is true.
10771092rowToJson
10781093 :: Expression schema relations grouping params (nullity ('PGcomposite ty))
10791094 -> Expression schema relations grouping params (nullity 'PGjson)
10801095rowToJson = unsafeFunction "row_to_json"
10811096
1097+-- | Builds a possibly-heterogeneously-typed JSON array out of a variadic
1098+-- argument list.
1099+jsonBuildArray
1100+ :: SListI elems
1101+ => NP (Expression schema relations grouping params) elems
1102+ -> Expression schema relations grouping params (nullity 'PGjson)
1103+jsonBuildArray = unsafeVariadicFunction "json_build_array"
1104+
1105+-- | Builds a possibly-heterogeneously-typed (binary) JSON array out of a
1106+-- variadic argument list.
1107+jsonbBuildArray
1108+ :: SListI elems
1109+ => NP (Expression schema relations grouping params) elems
1110+ -> Expression schema relations grouping params (nullity 'PGjsonb)
1111+jsonbBuildArray = unsafeVariadicFunction "jsonb_build_array"
1112+
1113+type family PGobjectpairs name x :: Constraint where
1114+ PGobjectpairs name ('NotNull 'PGtext : nullity arg : xs) = PGobjectpairs name xs
1115+ PGobjectpairs name '[] = ()
1116+ PGobjectpairs name (x:xs) = TypeError
1117+ ( 'Text name :<>: 'Text ": Incorrect argument list:"
1118+ :$$: 'Text "Expected alternating list of keys and values."
1119+ :$$: 'Text "But got " :<>: 'ShowType (x:xs))
1120+
1121+-- | Builds a possibly-heterogeneously-typed JSON object out of a variadic
1122+-- argument list. The elements of the argument list must alternate between text
1123+-- and values.
1124+jsonBuildObject
1125+ :: (PGobjectpairs "jsonBuildObject" elems, SListI elems)
1126+ => NP (Expression schema relations grouping params) elems
1127+ -> Expression schema relations grouping params (nullity 'PGjson)
1128+jsonBuildObject = unsafeVariadicFunction "json_build_object"
1129+
1130+-- | Builds a possibly-heterogeneously-typed (binary) JSON object out of a
1131+-- variadic argument list. The elements of the argument list must alternate
1132+-- between text and values.
1133+jsonbBuildObject
1134+ :: (PGobjectpairs "jsonbBuildObject" elems, SListI elems)
1135+ => NP (Expression schema relations grouping params) elems
1136+ -> Expression schema relations grouping params (nullity 'PGjsonb)
1137+jsonbBuildObject = unsafeVariadicFunction "jsonb_build_object"
1138+
1139+-- | Builds a JSON object out of a text array. The array must have either
1140+-- exactly one dimension with an even number of members, in which case they are
1141+-- taken as alternating key/value pairs, or two dimensions such that each inner
1142+-- array has exactly two elements, which are taken as a key/value pair.
1143+jsonObject
1144+ :: PGarrayOf "jsonObject" arr 'PGtext
1145+ => Expression schema relations grouping params (nullity arr)
1146+ -> Expression schema relations grouping params (nullity 'PGjson)
1147+jsonObject = unsafeFunction "json_object"
1148+
1149+-- | Builds a binary JSON object out of a text array. The array must have either
1150+-- exactly one dimension with an even number of members, in which case they are
1151+-- taken as alternating key/value pairs, or two dimensions such that each inner
1152+-- array has exactly two elements, which are taken as a key/value pair.
1153+jsonbObject
1154+ :: PGarrayOf "jsonbObject" arr 'PGtext
1155+ => Expression schema relations grouping params (nullity arr)
1156+ -> Expression schema relations grouping params (nullity 'PGjsonb)
1157+jsonbObject = unsafeFunction "jsonb_object"
1158+
1159+-- | This is an alternate form of 'jsonObject' that takes two arrays; one for
1160+-- keys and one for values, that are zipped pairwise to create a JSON object.
1161+jsonZipObject
1162+ :: ( PGarrayOf "jsonZipObject" keysArray 'PGtext
1163+ , PGarrayOf "jsonZipObject" valuesArray 'PGtext)
1164+ => Expression schema relations grouping params (nullity keysArray)
1165+ -> Expression schema relations grouping params (nullity valuesArray)
1166+ -> Expression schema relations grouping params (nullity 'PGjson)
1167+jsonZipObject ks vs =
1168+ unsafeVariadicFunction "json_object" (ks :* vs :* Nil)
1169+
1170+-- | This is an alternate form of 'jsonObject' that takes two arrays; one for
1171+-- keys and one for values, that are zipped pairwise to create a binary JSON
1172+-- object.
1173+jsonbZipObject
1174+ :: ( PGarrayOf "jsonbZipObject" keysArray 'PGtext
1175+ , PGarrayOf "jsonbZipObject" valuesArray 'PGtext)
1176+ => Expression schema relations grouping params (nullity keysArray)
1177+ -> Expression schema relations grouping params (nullity valuesArray)
1178+ -> Expression schema relations grouping params (nullity 'PGjsonb)
1179+jsonbZipObject ks vs =
1180+ unsafeVariadicFunction "jsonb_object" (ks :* vs :* Nil)
1181+
1182+{-----------------------------------------
1183+Table 9.46: JSON processing functions
1184+-----------------------------------------}
1185+
1186+-- | Returns the number of elements in the outermost JSON array.
1187+jsonArrayLength
1188+ :: Expression schema relations grouping params (nullity 'PGjson)
1189+ -> Expression schema relations grouping params (nullity 'PGint4)
1190+jsonArrayLength = unsafeFunction "json_array_length"
1191+
1192+-- | Returns the number of elements in the outermost binary JSON array.
1193+jsonbArrayLength
1194+ :: Expression schema relations grouping params (nullity 'PGjsonb)
1195+ -> Expression schema relations grouping params (nullity 'PGint4)
1196+jsonbArrayLength = unsafeFunction "jsonb_array_length"
1197+
10821198jsonObjectKeys
10831199 :: Expression schema relations grouping params (nullity 'PGjson)
10841200 -> Expression schema relations grouping params (nullity 'PGtext)
@@ -1089,10 +1205,6 @@ jsonbObjectKeys
10891205 -> Expression schema relations grouping params (nullity 'PGtext)
10901206jsonbObjectKeys = unsafeFunction "jsonb_object_keys"
10911207
1092−-- TODO: jsonBuildArray, jsonbBuildArray, jsonObject, jsonbObject
1093−-- probably something like
1094−-- :: NP (Expression s r g p) xs -> Expression s r g p ('NotNull 'PGjson[b])
1095−
10961208{-----------------------------------------
10971209aggregation
10981210-----------------------------------------}