7555538 · squeal · git.iko.soy

git.iko.soy/squeal

embed Haskell types in PGType

commit75555381d892489d86f477f15856e57d4f080b13 authorEitan Chatav <eitan.chatav@gmail.com> dateFri 1 Jun 2018, 14:10 (8 years ago) parent6d0dd7e

2 files changed+128−13

compare with dev

unifiedsplit

squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+30−12 squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+98−1

squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+30−12

@@ -23,6 +23,7 @@ Squeal data definition language.

2323 , TypeApplications

2424 , TypeInType

2525 , TypeOperators

26+ , UndecidableSuperClasses

2627#-}

2728

2829module Squeal.PostgreSQL.Definition

@@ -66,7 +67,7 @@ module Squeal.PostgreSQL.Definition

6667 -- * Types

6768 , createType

6869 , createTypeEnum

69− , createTypeEnumFromHaskell

70+ , createTypeEnumWith

7071 , dropType

7172 , ColumnTypeExpression (..)

7273 , hasNull

@@ -790,17 +791,27 @@ createTypeEnum enum labels = UnsafeDefinition $

790791 "CREATE" <+> "TYPE" <+> renderAlias enum <+> "AS" <+>

791792 parenthesized (commaSeparated (renderLabels labels)) <> ";"

792793

793−createTypeEnumFromHaskell

794− :: forall enum labels hask proxy schema

795− . ( KnownSymbol enum

796− , SOP.All KnownSymbol labels

797− , SOP.IsEnumType hask

798− , labels ~ DatatypeLabels (SOP.DatatypeInfoOf hask) )

799− => Alias enum

800− -> proxy hask

801− -> Definition schema (Create enum ('Typedef ('PGenum labels)) schema)

802−createTypeEnumFromHaskell enum _ = createTypeEnum enum

803− (SOP.hpure label :: NP PGlabel labels)

794+class

795+ ( SOP.IsEnumType hask

796+ , PGenumWith hask ~ 'PGenum labels

797+ ) => HasPGenum hask where

798+ createTypeEnumWith

799+ :: KnownSymbol enum

800+ => Alias enum

801+ -> Definition schema (Create enum ('Typedef (PGenumWith hask)) schema)

802+ createTypeEnumWith enum = createTypeEnum enum

803+ (SOP.hpure label :: NP PGlabel labels)

804+-- createTypeEnumWith

805+-- :: forall enum labels hask proxy schema

806+-- . ( KnownSymbol enum

807+-- , SOP.All KnownSymbol labels

808+-- , SOP.IsEnumType hask

809+-- , labels ~ DatatypeLabels (SOP.DatatypeInfoOf hask) )

810+-- => Alias enum

811+-- -> proxy hask

812+-- -> Definition schema (Create enum ('Typedef ('PGenum labels)) schema)

813+-- createTypeEnumWith enum _ = createTypeEnum enum

814+-- (SOP.hpure label :: NP PGlabel labels)

804815

805816createType

806817 :: (KnownSymbol comp, SOP.SListI fields)

@@ -811,6 +822,13 @@ createType comp fields = UnsafeDefinition $

811822 "CREATE" <+> "TYPE" <+> renderAlias comp <+> "AS" <+> parenthesized

812823 (renderCommaSeparated (renderAliasedAs renderTypeExpression) fields) <> ";"

813824

825+-- class HasPGcomposite hask where

826+-- createTypeCompositeWith

827+-- :: Alias composite

828+-- -> Definition schema

829+-- (Create composite ('Typedef ('PGcompositeWith hask)) schema)

830+-- createTypeCompositeWith

831+

814832dropType

815833 :: Has tydef schema ('Typedef ty)

816834 => Alias tydef

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

@@ -105,17 +105,38 @@ module Squeal.PostgreSQL.Schema

105105 , SchemumType (..)

106106 , SchemaType

107107 , With

108+ -- * STUFF

109+ , PG

110+ , PGenumWith

111+ , PGcompositeWith

112+ , ConstructorsOf

113+ , ConstructorNameOf

114+ , ConstructorNamesOf

115+ , FieldsOf

116+ , FieldNameOf

117+ , FieldNamesOf

118+ , FieldTypeOf

119+ , FieldTypesOf

120+ , RecordFieldTypesOf

121+ , Zip

108122 ) where

109123

110124import Control.DeepSeq

111−import Data.ByteString

125+import Data.Aeson (Value)

126+import Data.ByteString (ByteString)

127+import Data.Int

112128import Data.Kind

113129import Data.Monoid hiding (All)

130+import Data.Scientific

114131import Data.String

132+import Data.Text (Text)

133+import Data.Time

115134import Data.Word

116135import Data.Type.Bool

136+import Data.UUID.Types (UUID)

117137import GHC.OverloadedLabels

118138import GHC.TypeLits

139+import Network.IP.Addr

119140

120141import qualified GHC.Generics as GHC

121142import qualified Generics.SOP as SOP

@@ -653,3 +674,79 @@ type family LabelsOf (conss :: [Type.ConstructorInfo]) :: [Symbol] where

653674

654675type family DatatypeLabels (info :: Type.DatatypeInfo) :: [Symbol] where

655676 DatatypeLabels ('Type.ADT _module _datatype constructors) = LabelsOf constructors

677+

678+type family PG (hask :: Type) = (pg :: PGType) | pg -> hask where

679+ PG Bool = 'PGbool

680+ PG Int16 = 'PGint2

681+ PG Int32 = 'PGint4

682+ PG Int64 = 'PGint8

683+ PG Scientific = 'PGnumeric

684+ PG Float = 'PGfloat4

685+ PG Double = 'PGfloat8

686+ PG Text = 'PGtext

687+ PG ByteString = 'PGbytea

688+ PG LocalTime = 'PGtimestamp

689+ PG UTCTime = 'PGtimestamptz

690+ PG Day = 'PGdate

691+ PG TimeOfDay = 'PGtime

692+ PG (TimeOfDay, TimeZone) = 'PGtimetz

693+ PG DiffTime = 'PGinterval

694+ PG UUID = 'PGuuid

695+ PG (NetAddr IP) = 'PGinet

696+ PG Value = 'PGjson

697+

698+type family PGenumWith (hask :: Type) :: PGType where

699+ PGenumWith hask =

700+ 'PGenum (ConstructorNamesOf (ConstructorsOf (SOP.DatatypeInfoOf hask)))

701+

702+type family PGcompositeWith (hask :: Type) :: PGType where

703+ PGcompositeWith hask =

704+ 'PGcomposite (Zip

705+ (FieldNamesOf (FieldsOf (SOP.DatatypeInfoOf hask)))

706+ (RecordFieldTypesOf (SOP.Code hask)))

707+

708+type family ConstructorsOf (datatype :: Type.DatatypeInfo)

709+ :: [Type.ConstructorInfo] where

710+ ConstructorsOf ('Type.ADT _module _datatype constructors) =

711+ constructors

712+ ConstructorsOf ('Type.Newtype _module _datatype constructor) =

713+ '[constructor]

714+

715+type family ConstructorNameOf (constructors :: Type.ConstructorInfo)

716+ :: Type.ConstructorName where

717+ ConstructorNameOf ('Type.Constructor name) = name

718+ ConstructorNameOf ('Type.Infix name _assoc _fix) = name

719+ ConstructorNameOf ('Type.Record name _fields) = name

720+

721+type family ConstructorNamesOf (constructors :: [Type.ConstructorInfo])

722+ :: [Type.ConstructorName] where

723+ ConstructorNamesOf '[] = '[]

724+ ConstructorNamesOf (constructor ': constructors) =

725+ ConstructorNameOf constructor ': ConstructorNamesOf constructors

726+

727+type family FieldsOf (constructor :: Type.DatatypeInfo)

728+ :: [Type.FieldInfo] where

729+ FieldsOf ('Type.ADT _module _datatype '[ 'Type.Record _name fields]) =

730+ fields

731+

732+type family FieldNameOf (field :: Type.FieldInfo) :: Type.FieldName where

733+ FieldNameOf ('Type.FieldInfo name) = name

734+

735+type family FieldNamesOf (fields :: [Type.FieldInfo])

736+ :: [Type.FieldName] where

737+ FieldNamesOf '[] = '[]

738+ FieldNamesOf (field ': fields) = FieldNameOf field ': FieldNamesOf fields

739+

740+type family FieldTypeOf (maybe :: Type) where

741+ FieldTypeOf (Maybe hask) = PG hask

742+

743+type family FieldTypesOf (fields :: [Type]) where

744+ FieldTypesOf '[] = '[]

745+ FieldTypesOf (field ': fields) = FieldTypeOf field ': FieldTypesOf fields

746+

747+type family RecordFieldTypesOf (code :: [[Type]]) where

748+ RecordFieldTypesOf '[fields] = FieldTypesOf fields

749+

750+type family Zip xs ys where

751+ Zip '[] '[] = '[]

752+ Zip (x ': xs) (y ': ys) = '(x,y) ': Zip xs ys