mirror of
https://github.com/ilyakooo0/squeal.git
synced 2024-09-17 16:57:22 +03:00
didn't quite make it
This commit is contained in:
Eitan Chatav
parent
739a943cea
commit
7ce2cb7852
@ -51,6 +51,7 @@ library
|
||||
, postgresql-binary >= 0.12.1
|
||||
, postgresql-libpq >= 0.9.4.1
|
||||
, profunctors >= 5.2.2
|
||||
, records-sop >= 0.1.0.0
|
||||
, resource-pool >= 0.2.3.2
|
||||
, scientific >= 0.3.5.3
|
||||
, text >= 1.2.3.0
|
||||
|
||||
@ -171,6 +171,7 @@ import Data.UUID.Types
|
||||
import Data.Vector (Vector)
|
||||
import Data.Word
|
||||
import Generics.SOP
|
||||
import Generics.SOP.Record
|
||||
import GHC.TypeLits
|
||||
import Network.IP.Addr
|
||||
|
||||
@ -262,10 +263,8 @@ instance
|
||||
. from
|
||||
instance
|
||||
( SListI fields
|
||||
, MapMaybes xs
|
||||
, IsProductType x (Maybes xs)
|
||||
, IsRecord x xs
|
||||
, AllZip ToAliasedParam xs fields
|
||||
, FieldNamesFrom x ~ AliasesOf fields
|
||||
, All HasAliasedOid fields
|
||||
) => ToParam x ('PGcomposite fields) where
|
||||
toParam =
|
||||
@ -435,10 +434,8 @@ instance
|
||||
|
||||
instance
|
||||
( SListI fields
|
||||
, MapMaybes ys
|
||||
, IsProductType y (Maybes ys)
|
||||
, IsRecord y ys
|
||||
, AllZip FromAliasedValue fields ys
|
||||
, FieldNamesFrom y ~ AliasesOf fields
|
||||
) => FromValue ('PGcomposite fields) y where
|
||||
fromValue =
|
||||
let
|
||||
@ -529,9 +526,8 @@ class SListI results => FromRow (results :: RelationType) y where
|
||||
fromRow :: NP (K (Maybe Strict.ByteString)) results -> y
|
||||
instance
|
||||
( SListI results
|
||||
, IsProductType y ys
|
||||
, IsRecord y ys
|
||||
, AllZip FromColumnValue results ys
|
||||
, FieldNamesFrom y ~ AliasesOf results
|
||||
) => FromRow results y where
|
||||
fromRow
|
||||
= to . SOP . Z . htrans (Proxy @FromColumnValue) (I . fromColumnValue)
|
||||
|
||||
@ -904,17 +904,22 @@ createTypeComposite ty fields = UnsafeDefinition $
|
||||
-- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
|
||||
createTypeCompositeFrom
|
||||
:: forall hask ty schema.
|
||||
( ZipAliased (FieldNamesFrom hask) (FieldTypesFrom hask)
|
||||
, SOP.All (PGTyped schema) (FieldTypesFrom hask)
|
||||
( SOP.All (BaseTyped schema) (PGFieldsFrom hask)
|
||||
, KnownSymbol ty
|
||||
)
|
||||
=> Alias ty
|
||||
-- ^ name of the user defined composite type
|
||||
-> Definition schema (Create ty ( 'Typedef (CompositeFrom hask)) schema)
|
||||
createTypeCompositeFrom ty = createTypeComposite ty $ zipAs
|
||||
(SOP.hpure Alias :: NP Alias (FieldNamesFrom hask))
|
||||
(SOP.hcpure (SOP.Proxy :: SOP.Proxy (PGTyped schema)) pgtype
|
||||
:: NP (TypeExpression schema) (FieldTypesFrom hask))
|
||||
createTypeCompositeFrom ty = createTypeComposite ty
|
||||
(SOP.hcpure (SOP.Proxy :: SOP.Proxy (BaseTyped schema)) basetype
|
||||
:: NP (Aliased (TypeExpression schema)) (PGFieldsFrom hask))
|
||||
|
||||
|
||||
class BaseTyped (schema :: SchemaType) (ty :: (Symbol,NullityType)) where
|
||||
basetype :: Aliased (TypeExpression schema) ty
|
||||
instance (KnownSymbol alias, PGTyped schema ty)
|
||||
=> BaseTyped schema (alias ::: nullity ty) where
|
||||
basetype = pgtype @schema @ty `As` Alias @alias
|
||||
|
||||
-- | Drop a type.
|
||||
--
|
||||
@ -938,14 +943,14 @@ newtype ColumnTypeExpression (schema :: SchemaType) (ty :: ColumnType)
|
||||
-- | used in `createTable` commands as a column constraint to note that
|
||||
-- @NULL@ may be present in a column
|
||||
nullable
|
||||
:: TypeExpression schema ty
|
||||
:: (forall nullity. TypeExpression schema (nullity ty))
|
||||
-> ColumnTypeExpression schema ('NoDef :=> 'Null ty)
|
||||
nullable ty = UnsafeColumnTypeExpression $ renderTypeExpression ty <+> "NULL"
|
||||
|
||||
-- | used in `createTable` commands as a column constraint to ensure
|
||||
-- @NULL@ is not present in a column
|
||||
notNullable
|
||||
:: TypeExpression schema ty
|
||||
:: (forall nullity. TypeExpression schema (nullity ty))
|
||||
-> ColumnTypeExpression schema (def :=> 'NotNull ty)
|
||||
notNullable ty = UnsafeColumnTypeExpression $ renderTypeExpression ty <+> "NOT NULL"
|
||||
|
||||
|
||||
@ -195,7 +195,7 @@ class KnownNat n => HasParameter
|
||||
-- >>> printSQL expr
|
||||
-- ($1 :: int4)
|
||||
parameter
|
||||
:: TypeExpression schema (PGTypeOf ty)
|
||||
:: TypeExpression schema ty
|
||||
-> Expression schema relations grouping params ty
|
||||
parameter ty = UnsafeExpression $ parenthesized $
|
||||
"$" <> renderNat (Proxy @n) <+> "::"
|
||||
@ -211,9 +211,9 @@ instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) schema params ty)
|
||||
-- >>> printSQL expr
|
||||
-- ($1 :: int4)
|
||||
param
|
||||
:: forall n schema params relations grouping ty
|
||||
. (PGTyped schema (PGTypeOf ty), HasParameter n schema params ty)
|
||||
=> Expression schema relations grouping params ty -- ^ param
|
||||
:: forall n schema params relations grouping nullity ty
|
||||
. (PGTyped schema ty, HasParameter n schema params (nullity ty))
|
||||
=> Expression schema relations grouping params (nullity ty) -- ^ param
|
||||
param = parameter @n pgtype
|
||||
|
||||
instance (HasUnique relation relations columns, Has column columns ty)
|
||||
@ -400,16 +400,16 @@ instance (KnownSymbol label, label `In` labels) => IsPGlabel label
|
||||
-- >>> printSQL i
|
||||
-- ROW(0, 1)
|
||||
row
|
||||
:: SListI (Nulls fields)
|
||||
=> NP (Aliased (Expression schema relations grouping params)) (Nulls fields)
|
||||
:: SListI fields
|
||||
=> NP (Aliased (Expression schema relations grouping params)) fields
|
||||
-- ^ zero or more expressions for the row field values
|
||||
-> Expression schema relations grouping params (nullity ('PGcomposite fields))
|
||||
row exprs = UnsafeExpression $ "ROW" <> parenthesized
|
||||
(renderCommaSeparated (\ (expr `As` _) -> renderExpression expr) exprs)
|
||||
|
||||
instance Has field fields ty => IsLabel field
|
||||
( Expression schema relation grouping params (nullity ('PGcomposite fields))
|
||||
-> Expression schema relation grouping params ('Null ty) ) where
|
||||
( Expression schema relation grouping params ('NotNull ('PGcomposite fields))
|
||||
-> Expression schema relation grouping params ty ) where
|
||||
fromLabel expr = UnsafeExpression $
|
||||
parenthesized (renderExpression expr) <> "." <>
|
||||
fromString (symbolVal (Proxy @field))
|
||||
@ -1117,96 +1117,96 @@ type expressions
|
||||
-----------------------------------------}
|
||||
|
||||
-- | `TypeExpression`s are used in `cast`s and `createTable` commands.
|
||||
newtype TypeExpression (schema :: SchemaType) (ty :: PGType)
|
||||
newtype TypeExpression (schema :: SchemaType) (ty :: NullityType)
|
||||
= UnsafeTypeExpression { renderTypeExpression :: ByteString }
|
||||
deriving (GHC.Generic,Show,Eq,Ord,NFData)
|
||||
|
||||
instance (Has alias schema ('Typedef ty))
|
||||
=> IsLabel alias (TypeExpression schema ty) where
|
||||
=> IsLabel alias (TypeExpression schema (nullity ty)) where
|
||||
fromLabel = UnsafeTypeExpression (renderAlias (fromLabel @alias))
|
||||
|
||||
-- | logical Boolean (true/false)
|
||||
bool :: TypeExpression schema 'PGbool
|
||||
bool :: TypeExpression schema (nullity 'PGbool)
|
||||
bool = UnsafeTypeExpression "bool"
|
||||
-- | signed two-byte integer
|
||||
int2, smallint :: TypeExpression schema 'PGint2
|
||||
int2, smallint :: TypeExpression schema (nullity 'PGint2)
|
||||
int2 = UnsafeTypeExpression "int2"
|
||||
smallint = UnsafeTypeExpression "smallint"
|
||||
-- | signed four-byte integer
|
||||
int4, int, integer :: TypeExpression schema 'PGint4
|
||||
int4, int, integer :: TypeExpression schema (nullity 'PGint4)
|
||||
int4 = UnsafeTypeExpression "int4"
|
||||
int = UnsafeTypeExpression "int"
|
||||
integer = UnsafeTypeExpression "integer"
|
||||
-- | signed eight-byte integer
|
||||
int8, bigint :: TypeExpression schema 'PGint8
|
||||
int8, bigint :: TypeExpression schema (nullity 'PGint8)
|
||||
int8 = UnsafeTypeExpression "int8"
|
||||
bigint = UnsafeTypeExpression "bigint"
|
||||
-- | arbitrary precision numeric type
|
||||
numeric :: TypeExpression schema 'PGnumeric
|
||||
numeric :: TypeExpression schema (nullity 'PGnumeric)
|
||||
numeric = UnsafeTypeExpression "numeric"
|
||||
-- | single precision floating-point number (4 bytes)
|
||||
float4, real :: TypeExpression schema 'PGfloat4
|
||||
float4, real :: TypeExpression schema (nullity 'PGfloat4)
|
||||
float4 = UnsafeTypeExpression "float4"
|
||||
real = UnsafeTypeExpression "real"
|
||||
-- | double precision floating-point number (8 bytes)
|
||||
float8, doublePrecision :: TypeExpression schema 'PGfloat8
|
||||
float8, doublePrecision :: TypeExpression schema (nullity 'PGfloat8)
|
||||
float8 = UnsafeTypeExpression "float8"
|
||||
doublePrecision = UnsafeTypeExpression "double precision"
|
||||
-- | variable-length character string
|
||||
text :: TypeExpression schema 'PGtext
|
||||
text :: TypeExpression schema (nullity 'PGtext)
|
||||
text = UnsafeTypeExpression "text"
|
||||
-- | fixed-length character string
|
||||
char, character
|
||||
:: (KnownNat n, 1 <= n)
|
||||
=> proxy n
|
||||
-> TypeExpression schema ('PGchar n)
|
||||
-> TypeExpression schema (nullity ('PGchar n))
|
||||
char p = UnsafeTypeExpression $ "char(" <> renderNat p <> ")"
|
||||
character p = UnsafeTypeExpression $ "character(" <> renderNat p <> ")"
|
||||
-- | variable-length character string
|
||||
varchar, characterVarying
|
||||
:: (KnownNat n, 1 <= n)
|
||||
=> proxy n
|
||||
-> TypeExpression schema ('PGvarchar n)
|
||||
-> TypeExpression schema (nullity ('PGvarchar n))
|
||||
varchar p = UnsafeTypeExpression $ "varchar(" <> renderNat p <> ")"
|
||||
characterVarying p = UnsafeTypeExpression $
|
||||
"character varying(" <> renderNat p <> ")"
|
||||
-- | binary data ("byte array")
|
||||
bytea :: TypeExpression schema 'PGbytea
|
||||
bytea :: TypeExpression schema (nullity 'PGbytea)
|
||||
bytea = UnsafeTypeExpression "bytea"
|
||||
-- | date and time (no time zone)
|
||||
timestamp :: TypeExpression schema 'PGtimestamp
|
||||
timestamp :: TypeExpression schema (nullity 'PGtimestamp)
|
||||
timestamp = UnsafeTypeExpression "timestamp"
|
||||
-- | date and time, including time zone
|
||||
timestampWithTimeZone :: TypeExpression schema 'PGtimestamptz
|
||||
timestampWithTimeZone :: TypeExpression schema (nullity 'PGtimestamptz)
|
||||
timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"
|
||||
-- | calendar date (year, month, day)
|
||||
date :: TypeExpression schema 'PGdate
|
||||
date :: TypeExpression schema (nullity 'PGdate)
|
||||
date = UnsafeTypeExpression "date"
|
||||
-- | time of day (no time zone)
|
||||
time :: TypeExpression schema 'PGtime
|
||||
time :: TypeExpression schema (nullity 'PGtime)
|
||||
time = UnsafeTypeExpression "time"
|
||||
-- | time of day, including time zone
|
||||
timeWithTimeZone :: TypeExpression schema 'PGtimetz
|
||||
timeWithTimeZone :: TypeExpression schema (nullity 'PGtimetz)
|
||||
timeWithTimeZone = UnsafeTypeExpression "time with time zone"
|
||||
-- | time span
|
||||
interval :: TypeExpression schema 'PGinterval
|
||||
interval :: TypeExpression schema (nullity 'PGinterval)
|
||||
interval = UnsafeTypeExpression "interval"
|
||||
-- | universally unique identifier
|
||||
uuid :: TypeExpression schema 'PGuuid
|
||||
uuid :: TypeExpression schema (nullity 'PGuuid)
|
||||
uuid = UnsafeTypeExpression "uuid"
|
||||
-- | IPv4 or IPv6 host address
|
||||
inet :: TypeExpression schema 'PGinet
|
||||
inet :: TypeExpression schema (nullity 'PGinet)
|
||||
inet = UnsafeTypeExpression "inet"
|
||||
-- | textual JSON data
|
||||
json :: TypeExpression schema 'PGjson
|
||||
json :: TypeExpression schema (nullity 'PGjson)
|
||||
json = UnsafeTypeExpression "json"
|
||||
-- | binary JSON data, decomposed
|
||||
jsonb :: TypeExpression schema 'PGjsonb
|
||||
jsonb :: TypeExpression schema (nullity 'PGjsonb)
|
||||
jsonb = UnsafeTypeExpression "jsonb"
|
||||
-- | variable length array
|
||||
vararray
|
||||
:: TypeExpression schema pg
|
||||
-> TypeExpression schema ('PGvararray (nullity pg))
|
||||
-> TypeExpression schema (nullity ('PGvararray pg))
|
||||
vararray ty = UnsafeTypeExpression $ renderTypeExpression ty <> "[]"
|
||||
-- | fixed length array
|
||||
--
|
||||
@ -1215,12 +1215,12 @@ vararray ty = UnsafeTypeExpression $ renderTypeExpression ty <> "[]"
|
||||
fixarray
|
||||
:: forall n schema nullity pg. KnownNat n
|
||||
=> TypeExpression schema pg
|
||||
-> TypeExpression schema ('PGfixarray n (nullity pg))
|
||||
-> TypeExpression schema (nullity ('PGfixarray n pg))
|
||||
fixarray ty = UnsafeTypeExpression $
|
||||
renderTypeExpression ty <> "[" <> renderNat (Proxy @n) <> "]"
|
||||
|
||||
-- | `pgtype` is a demoted version of a `PGType`
|
||||
class PGTyped schema (ty :: PGType) where pgtype :: TypeExpression schema ty
|
||||
class PGTyped schema (ty :: PGType) where pgtype :: TypeExpression schema (nullity ty)
|
||||
instance PGTyped schema 'PGbool where pgtype = bool
|
||||
instance PGTyped schema 'PGint2 where pgtype = int2
|
||||
instance PGTyped schema 'PGint4 where pgtype = int4
|
||||
|
||||
@ -63,7 +63,6 @@ module Squeal.PostgreSQL.Schema
|
||||
, Aliasable (as)
|
||||
, renderAliasedAs
|
||||
, AliasesOf
|
||||
, ZipAliased (..)
|
||||
, Has
|
||||
, HasUnique
|
||||
, HasAll
|
||||
@ -107,17 +106,12 @@ module Squeal.PostgreSQL.Schema
|
||||
, EnumFrom
|
||||
, LabelsFrom
|
||||
, CompositeFrom
|
||||
, FieldNamesFrom
|
||||
, FieldTypesFrom
|
||||
, PGFieldsFrom
|
||||
, PGFieldsOf
|
||||
, PGFieldOf
|
||||
, ConstructorsOf
|
||||
, ConstructorNameOf
|
||||
, ConstructorNamesOf
|
||||
, FieldsOf
|
||||
, FieldNameOf
|
||||
, FieldNamesOf
|
||||
, FieldTypeOf
|
||||
, FieldTypesOf
|
||||
, RecordCodeOf
|
||||
, MapMaybes (..)
|
||||
, Nulls
|
||||
) where
|
||||
@ -136,6 +130,7 @@ import Data.Word (Word16, Word32, Word64)
|
||||
import Data.Type.Bool
|
||||
import Data.UUID.Types (UUID)
|
||||
import Generics.SOP
|
||||
import Generics.SOP.Record
|
||||
import GHC.OverloadedLabels
|
||||
import GHC.TypeLits
|
||||
import Network.IP.Addr
|
||||
@ -177,7 +172,7 @@ data PGType
|
||||
| PGvararray NullityType -- ^ variable length array
|
||||
| PGfixarray Nat NullityType -- ^ fixed length array
|
||||
| PGenum [Symbol] -- ^ enumerated (enum) types are data types that comprise a static, ordered set of values.
|
||||
| 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.
|
||||
| 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.
|
||||
| UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types
|
||||
|
||||
-- | The object identifier of a `PGType`.
|
||||
@ -432,36 +427,6 @@ type family AliasesOf aliaseds where
|
||||
AliasesOf '[] = '[]
|
||||
AliasesOf (alias ::: ty ': tys) = alias ': AliasesOf tys
|
||||
|
||||
-- | The `ZipAliased` class provides a type family for zipping
|
||||
-- `Symbol` lists together with arbitrary lists of the same size,
|
||||
-- with an associated type family `ZipAs`, together with
|
||||
-- a method `zipAs` for zipping heterogeneous lists of `Alias`es
|
||||
-- together with a heterogeneous list of expressions into
|
||||
-- a heterogeneous list of `Aliased` expressions.
|
||||
class
|
||||
( SListI (ZipAs ns xs)
|
||||
, All KnownSymbol ns
|
||||
) => ZipAliased ns xs where
|
||||
|
||||
type family ZipAs
|
||||
(ns :: [Symbol]) (xs :: [k]) = (zs :: [(Symbol,k)]) | zs -> ns xs
|
||||
|
||||
zipAs
|
||||
:: NP Alias ns
|
||||
-> NP expr xs
|
||||
-> NP (Aliased expr) (ZipAs ns xs)
|
||||
|
||||
instance ZipAliased '[] '[] where
|
||||
type ZipAs '[] '[] = '[]
|
||||
zipAs Nil Nil = Nil
|
||||
|
||||
instance
|
||||
( KnownSymbol n
|
||||
, ZipAliased ns xs
|
||||
) => ZipAliased (n ': ns) (x ': xs) where
|
||||
type ZipAs (n ': ns) (x ': xs) = '(n,x) ': ZipAs ns xs
|
||||
zipAs (n :* ns) (x :* xs) = x `As` n :* zipAs ns xs
|
||||
|
||||
-- | @HasUnique alias fields field@ is a constraint that proves that
|
||||
-- @fields@ is a singleton of @alias ::: field@.
|
||||
type HasUnique alias fields field = fields ~ '[alias ::: field]
|
||||
@ -772,26 +737,21 @@ type family LabelsFrom (hask :: Type) :: [Type.ConstructorName] where
|
||||
-- CompositeFrom Row :: PGType
|
||||
-- = 'PGcomposite '['("a", 'PGint2), '("b", 'PGtimestamp)]
|
||||
type family CompositeFrom (hask :: Type) :: PGType where
|
||||
CompositeFrom hask =
|
||||
'PGcomposite (ZipAs (FieldNamesFrom hask) (FieldTypesFrom hask))
|
||||
CompositeFrom hask = 'PGcomposite (PGFieldsFrom hask)
|
||||
|
||||
-- | >>> data Row = Row { a :: Maybe Int16, b :: Maybe LocalTime } deriving GHC.Generic
|
||||
-- >>> instance Generic Row
|
||||
-- >>> instance HasDatatypeInfo Row
|
||||
-- >>> :kind! FieldNamesFrom Row
|
||||
-- FieldNamesFrom Row :: [Type.FieldName]
|
||||
-- = '["a", "b"]
|
||||
type family FieldNamesFrom (hask :: Type) :: [Type.FieldName] where
|
||||
FieldNamesFrom hask = FieldNamesOf (FieldsOf (DatatypeInfoOf hask))
|
||||
type family PGFieldsFrom (hask :: Type) :: RelationType where
|
||||
PGFieldsFrom hask = PGFieldsOf (RecordCodeOf hask)
|
||||
|
||||
-- | >>> data Row = Row { a :: Maybe Int16, b :: Maybe LocalTime } deriving GHC.Generic
|
||||
-- >>> instance Generic Row
|
||||
-- >>> instance HasDatatypeInfo Row
|
||||
-- >>> :kind! FieldTypesFrom Row
|
||||
-- FieldTypesFrom Row :: [PGType]
|
||||
-- = '['PGint2, 'PGtimestamp]
|
||||
type family FieldTypesFrom (hask :: Type) :: [PGType] where
|
||||
FieldTypesFrom hask = FieldTypesOf (RecordCodeOf hask (Code hask))
|
||||
type family PGFieldsOf (fields :: [(Symbol, Type)]) :: RelationType where
|
||||
PGFieldsOf '[] = '[]
|
||||
PGFieldsOf (field ': fields) = PGFieldOf field ': PGFieldsOf fields
|
||||
|
||||
type family PGFieldOf (field :: (Symbol, Type)) :: (Symbol, NullityType) where
|
||||
PGFieldOf (field ::: hask) = field ::: NullityTypeOf hask
|
||||
|
||||
type family NullityTypeOf (hask :: Type) :: NullityType where
|
||||
NullityTypeOf (Maybe hask) = 'Null (PG hask)
|
||||
NullityTypeOf hask = 'NotNull (PG hask)
|
||||
|
||||
-- | Calculates constructors of a datatype.
|
||||
type family ConstructorsOf (datatype :: Type.DatatypeInfo)
|
||||
@ -819,41 +779,3 @@ type family ConstructorNamesOf (constructors :: [Type.ConstructorInfo])
|
||||
ConstructorNamesOf '[] = '[]
|
||||
ConstructorNamesOf (constructor ': constructors) =
|
||||
ConstructorNameOf constructor ': ConstructorNamesOf constructors
|
||||
|
||||
-- | Calculate the fields of a datatype.
|
||||
type family FieldsOf (datatype :: Type.DatatypeInfo)
|
||||
:: [Type.FieldInfo] where
|
||||
FieldsOf ('Type.ADT _module _datatype '[ 'Type.Record _name fields]) =
|
||||
fields
|
||||
FieldsOf ('Type.Newtype _module _datatype ('Type.Record _name fields)) =
|
||||
fields
|
||||
|
||||
-- | Calculate the name of a field.
|
||||
type family FieldNameOf (field :: Type.FieldInfo) :: Type.FieldName where
|
||||
FieldNameOf ('Type.FieldInfo name) = name
|
||||
|
||||
-- | Calculate the names of fields.
|
||||
type family FieldNamesOf (fields :: [Type.FieldInfo])
|
||||
:: [Type.FieldName] where
|
||||
FieldNamesOf '[] = '[]
|
||||
FieldNamesOf (field ': fields) = FieldNameOf field ': FieldNamesOf fields
|
||||
|
||||
-- | >>> :kind! FieldTypeOf (Maybe Int16)
|
||||
-- FieldTypeOf (Maybe Int16) :: PGType
|
||||
-- = 'PGint2
|
||||
type family FieldTypeOf (maybe :: Type) where
|
||||
FieldTypeOf (Maybe hask) = PG hask
|
||||
FieldTypeOf ty = TypeError
|
||||
('Text "FieldTypeOf error: non-Maybe type " ':<>: 'ShowType ty)
|
||||
|
||||
-- | Calculate the types of fields.
|
||||
type family FieldTypesOf (fields :: [Type]) where
|
||||
FieldTypesOf '[] = '[]
|
||||
FieldTypesOf (field ': fields) = FieldTypeOf field ': FieldTypesOf fields
|
||||
|
||||
-- | Inspect the code of an algebraic datatype and ensure it's a product,
|
||||
-- otherwise generate a type error
|
||||
type family RecordCodeOf (hask :: Type) (code ::[[Type]]) :: [Type] where
|
||||
RecordCodeOf _hask '[tys] = tys
|
||||
RecordCodeOf hask _tys = TypeError
|
||||
('Text "RecordCodeOf error: non-Record type " ':<>: 'ShowType hask)
|
||||
|
||||
@ -1,3 +1,5 @@
|
||||
resolver: lts-11.15
|
||||
packages:
|
||||
- squeal-postgresql
|
||||
extra-deps:
|
||||
- records-sop-0.1.0.0
|
||||
|
||||
Loading…
Reference in New Issue
Block a user