0a95352 · squeal · git.iko.soy

git.iko.soy/squeal

on dev help sign in

move type families to Schema module

0a95352Mike Ledger8 years ago

squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs+4−41

compare with dev

unifiedsplit

@@ -8,7 +8,7 @@ Stability: experimental

8Squeal expressions are the atoms used to build statements.

9-}

11−{-# OPTIONS_GHC -fno-warn-redundant-constraints -fno-warn-unticked-promoted-constructors #-}

11+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

12{-# LANGUAGE

13 AllowAmbiguousTypes

14 , ConstraintKinds

@@ -917,35 +917,6 @@ comments lifted directly from this page.

917Table 9.44: json and jsonb operators

918-----------------------------------------}

919

920−type PGjsonKey key = key `In` '[ 'PGint2, 'PGint4, 'PGtext ]

921−

922−type PGjson_ json = json `In` '[ 'PGjson, 'PGjsonb ]

923−

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

927−type ErrPGvararrayOf t = ErrArrayOf ('ShowType 'PGvararray) t

928−

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

948−

949-- | Get JSON value (object field or array element) at a key.

920-- | Get JSON value (object field or array element) at a key.

950(.->)

921(.->)

951 :: (PGjson_ json, PGjsonKey key)

922 :: (PGjson_ json, PGjsonKey key)

@@ -964,7 +935,7 @@ type IsPGtextArray name arr = PGarrayOf name arr 'PGtext

964

935

965-- | Get JSON value at a specified path.

936-- | Get JSON value at a specified path.

966(.#>)

937(.#>)

967− :: (PGjson_ json, IsPGtextArray "(.#>)" path)

938+ :: (PGjson_ json, PGtextArray "(.#>)" path)

968 => Expression schema relations grouping params (nullity json)

939 => Expression schema relations grouping params (nullity json)

969 -> Expression schema relations grouping params (nullity path)

940 -> Expression schema relations grouping params (nullity path)

970 -> Expression schema relations grouping params ('Null json)

941 -> Expression schema relations grouping params ('Null json)

@@ -972,7 +943,7 @@ type IsPGtextArray name arr = PGarrayOf name arr 'PGtext

972

943

973-- | Get JSON value at a specified path as text.

944-- | Get JSON value at a specified path as text.

974(.#>>)

945(.#>>)

975− :: (PGjson_ json, IsPGtextArray "(.#>>)" path)

946+ :: (PGjson_ json, PGtextArray "(.#>>)" path)

976 => Expression schema relations grouping params (nullity json)

947 => Expression schema relations grouping params (nullity json)

977 -> Expression schema relations grouping params (nullity path)

948 -> Expression schema relations grouping params (nullity path)

978 -> Expression schema relations grouping params ('Null 'PGtext)

949 -> Expression schema relations grouping params ('Null 'PGtext)

@@ -1046,7 +1017,7 @@ type IsPGtextArray name arr = PGarrayOf name arr 'PGtext

1046-- | Delete the field or element with specified path (for JSON arrays, negative

1017-- | Delete the field or element with specified path (for JSON arrays, negative

1047-- integers count from the end)

1018-- integers count from the end)

1048(#-.)

1019(#-.)

1049− :: IsPGtextArray "(#-.)" arrayty

1020+ :: PGtextArray "(#-.)" arrayty

1050 => Expression schema relations grouping params (nullity 'PGjsonb)

1021 => Expression schema relations grouping params (nullity 'PGjsonb)

1051 -> Expression schema relations grouping params (nullity arrayty)

1022 -> Expression schema relations grouping params (nullity arrayty)

1052 -> Expression schema relations grouping params (nullity 'PGjsonb)

1023 -> Expression schema relations grouping params (nullity 'PGjsonb)

@@ -1110,14 +1081,6 @@ jsonbBuildArray

1110 -> Expression schema relations grouping params (nullity 'PGjsonb)

1081 -> Expression schema relations grouping params (nullity 'PGjsonb)

1111jsonbBuildArray = unsafeVariadicFunction "jsonb_build_array"

1082jsonbBuildArray = unsafeVariadicFunction "jsonb_build_array"

1112

1083

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

1084-- | Builds a possibly-heterogeneously-typed JSON object out of a variadic

1122-- argument list. The elements of the argument list must alternate between text

1085-- argument list. The elements of the argument list must alternate between text

1123-- and values.

1086-- and values.

squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+55−1

@@ -10,7 +10,7 @@ tables, schema, constraints, aliases, enumerated labels, and groupings.

10It also defines useful type families to operate on these. Finally,

11it defines an embedding of Haskell types into Postgres types.

12-}

13−

13+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}

14{-# LANGUAGE

15 AllowAmbiguousTypes

16 , ConstraintKinds

@@ -89,6 +89,10 @@ module Squeal.PostgreSQL.Schema

89 , PGIntegral

90 , PGFloating

91 , PGTypeOf

92+ , PGarrayOf

93+ , PGarray

94+ , PGtextArray

95+ , PGobjectpairs

92 , SameTypes

96 , SameTypes

93 , SamePGType

97 , SamePGType

94 , AllNotNull

98 , AllNotNull

@@ -101,6 +105,9 @@ module Squeal.PostgreSQL.Schema

101 , TableToRelation

105 , TableToRelation

102 , ConstraintInvolves

106 , ConstraintInvolves

103 , DropIfConstraintsInvolve

107 , DropIfConstraintsInvolve

108+ -- ** JSON support

109+ , PGjson_

110+ , PGjsonKey

104 -- * Embedding

111 -- * Embedding

105 , PG

112 , PG

106 , EnumFrom

113 , EnumFrom

@@ -506,6 +513,46 @@ type PGFloating ty = In ty '[ 'PGfloat4, 'PGfloat8, 'PGnumeric]

506-- `Squeal.PostgreSQL.Expression.mod_` functions.

513-- `Squeal.PostgreSQL.Expression.mod_` functions.

507type PGIntegral ty = In ty '[ 'PGint2, 'PGint4, 'PGint8]

514type PGIntegral ty = In ty '[ 'PGint2, 'PGint4, 'PGint8]

508

515

516+-- | Error message helper for displaying unavailable\/unknown\/placeholder type

517+-- variables whose kind is known.

518+type Placeholder k = 'Text "(_::" :<>: 'ShowType k :<>: 'Text ")"

519+

520+type ErrArrayOf arr ty = arr :<>: 'Text " " :<>: ty

521+type ErrPGfixarrayOf t = ErrArrayOf ('ShowType 'PGfixarray :<>: 'Text " " :<>: Placeholder Nat) t

522+type ErrPGvararrayOf t = ErrArrayOf ('ShowType 'PGvararray) t

523+

524+-- | Ensure a type is a valid array type.

525+type family PGarray name arr :: Constraint where

526+ PGarray name ('PGvararray x) = ()

527+ PGarray name ('PGfixarray n x) = ()

528+ PGarray name val = TypeError

529+ ('Text name :<>: 'Text ": Unsatisfied PGarray constraint. Expected either: "

530+ :$$: 'Text " • " :<>: ErrPGvararrayOf (Placeholder PGType)

531+ :$$: 'Text " • " :<>: ErrPGfixarrayOf (Placeholder PGType)

532+ :$$: 'Text "But got: " :<>: 'ShowType val)

533+

534+-- | Ensure a type is a valid array type with a specific element type.

535+type family PGarrayOf name arr ty :: Constraint where

536+ PGarrayOf name ('PGvararray x) ty = x ~ ty

537+ PGarrayOf name ('PGfixarray n x) ty = x ~ ty

538+ PGarrayOf name val ty = TypeError

539+ ( 'Text name :<>: 'Text "Unsatisfied PGarrayOf constraint. Expected either: "

540+ :$$: 'Text " • " :<>: ErrPGvararrayOf ( 'ShowType ty )

541+ :$$: 'Text " • " :<>: ErrPGfixarrayOf ( 'ShowType ty )

542+ :$$: 'Text "But got: " :<>: 'ShowType val)

543+

544+-- | Ensure a type is a valid array type whose elements are text.

545+type PGtextArray name arr = PGarrayOf name arr 'PGtext

546+

547+-- | Ensure a list of arguments is an alternating list of text and value pairs.

548+type family PGobjectpairs name x :: Constraint where

549+ PGobjectpairs name ('NotNull 'PGtext : arg : xs) = PGobjectpairs name xs

550+ PGobjectpairs name '[] = ()

551+ PGobjectpairs name (x:xs) = TypeError

552+ ( 'Text name :<>: 'Text ": Incorrect argument list:"

553+ :$$: 'Text "Expected alternating list of keys and values."

554+ :$$: 'Text "But got " :<>: 'ShowType (x:xs))

555+

509-- | `PGTypeOf` forgets about @NULL@ and any column constraints.

556-- | `PGTypeOf` forgets about @NULL@ and any column constraints.

510type family PGTypeOf (ty :: NullityType) :: PGType where

557type family PGTypeOf (ty :: NullityType) :: PGType where

511 PGTypeOf (nullity pg) = pg

558 PGTypeOf (nullity pg) = pg

@@ -837,3 +884,10 @@ type family RecordCodeOf (hask :: Type) (code ::[[Type]]) :: [Type] where

837 RecordCodeOf _hask '[tys] = tys

884 RecordCodeOf _hask '[tys] = tys

838 RecordCodeOf hask _tys = TypeError

885 RecordCodeOf hask _tys = TypeError

839 ('Text "RecordCodeOf error: non-Record type " ':<>: 'ShowType hask)

886 ('Text "RecordCodeOf error: non-Record type " ':<>: 'ShowType hask)

887+

888+-- | Is a type a valid JSON key?

889+type PGjsonKey key = key `In` '[ 'PGint2, 'PGint4, 'PGtext ]

890+

891+-- | Is a type a valid JSON type?

892+type PGjson_ json = json `In` '[ 'PGjson, 'PGjsonb ]

893+