@@ -1,8 +1,3 @@
1−{-# LANGUAGE
2− TypeFamilies
3− , UndecidableSuperClasses
4−#-}
5−
61{-|
72Module: Squeal.PostgreSQL.Binary
83Description: Binary encoding and decoding
@@ -199,13 +194,22 @@ True
199194 , MultiParamTypeClasses
200195 , ScopedTypeVariables
201196 , TypeApplications
197+ , TypeFamilies
202198 , TypeInType
203199 , TypeOperators
204200 , UndecidableInstances
201+ , UndecidableSuperClasses
205202#-}
206203
207204module Squeal.PostgreSQL.Binary
208− ( Json (..)
205+ ( -- * PG type families
206+ PG
207+ , NullPG
208+ , TuplePG
209+ , RowPG
210+ , LabelsPG
211+ -- * Storage newtypes
212+ , Json (..)
209213 , Jsonb (..)
210214 , Composite (..)
211215 , Enumerated (..)
@@ -226,9 +230,12 @@ import BinaryParser
226230import ByteString.StrictBuilder (builderLength, int32BE, int64BE, word32BE)
227231import Control.Arrow (left)
228232import Control.Monad
233+import Data.Aeson (Value)
234+import Data.ByteString (ByteString)
229235import Data.Int
230236import Data.Kind
231237import Data.Scientific
238+import Data.Text (Text)
232239import Data.Time
233240import Data.UUID.Types
234241import Data.Vector (Vector)
@@ -246,6 +253,7 @@ import qualified Data.Text.Lazy as Lazy (Text)
246253import qualified Data.Text as Strict (Text)
247254import qualified Data.Text as Strict.Text
248255import qualified Data.Vector as Vector
256+import qualified Generics.SOP.Type.Metadata as Type
249257import qualified GHC.Generics as GHC
250258import qualified PostgreSQL.Binary.Decoding as Decoding
251259import qualified PostgreSQL.Binary.Encoding as Encoding
@@ -773,3 +781,149 @@ type family FixPG (hask :: Type) :: NullityType where
773781 FixPG (x,x,x,x,x,x,x,x,x,x) = FixPG x
774782 FixPG (x,x,x,x,x,x,x,x,x,x,x) = FixPG x
775783 FixPG x = NullPG x
784+
785+{- | The `PG` type family embeds a subset of Haskell types
786+as Postgres types. As an open type family, `PG` is extensible.
787+
788+>>> :kind! PG LocalTime
789+PG LocalTime :: PGType
790+= 'PGtimestamp
791+
792+>>> newtype MyDouble = My Double
793+>>> :set -XTypeFamilies
794+>>> type instance PG MyDouble = 'PGfloat8
795+-}
796+type family PG (hask :: Type) :: PGType
797+type instance PG Bool = 'PGbool
798+type instance PG Int16 = 'PGint2
799+type instance PG Int32 = 'PGint4
800+type instance PG Int64 = 'PGint8
801+type instance PG Word16 = 'PGint2
802+type instance PG Word32 = 'PGint4
803+type instance PG Word64 = 'PGint8
804+type instance PG Scientific = 'PGnumeric
805+type instance PG Float = 'PGfloat4
806+type instance PG Double = 'PGfloat8
807+type instance PG Char = 'PGchar 1
808+type instance PG Text = 'PGtext
809+type instance PG Lazy.Text = 'PGtext
810+type instance PG String = 'PGtext
811+type instance PG ByteString = 'PGbytea
812+type instance PG Lazy.ByteString = 'PGbytea
813+type instance PG LocalTime = 'PGtimestamp
814+type instance PG UTCTime = 'PGtimestamptz
815+type instance PG Day = 'PGdate
816+type instance PG TimeOfDay = 'PGtime
817+type instance PG (TimeOfDay, TimeZone) = 'PGtimetz
818+type instance PG DiffTime = 'PGinterval
819+type instance PG UUID = 'PGuuid
820+type instance PG (NetAddr IP) = 'PGinet
821+type instance PG Value = 'PGjson
822+
823+{-| The `LabelsPG` type family calculates the constructors of a
824+Haskell enum type.
825+
826+>>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
827+>>> instance Generic Schwarma
828+>>> instance HasDatatypeInfo Schwarma
829+>>> :kind! LabelsPG Schwarma
830+LabelsPG Schwarma :: [Type.ConstructorName]
831+= '["Beef", "Lamb", "Chicken"]
832+-}
833+type family LabelsPG (hask :: Type) :: [Type.ConstructorName] where
834+ LabelsPG hask =
835+ ConstructorNamesOf (ConstructorsOf (DatatypeInfoOf hask))
836+
837+{- | `RowPG` turns a Haskell record type into a `RowType`.
838+
839+>>> data Person = Person { name :: Text, age :: Int32 } deriving GHC.Generic
840+>>> instance Generic Person
841+>>> instance HasDatatypeInfo Person
842+>>> :kind! RowPG Person
843+RowPG Person :: [(Symbol, NullityType)]
844+= '["name" ::: 'NotNull 'PGtext, "age" ::: 'NotNull 'PGint4]
845+-}
846+type family RowPG (hask :: Type) :: RowType where
847+ RowPG (hask1, hask2) = Join (RowPG hask1) (RowPG hask2)
848+ RowPG (hask1, hask2, hask3) =
849+ Join (RowPG hask1) (RowPG (hask2, hask3))
850+ RowPG (hask1, hask2, hask3, hask4) =
851+ Join (RowPG hask1) (RowPG (hask2, hask3, hask4))
852+ RowPG (hask1, hask2, hask3, hask4, hask5) =
853+ Join (RowPG hask1) (RowPG (hask2, hask3, hask4, hask5))
854+ RowPG (P (col ::: head)) = '[col ::: NullPG head]
855+ RowPG hask = RowOf (RecordCodeOf hask)
856+
857+type family RowOf (fields :: [(Symbol, Type)]) :: RowType where
858+ RowOf '[] = '[]
859+ RowOf (field ': fields) = FieldPG field ': RowOf fields
860+
861+type family FieldPG (field :: (Symbol, Type)) :: (Symbol, NullityType) where
862+ FieldPG (field ::: hask) = field ::: NullPG hask
863+
864+{- | `NullPG` turns a Haskell type into a `NullityType`.
865+
866+>>> :kind! NullPG Double
867+NullPG Double :: NullityType
868+= 'NotNull 'PGfloat8
869+>>> :kind! NullPG (Maybe Double)
870+NullPG (Maybe Double) :: NullityType
871+= 'Null 'PGfloat8
872+-}
873+type family NullPG (hask :: Type) :: NullityType where
874+ NullPG (Maybe hask) = 'Null (PG hask)
875+ NullPG hask = 'NotNull (PG hask)
876+
877+{- | `TuplePG` turns a Haskell tuple type (including record types) into
878+the corresponding list of `NullityType`s.
879+
880+>>> :kind! TuplePG (Double, Maybe Char)
881+TuplePG (Double, Maybe Char) :: [NullityType]
882+= '[ 'NotNull 'PGfloat8, 'Null ('PGchar 1)]
883+-}
884+type family TuplePG (hask :: Type) :: [NullityType] where
885+ TuplePG hask = TupleOf (TupleCodeOf hask (Code hask))
886+
887+type family TupleOf (tuple :: [Type]) :: [NullityType] where
888+ TupleOf '[] = '[]
889+ TupleOf (hask ': tuple) = NullPG hask ': TupleOf tuple
890+
891+type family TupleCodeOf (hask :: Type) (code :: [[Type]]) :: [Type] where
892+ TupleCodeOf hask '[tuple] = tuple
893+ TupleCodeOf hask '[] =
894+ TypeError
895+ ( 'Text "The type `" ':<>: 'ShowType hask ':<>: 'Text "' is not a tuple type."
896+ ':$$: 'Text "It is a void type with no constructors."
897+ )
898+ TupleCodeOf hask (_ ': _ ': _) =
899+ TypeError
900+ ( 'Text "The type `" ':<>: 'ShowType hask ':<>: 'Text "' is not a tuple type."
901+ ':$$: 'Text "It is a sum type with more than one constructor."
902+ )
903+
904+-- | Calculates constructors of a datatype.
905+type family ConstructorsOf (datatype :: Type.DatatypeInfo)
906+ :: [Type.ConstructorInfo] where
907+ ConstructorsOf ('Type.ADT _module _datatype constructors) =
908+ constructors
909+ ConstructorsOf ('Type.Newtype _module _datatype constructor) =
910+ '[constructor]
911+
912+-- | Calculates the name of a nullary constructor, otherwise
913+-- generates a type error.
914+type family ConstructorNameOf (constructors :: Type.ConstructorInfo)
915+ :: Type.ConstructorName where
916+ ConstructorNameOf ('Type.Constructor name) = name
917+ ConstructorNameOf ('Type.Infix name _assoc _fix) = TypeError
918+ ('Text "ConstructorNameOf error: non-nullary constructor "
919+ ':<>: 'Text name)
920+ ConstructorNameOf ('Type.Record name _fields) = TypeError
921+ ('Text "ConstructorNameOf error: non-nullary constructor "
922+ ':<>: 'Text name)
923+
924+-- | Calculate the names of nullary constructors.
925+type family ConstructorNamesOf (constructors :: [Type.ConstructorInfo])
926+ :: [Type.ConstructorName] where
927+ ConstructorNamesOf '[] = '[]
928+ ConstructorNamesOf (constructor ': constructors) =
929+ ConstructorNameOf constructor ': ConstructorNamesOf constructors