0a95352 · squeal · git.iko.soy

git.iko.soy/squeal

move type families to Schema module

commit0a953522971f0f2df0b0768aeee48c7296480cf8 authorMike Ledger <mike@quasimal.com> dateWed 11 Jul 2018, 15:26 (8 years ago) parent7f6cb75

2 files changed+59−42

compare with dev

unifiedsplit

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

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

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

88Squeal expressions are the atoms used to build statements.

99-}

1010

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

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

1212{-# LANGUAGE

1313 AllowAmbiguousTypes

1414 , ConstraintKinds

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

917917Table 9.44: json and jsonb operators

918918-----------------------------------------}

919919

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−

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

950921(.->)

951922 :: (PGjson_ json, PGjsonKey key)

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

964935

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

966937(.#>)

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

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

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

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

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

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

972943

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

974945(.#>>)

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

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

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

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

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

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

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

10471018-- integers count from the end)

10481019(#-.)

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

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

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

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

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

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

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

11111082jsonbBuildArray = unsafeVariadicFunction "jsonb_build_array"

11121083

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−

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

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

11231086-- and values.

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

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

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

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

1212-}

13−

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

1414{-# LANGUAGE

1515 AllowAmbiguousTypes

1616 , ConstraintKinds

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

8989 , PGIntegral

9090 , PGFloating

9191 , PGTypeOf

92+ , PGarrayOf

93+ , PGarray

94+ , PGtextArray

95+ , PGobjectpairs

9296 , SameTypes

9397 , SamePGType

9498 , AllNotNull

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

101105 , TableToRelation

102106 , ConstraintInvolves

103107 , DropIfConstraintsInvolve

108+ -- ** JSON support

109+ , PGjson_

110+ , PGjsonKey

104111 -- * Embedding

105112 , PG

106113 , EnumFrom

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

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

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

508515

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+

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

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

511558 PGTypeOf (nullity pg) = pg

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

837884 RecordCodeOf _hask '[tys] = tys

838885 RecordCodeOf hask _tys = TypeError

839886 ('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+