git.iko.soy/squeal
on dev help sign in
embed Haskell types in PGType
7555538Eitan Chatav
squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+30−12
compare with dev
unifiedsplit
@@ -23,6 +23,7 @@ Squeal data definition language.
23 , TypeApplications
23 , TypeApplications
24 , TypeInType
24 , TypeInType
25 , TypeOperators
25 , TypeOperators
26+ , UndecidableSuperClasses
26#-}
27#-}
27
28
28module Squeal.PostgreSQL.Definition
29module Squeal.PostgreSQL.Definition
@@ -66,7 +67,7 @@ module Squeal.PostgreSQL.Definition
66 -- * Types
67 -- * Types
67 , createType
68 , createType
68 , createTypeEnum
69 , createTypeEnum
69− , createTypeEnumFromHaskell
70+ , createTypeEnumWith
70 , dropType
71 , dropType
71 , ColumnTypeExpression (..)
72 , ColumnTypeExpression (..)
72 , hasNull
73 , hasNull
@@ -790,17 +791,27 @@ createTypeEnum enum labels = UnsafeDefinition $
790 "CREATE" <+> "TYPE" <+> renderAlias enum <+> "AS" <+>
791 "CREATE" <+> "TYPE" <+> renderAlias enum <+> "AS" <+>
791 parenthesized (commaSeparated (renderLabels labels)) <> ";"
792 parenthesized (commaSeparated (renderLabels labels)) <> ";"
792
793
793−createTypeEnumFromHaskell
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
794− :: forall enum labels hask proxy schema
805+-- :: forall enum labels hask proxy schema
795− . ( KnownSymbol enum
806+-- . ( KnownSymbol enum
796− , SOP.All KnownSymbol labels
807+-- , SOP.All KnownSymbol labels
797− , SOP.IsEnumType hask
808+-- , SOP.IsEnumType hask
798− , labels ~ DatatypeLabels (SOP.DatatypeInfoOf hask) )
809+-- , labels ~ DatatypeLabels (SOP.DatatypeInfoOf hask) )
799− => Alias enum
810+-- => Alias enum
800− -> proxy hask
811+-- -> proxy hask
801− -> Definition schema (Create enum ('Typedef ('PGenum labels)) schema)
812+-- -> Definition schema (Create enum ('Typedef ('PGenum labels)) schema)
802−createTypeEnumFromHaskell enum _ = createTypeEnum enum
813+-- createTypeEnumWith enum _ = createTypeEnum enum
803− (SOP.hpure label :: NP PGlabel labels)
814+-- (SOP.hpure label :: NP PGlabel labels)
804
815
805createType
816createType
806 :: (KnownSymbol comp, SOP.SListI fields)
817 :: (KnownSymbol comp, SOP.SListI fields)
@@ -811,6 +822,13 @@ createType comp fields = UnsafeDefinition $
811 "CREATE" <+> "TYPE" <+> renderAlias comp <+> "AS" <+> parenthesized
822 "CREATE" <+> "TYPE" <+> renderAlias comp <+> "AS" <+> parenthesized
812 (renderCommaSeparated (renderAliasedAs renderTypeExpression) fields) <> ";"
823 (renderCommaSeparated (renderAliasedAs renderTypeExpression) fields) <> ";"
813
824
825+-- class HasPGcomposite hask where
826+-- createTypeCompositeWith
827+-- :: Alias composite
828+-- -> Definition schema
829+-- (Create composite ('Typedef ('PGcompositeWith hask)) schema)
830+-- createTypeCompositeWith
831+
814dropType
832dropType
815 :: Has tydef schema ('Typedef ty)
833 :: Has tydef schema ('Typedef ty)
816 => Alias tydef
834 => Alias tydef
squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+98−1
@@ -105,17 +105,38 @@ module Squeal.PostgreSQL.Schema
105 , SchemumType (..)
105 , SchemumType (..)
106 , SchemaType
106 , SchemaType
107 , With
107 , 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
108 ) where
122 ) where
109
123
110import Control.DeepSeq
124import Control.DeepSeq
111−import Data.ByteString
125+import Data.Aeson (Value)
126+import Data.ByteString (ByteString)
127+import Data.Int
112import Data.Kind
128import Data.Kind
113import Data.Monoid hiding (All)
129import Data.Monoid hiding (All)
130+import Data.Scientific
114import Data.String
131import Data.String
132+import Data.Text (Text)
133+import Data.Time
115import Data.Word
134import Data.Word
116import Data.Type.Bool
135import Data.Type.Bool
136+import Data.UUID.Types (UUID)
117import GHC.OverloadedLabels
137import GHC.OverloadedLabels
118import GHC.TypeLits
138import GHC.TypeLits
139+import Network.IP.Addr
119
140
120import qualified GHC.Generics as GHC
141import qualified GHC.Generics as GHC
121import qualified Generics.SOP as SOP
142import qualified Generics.SOP as SOP
@@ -653,3 +674,79 @@ type family LabelsOf (conss :: [Type.ConstructorInfo]) :: [Symbol] where
653
674
654type family DatatypeLabels (info :: Type.DatatypeInfo) :: [Symbol] where
675type family DatatypeLabels (info :: Type.DatatypeInfo) :: [Symbol] where
655 DatatypeLabels ('Type.ADT _module _datatype constructors) = LabelsOf constructors
676 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