7ce2cb7 · squeal · git.iko.soy

git.iko.soy/squeal

didn't quite make it

commit7ce2cb785257009330c14a7d17eee04a61a53025 authorEitan Chatav <eitan.chatav@gmail.com> dateWed 11 Jul 2018, 15:58 (8 years ago) parent739a943

6 files changed+72−146

compare with dev

unifiedsplit

squeal-postgresql/squeal-postgresql.cabal+1 squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs+4−8 squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+13−8 squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs+34−34 squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+18−96 stack.yaml+2

squeal-postgresql/squeal-postgresql.cabal+1

@@ -51,6 +51,7 @@ library

5151 , postgresql-binary >= 0.12.1

5252 , postgresql-libpq >= 0.9.4.1

5353 , profunctors >= 5.2.2

54+ , records-sop >= 0.1.0.0

5455 , resource-pool >= 0.2.3.2

5556 , scientific >= 0.3.5.3

5657 , text >= 1.2.3.0

squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs+4−8

@@ -171,6 +171,7 @@ import Data.UUID.Types

171171import Data.Vector (Vector)

172172import Data.Word

173173import Generics.SOP

174+import Generics.SOP.Record

174175import GHC.TypeLits

175176import Network.IP.Addr

176177

@@ -262,10 +263,8 @@ instance

262263 . from

263264instance

264265 ( SListI fields

265− , MapMaybes xs

266− , IsProductType x (Maybes xs)

266+ , IsRecord x xs

267267 , AllZip ToAliasedParam xs fields

268− , FieldNamesFrom x ~ AliasesOf fields

269268 , All HasAliasedOid fields

270269 ) => ToParam x ('PGcomposite fields) where

271270 toParam =

@@ -435,10 +434,8 @@ instance

435434

436435instance

437436 ( SListI fields

438− , MapMaybes ys

439− , IsProductType y (Maybes ys)

437+ , IsRecord y ys

440438 , AllZip FromAliasedValue fields ys

441− , FieldNamesFrom y ~ AliasesOf fields

442439 ) => FromValue ('PGcomposite fields) y where

443440 fromValue =

444441 let

@@ -529,9 +526,8 @@ class SListI results => FromRow (results :: RelationType) y where

529526 fromRow :: NP (K (Maybe Strict.ByteString)) results -> y

530527instance

531528 ( SListI results

532− , IsProductType y ys

529+ , IsRecord y ys

533530 , AllZip FromColumnValue results ys

534− , FieldNamesFrom y ~ AliasesOf results

535531 ) => FromRow results y where

536532 fromRow

537533 = to . SOP . Z . htrans (Proxy @FromColumnValue) (I . fromColumnValue)

squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+13−8

@@ -904,17 +904,22 @@ createTypeComposite ty fields = UnsafeDefinition $

904904-- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);

905905createTypeCompositeFrom

906906 :: forall hask ty schema.

907− ( ZipAliased (FieldNamesFrom hask) (FieldTypesFrom hask)

908− , SOP.All (PGTyped schema) (FieldTypesFrom hask)

907+ ( SOP.All (BaseTyped schema) (PGFieldsFrom hask)

909908 , KnownSymbol ty

910909 )

911910 => Alias ty

912911 -- ^ name of the user defined composite type

913912 -> Definition schema (Create ty ( 'Typedef (CompositeFrom hask)) schema)

914−createTypeCompositeFrom ty = createTypeComposite ty $ zipAs

915− (SOP.hpure Alias :: NP Alias (FieldNamesFrom hask))

916− (SOP.hcpure (SOP.Proxy :: SOP.Proxy (PGTyped schema)) pgtype

917− :: NP (TypeExpression schema) (FieldTypesFrom hask))

913+createTypeCompositeFrom ty = createTypeComposite ty

914+ (SOP.hcpure (SOP.Proxy :: SOP.Proxy (BaseTyped schema)) basetype

915+ :: NP (Aliased (TypeExpression schema)) (PGFieldsFrom hask))

916+

917+

918+class BaseTyped (schema :: SchemaType) (ty :: (Symbol,NullityType)) where

919+ basetype :: Aliased (TypeExpression schema) ty

920+instance (KnownSymbol alias, PGTyped schema ty)

921+ => BaseTyped schema (alias ::: nullity ty) where

922+ basetype = pgtype @schema @ty `As` Alias @alias

918923

919924-- | Drop a type.

920925--

@@ -938,14 +943,14 @@ newtype ColumnTypeExpression (schema :: SchemaType) (ty :: ColumnType)

938943-- | used in `createTable` commands as a column constraint to note that

939944-- @NULL@ may be present in a column

940945nullable

941− :: TypeExpression schema ty

946+ :: (forall nullity. TypeExpression schema (nullity ty))

942947 -> ColumnTypeExpression schema ('NoDef :=> 'Null ty)

943948nullable ty = UnsafeColumnTypeExpression $ renderTypeExpression ty <+> "NULL"

944949

945950-- | used in `createTable` commands as a column constraint to ensure

946951-- @NULL@ is not present in a column

947952notNullable

948− :: TypeExpression schema ty

953+ :: (forall nullity. TypeExpression schema (nullity ty))

949954 -> ColumnTypeExpression schema (def :=> 'NotNull ty)

950955notNullable ty = UnsafeColumnTypeExpression $ renderTypeExpression ty <+> "NOT NULL"

951956

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

@@ -195,7 +195,7 @@ class KnownNat n => HasParameter

195195 -- >>> printSQL expr

196196 -- ($1 :: int4)

197197 parameter

198− :: TypeExpression schema (PGTypeOf ty)

198+ :: TypeExpression schema ty

199199 -> Expression schema relations grouping params ty

200200 parameter ty = UnsafeExpression $ parenthesized $

201201 "$" <> renderNat (Proxy @n) <+> "::"

@@ -211,9 +211,9 @@ instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) schema params ty)

211211-- >>> printSQL expr

212212-- ($1 :: int4)

213213param

214− :: forall n schema params relations grouping ty

215− . (PGTyped schema (PGTypeOf ty), HasParameter n schema params ty)

216− => Expression schema relations grouping params ty -- ^ param

214+ :: forall n schema params relations grouping nullity ty

215+ . (PGTyped schema ty, HasParameter n schema params (nullity ty))

216+ => Expression schema relations grouping params (nullity ty) -- ^ param

217217param = parameter @n pgtype

218218

219219instance (HasUnique relation relations columns, Has column columns ty)

@@ -400,16 +400,16 @@ instance (KnownSymbol label, label `In` labels) => IsPGlabel label

400400-- >>> printSQL i

401401-- ROW(0, 1)

402402row

403− :: SListI (Nulls fields)

404− => NP (Aliased (Expression schema relations grouping params)) (Nulls fields)

403+ :: SListI fields

404+ => NP (Aliased (Expression schema relations grouping params)) fields

405405 -- ^ zero or more expressions for the row field values

406406 -> Expression schema relations grouping params (nullity ('PGcomposite fields))

407407row exprs = UnsafeExpression $ "ROW" <> parenthesized

408408 (renderCommaSeparated (\ (expr `As` _) -> renderExpression expr) exprs)

409409

410410instance Has field fields ty => IsLabel field

411− ( Expression schema relation grouping params (nullity ('PGcomposite fields))

412− -> Expression schema relation grouping params ('Null ty) ) where

411+ ( Expression schema relation grouping params ('NotNull ('PGcomposite fields))

412+ -> Expression schema relation grouping params ty ) where

413413 fromLabel expr = UnsafeExpression $

414414 parenthesized (renderExpression expr) <> "." <>

415415 fromString (symbolVal (Proxy @field))

@@ -1117,96 +1117,96 @@ type expressions

11171117-----------------------------------------}

11181118

11191119-- | `TypeExpression`s are used in `cast`s and `createTable` commands.

1120−newtype TypeExpression (schema :: SchemaType) (ty :: PGType)

1120+newtype TypeExpression (schema :: SchemaType) (ty :: NullityType)

11211121 = UnsafeTypeExpression { renderTypeExpression :: ByteString }

11221122 deriving (GHC.Generic,Show,Eq,Ord,NFData)

11231123

11241124instance (Has alias schema ('Typedef ty))

1125− => IsLabel alias (TypeExpression schema ty) where

1125+ => IsLabel alias (TypeExpression schema (nullity ty)) where

11261126 fromLabel = UnsafeTypeExpression (renderAlias (fromLabel @alias))

11271127

11281128-- | logical Boolean (true/false)

1129−bool :: TypeExpression schema 'PGbool

1129+bool :: TypeExpression schema (nullity 'PGbool)

11301130bool = UnsafeTypeExpression "bool"

11311131-- | signed two-byte integer

1132−int2, smallint :: TypeExpression schema 'PGint2

1132+int2, smallint :: TypeExpression schema (nullity 'PGint2)

11331133int2 = UnsafeTypeExpression "int2"

11341134smallint = UnsafeTypeExpression "smallint"

11351135-- | signed four-byte integer

1136−int4, int, integer :: TypeExpression schema 'PGint4

1136+int4, int, integer :: TypeExpression schema (nullity 'PGint4)

11371137int4 = UnsafeTypeExpression "int4"

11381138int = UnsafeTypeExpression "int"

11391139integer = UnsafeTypeExpression "integer"

11401140-- | signed eight-byte integer

1141−int8, bigint :: TypeExpression schema 'PGint8

1141+int8, bigint :: TypeExpression schema (nullity 'PGint8)

11421142int8 = UnsafeTypeExpression "int8"

11431143bigint = UnsafeTypeExpression "bigint"

11441144-- | arbitrary precision numeric type

1145−numeric :: TypeExpression schema 'PGnumeric

1145+numeric :: TypeExpression schema (nullity 'PGnumeric)

11461146numeric = UnsafeTypeExpression "numeric"

11471147-- | single precision floating-point number (4 bytes)

1148−float4, real :: TypeExpression schema 'PGfloat4

1148+float4, real :: TypeExpression schema (nullity 'PGfloat4)

11491149float4 = UnsafeTypeExpression "float4"

11501150real = UnsafeTypeExpression "real"

11511151-- | double precision floating-point number (8 bytes)

1152−float8, doublePrecision :: TypeExpression schema 'PGfloat8

1152+float8, doublePrecision :: TypeExpression schema (nullity 'PGfloat8)

11531153float8 = UnsafeTypeExpression "float8"

11541154doublePrecision = UnsafeTypeExpression "double precision"

11551155-- | variable-length character string

1156−text :: TypeExpression schema 'PGtext

1156+text :: TypeExpression schema (nullity 'PGtext)

11571157text = UnsafeTypeExpression "text"

11581158-- | fixed-length character string

11591159char, character

11601160 :: (KnownNat n, 1 <= n)

11611161 => proxy n

1162− -> TypeExpression schema ('PGchar n)

1162+ -> TypeExpression schema (nullity ('PGchar n))

11631163char p = UnsafeTypeExpression $ "char(" <> renderNat p <> ")"

11641164character p = UnsafeTypeExpression $ "character(" <> renderNat p <> ")"

11651165-- | variable-length character string

11661166varchar, characterVarying

11671167 :: (KnownNat n, 1 <= n)

11681168 => proxy n

1169− -> TypeExpression schema ('PGvarchar n)

1169+ -> TypeExpression schema (nullity ('PGvarchar n))

11701170varchar p = UnsafeTypeExpression $ "varchar(" <> renderNat p <> ")"

11711171characterVarying p = UnsafeTypeExpression $

11721172 "character varying(" <> renderNat p <> ")"

11731173-- | binary data ("byte array")

1174−bytea :: TypeExpression schema 'PGbytea

1174+bytea :: TypeExpression schema (nullity 'PGbytea)

11751175bytea = UnsafeTypeExpression "bytea"

11761176-- | date and time (no time zone)

1177−timestamp :: TypeExpression schema 'PGtimestamp

1177+timestamp :: TypeExpression schema (nullity 'PGtimestamp)

11781178timestamp = UnsafeTypeExpression "timestamp"

11791179-- | date and time, including time zone

1180−timestampWithTimeZone :: TypeExpression schema 'PGtimestamptz

1180+timestampWithTimeZone :: TypeExpression schema (nullity 'PGtimestamptz)

11811181timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"

11821182-- | calendar date (year, month, day)

1183−date :: TypeExpression schema 'PGdate

1183+date :: TypeExpression schema (nullity 'PGdate)

11841184date = UnsafeTypeExpression "date"

11851185-- | time of day (no time zone)

1186−time :: TypeExpression schema 'PGtime

1186+time :: TypeExpression schema (nullity 'PGtime)

11871187time = UnsafeTypeExpression "time"

11881188-- | time of day, including time zone

1189−timeWithTimeZone :: TypeExpression schema 'PGtimetz

1189+timeWithTimeZone :: TypeExpression schema (nullity 'PGtimetz)

11901190timeWithTimeZone = UnsafeTypeExpression "time with time zone"

11911191-- | time span

1192−interval :: TypeExpression schema 'PGinterval

1192+interval :: TypeExpression schema (nullity 'PGinterval)

11931193interval = UnsafeTypeExpression "interval"

11941194-- | universally unique identifier

1195−uuid :: TypeExpression schema 'PGuuid

1195+uuid :: TypeExpression schema (nullity 'PGuuid)

11961196uuid = UnsafeTypeExpression "uuid"

11971197-- | IPv4 or IPv6 host address

1198−inet :: TypeExpression schema 'PGinet

1198+inet :: TypeExpression schema (nullity 'PGinet)

11991199inet = UnsafeTypeExpression "inet"

12001200-- | textual JSON data

1201−json :: TypeExpression schema 'PGjson

1201+json :: TypeExpression schema (nullity 'PGjson)

12021202json = UnsafeTypeExpression "json"

12031203-- | binary JSON data, decomposed

1204−jsonb :: TypeExpression schema 'PGjsonb

1204+jsonb :: TypeExpression schema (nullity 'PGjsonb)

12051205jsonb = UnsafeTypeExpression "jsonb"

12061206-- | variable length array

12071207vararray

12081208 :: TypeExpression schema pg

1209− -> TypeExpression schema ('PGvararray (nullity pg))

1209+ -> TypeExpression schema (nullity ('PGvararray pg))

12101210vararray ty = UnsafeTypeExpression $ renderTypeExpression ty <> "[]"

12111211-- | fixed length array

12121212--

@@ -1215,12 +1215,12 @@ vararray ty = UnsafeTypeExpression $ renderTypeExpression ty <> "[]"

12151215fixarray

12161216 :: forall n schema nullity pg. KnownNat n

12171217 => TypeExpression schema pg

1218− -> TypeExpression schema ('PGfixarray n (nullity pg))

1218+ -> TypeExpression schema (nullity ('PGfixarray n pg))

12191219fixarray ty = UnsafeTypeExpression $

12201220 renderTypeExpression ty <> "[" <> renderNat (Proxy @n) <> "]"

12211221

12221222-- | `pgtype` is a demoted version of a `PGType`

1223−class PGTyped schema (ty :: PGType) where pgtype :: TypeExpression schema ty

1223+class PGTyped schema (ty :: PGType) where pgtype :: TypeExpression schema (nullity ty)

12241224instance PGTyped schema 'PGbool where pgtype = bool

12251225instance PGTyped schema 'PGint2 where pgtype = int2

12261226instance PGTyped schema 'PGint4 where pgtype = int4

squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+18−96

@@ -63,7 +63,6 @@ module Squeal.PostgreSQL.Schema

6363 , Aliasable (as)

6464 , renderAliasedAs

6565 , AliasesOf

66− , ZipAliased (..)

6766 , Has

6867 , HasUnique

6968 , HasAll

@@ -107,17 +106,12 @@ module Squeal.PostgreSQL.Schema

107106 , EnumFrom

108107 , LabelsFrom

109108 , CompositeFrom

110− , FieldNamesFrom

111− , FieldTypesFrom

109+ , PGFieldsFrom

110+ , PGFieldsOf

111+ , PGFieldOf

112112 , ConstructorsOf

113113 , ConstructorNameOf

114114 , ConstructorNamesOf

115− , FieldsOf

116− , FieldNameOf

117− , FieldNamesOf

118− , FieldTypeOf

119− , FieldTypesOf

120− , RecordCodeOf

121115 , MapMaybes (..)

122116 , Nulls

123117 ) where

@@ -136,6 +130,7 @@ import Data.Word (Word16, Word32, Word64)

136130import Data.Type.Bool

137131import Data.UUID.Types (UUID)

138132import Generics.SOP

133+import Generics.SOP.Record

139134import GHC.OverloadedLabels

140135import GHC.TypeLits

141136import Network.IP.Addr

@@ -177,7 +172,7 @@ data PGType

177172 | PGvararray NullityType -- ^ variable length array

178173 | PGfixarray Nat NullityType -- ^ fixed length array

179174 | PGenum [Symbol] -- ^ enumerated (enum) types are data types that comprise a static, ordered set of values.

180− | PGcomposite [(Symbol, PGType)] -- ^ a composite type represents the structure of a row or record; it is essentially just a list of field names and their data types.

175+ | PGcomposite [(Symbol, NullityType)] -- ^ a composite type represents the structure of a row or record; it is essentially just a list of field names and their data types.

181176 | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types

182177

183178-- | The object identifier of a `PGType`.

@@ -432,36 +427,6 @@ type family AliasesOf aliaseds where

432427 AliasesOf '[] = '[]

433428 AliasesOf (alias ::: ty ': tys) = alias ': AliasesOf tys

434429

435−-- | The `ZipAliased` class provides a type family for zipping

436−-- `Symbol` lists together with arbitrary lists of the same size,

437−-- with an associated type family `ZipAs`, together with

438−-- a method `zipAs` for zipping heterogeneous lists of `Alias`es

439−-- together with a heterogeneous list of expressions into

440−-- a heterogeneous list of `Aliased` expressions.

441−class

442− ( SListI (ZipAs ns xs)

443− , All KnownSymbol ns

444− ) => ZipAliased ns xs where

445−

446− type family ZipAs

447− (ns :: [Symbol]) (xs :: [k]) = (zs :: [(Symbol,k)]) | zs -> ns xs

448−

449− zipAs

450− :: NP Alias ns

451− -> NP expr xs

452− -> NP (Aliased expr) (ZipAs ns xs)

453−

454−instance ZipAliased '[] '[] where

455− type ZipAs '[] '[] = '[]

456− zipAs Nil Nil = Nil

457−

458−instance

459− ( KnownSymbol n

460− , ZipAliased ns xs

461− ) => ZipAliased (n ': ns) (x ': xs) where

462− type ZipAs (n ': ns) (x ': xs) = '(n,x) ': ZipAs ns xs

463− zipAs (n :* ns) (x :* xs) = x `As` n :* zipAs ns xs

464−

465430-- | @HasUnique alias fields field@ is a constraint that proves that

466431-- @fields@ is a singleton of @alias ::: field@.

467432type HasUnique alias fields field = fields ~ '[alias ::: field]

@@ -772,26 +737,21 @@ type family LabelsFrom (hask :: Type) :: [Type.ConstructorName] where

772737-- CompositeFrom Row :: PGType

773738-- = 'PGcomposite '['("a", 'PGint2), '("b", 'PGtimestamp)]

774739type family CompositeFrom (hask :: Type) :: PGType where

775− CompositeFrom hask =

776− 'PGcomposite (ZipAs (FieldNamesFrom hask) (FieldTypesFrom hask))

740+ CompositeFrom hask = 'PGcomposite (PGFieldsFrom hask)

777741

778−-- | >>> data Row = Row { a :: Maybe Int16, b :: Maybe LocalTime } deriving GHC.Generic

779−-- >>> instance Generic Row

780−-- >>> instance HasDatatypeInfo Row

781−-- >>> :kind! FieldNamesFrom Row

782−-- FieldNamesFrom Row :: [Type.FieldName]

783−-- = '["a", "b"]

784−type family FieldNamesFrom (hask :: Type) :: [Type.FieldName] where

785− FieldNamesFrom hask = FieldNamesOf (FieldsOf (DatatypeInfoOf hask))

742+type family PGFieldsFrom (hask :: Type) :: RelationType where

743+ PGFieldsFrom hask = PGFieldsOf (RecordCodeOf hask)

786744

787−-- | >>> data Row = Row { a :: Maybe Int16, b :: Maybe LocalTime } deriving GHC.Generic

788−-- >>> instance Generic Row

789−-- >>> instance HasDatatypeInfo Row

790−-- >>> :kind! FieldTypesFrom Row

791−-- FieldTypesFrom Row :: [PGType]

792−-- = '['PGint2, 'PGtimestamp]

793−type family FieldTypesFrom (hask :: Type) :: [PGType] where

794− FieldTypesFrom hask = FieldTypesOf (RecordCodeOf hask (Code hask))

745+type family PGFieldsOf (fields :: [(Symbol, Type)]) :: RelationType where

746+ PGFieldsOf '[] = '[]

747+ PGFieldsOf (field ': fields) = PGFieldOf field ': PGFieldsOf fields

748+

749+type family PGFieldOf (field :: (Symbol, Type)) :: (Symbol, NullityType) where

750+ PGFieldOf (field ::: hask) = field ::: NullityTypeOf hask

751+

752+type family NullityTypeOf (hask :: Type) :: NullityType where

753+ NullityTypeOf (Maybe hask) = 'Null (PG hask)

754+ NullityTypeOf hask = 'NotNull (PG hask)

795755

796756-- | Calculates constructors of a datatype.

797757type family ConstructorsOf (datatype :: Type.DatatypeInfo)

@@ -819,41 +779,3 @@ type family ConstructorNamesOf (constructors :: [Type.ConstructorInfo])

819779 ConstructorNamesOf '[] = '[]

820780 ConstructorNamesOf (constructor ': constructors) =

821781 ConstructorNameOf constructor ': ConstructorNamesOf constructors

822−

823−-- | Calculate the fields of a datatype.

824−type family FieldsOf (datatype :: Type.DatatypeInfo)

825− :: [Type.FieldInfo] where

826− FieldsOf ('Type.ADT _module _datatype '[ 'Type.Record _name fields]) =

827− fields

828− FieldsOf ('Type.Newtype _module _datatype ('Type.Record _name fields)) =

829− fields

830−

831−-- | Calculate the name of a field.

832−type family FieldNameOf (field :: Type.FieldInfo) :: Type.FieldName where

833− FieldNameOf ('Type.FieldInfo name) = name

834−

835−-- | Calculate the names of fields.

836−type family FieldNamesOf (fields :: [Type.FieldInfo])

837− :: [Type.FieldName] where

838− FieldNamesOf '[] = '[]

839− FieldNamesOf (field ': fields) = FieldNameOf field ': FieldNamesOf fields

840−

841−-- | >>> :kind! FieldTypeOf (Maybe Int16)

842−-- FieldTypeOf (Maybe Int16) :: PGType

843−-- = 'PGint2

844−type family FieldTypeOf (maybe :: Type) where

845− FieldTypeOf (Maybe hask) = PG hask

846− FieldTypeOf ty = TypeError

847− ('Text "FieldTypeOf error: non-Maybe type " ':<>: 'ShowType ty)

848−

849−-- | Calculate the types of fields.

850−type family FieldTypesOf (fields :: [Type]) where

851− FieldTypesOf '[] = '[]

852− FieldTypesOf (field ': fields) = FieldTypeOf field ': FieldTypesOf fields

853−

854−-- | Inspect the code of an algebraic datatype and ensure it's a product,

855−-- otherwise generate a type error

856−type family RecordCodeOf (hask :: Type) (code ::[[Type]]) :: [Type] where

857− RecordCodeOf _hask '[tys] = tys

858− RecordCodeOf hask _tys = TypeError

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

stack.yaml+2

@@ -1,3 +1,5 @@

11resolver: lts-11.15

22packages:

33- squeal-postgresql

4+extra-deps:

5+- records-sop-0.1.0.0