392022c · squeal · git.iko.soy

git.iko.soy/squeal

on dev help sign in

move PG to Binary

392022cEitan Chatav8 years ago

squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs+160−6

compare with dev

unifiedsplit

@@ -1,8 +1,3 @@

1−{-# LANGUAGE

2− TypeFamilies

3− , UndecidableSuperClasses

4−#-}

5−

6{-|

1{-|

7Module: Squeal.PostgreSQL.Binary

2Module: Squeal.PostgreSQL.Binary

8Description: Binary encoding and decoding

3Description: Binary encoding and decoding

@@ -199,13 +194,22 @@ True

199 , MultiParamTypeClasses

194 , MultiParamTypeClasses

200 , ScopedTypeVariables

195 , ScopedTypeVariables

201 , TypeApplications

196 , TypeApplications

197+ , TypeFamilies

202 , TypeInType

198 , TypeInType

203 , TypeOperators

199 , TypeOperators

204 , UndecidableInstances

200 , UndecidableInstances

201+ , UndecidableSuperClasses

205#-}

202#-}

206

203

207module Squeal.PostgreSQL.Binary

204module Squeal.PostgreSQL.Binary

205+ ( -- * PG type families

206+ PG

207+ , NullPG

208+ , TuplePG

209+ , RowPG

210+ , LabelsPG

211+ -- * Storage newtypes

208− ( Json (..)

212+ , Json (..)

209 , Jsonb (..)

213 , Jsonb (..)

210 , Composite (..)

214 , Composite (..)

211 , Enumerated (..)

215 , Enumerated (..)

@@ -226,9 +230,12 @@ import BinaryParser

226import ByteString.StrictBuilder (builderLength, int32BE, int64BE, word32BE)

230import ByteString.StrictBuilder (builderLength, int32BE, int64BE, word32BE)

227import Control.Arrow (left)

231import Control.Arrow (left)

228import Control.Monad

232import Control.Monad

233+import Data.Aeson (Value)

234+import Data.ByteString (ByteString)

229import Data.Int

235import Data.Int

230import Data.Kind

236import Data.Kind

231import Data.Scientific

237import Data.Scientific

238+import Data.Text (Text)

232import Data.Time

239import Data.Time

233import Data.UUID.Types

240import Data.UUID.Types

234import Data.Vector (Vector)

241import Data.Vector (Vector)

@@ -246,6 +253,7 @@ import qualified Data.Text.Lazy as Lazy (Text)

246import qualified Data.Text as Strict (Text)

253import qualified Data.Text as Strict (Text)

247import qualified Data.Text as Strict.Text

254import qualified Data.Text as Strict.Text

248import qualified Data.Vector as Vector

255import qualified Data.Vector as Vector

256+import qualified Generics.SOP.Type.Metadata as Type

249import qualified GHC.Generics as GHC

257import qualified GHC.Generics as GHC

250import qualified PostgreSQL.Binary.Decoding as Decoding

258import qualified PostgreSQL.Binary.Decoding as Decoding

251import qualified PostgreSQL.Binary.Encoding as Encoding

259import qualified PostgreSQL.Binary.Encoding as Encoding

@@ -773,3 +781,149 @@ type family FixPG (hask :: Type) :: NullityType where

773 FixPG (x,x,x,x,x,x,x,x,x,x) = FixPG x

781 FixPG (x,x,x,x,x,x,x,x,x,x) = FixPG x

774 FixPG (x,x,x,x,x,x,x,x,x,x,x) = FixPG x

782 FixPG (x,x,x,x,x,x,x,x,x,x,x) = FixPG x

775 FixPG x = NullPG x

783 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

squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs+1

@@ -62,6 +62,7 @@ import GHC.TypeLits (KnownSymbol)

62import qualified Generics.SOP as SOP

63import qualified GHC.Generics as GHC

65+import Squeal.PostgreSQL.Binary

65import Squeal.PostgreSQL.Expression

66import Squeal.PostgreSQL.Expression

66import Squeal.PostgreSQL.Render

67import Squeal.PostgreSQL.Render

67import Squeal.PostgreSQL.Query

68import Squeal.PostgreSQL.Query

squeal-postgresql/src/Squeal/PostgreSQL/Query.hs+1

@@ -111,6 +111,7 @@ import GHC.TypeLits

111

112import qualified GHC.Generics as GHC

113

114+import Squeal.PostgreSQL.Binary

114import Squeal.PostgreSQL.Expression

115import Squeal.PostgreSQL.Expression

115import Squeal.PostgreSQL.Render

116import Squeal.PostgreSQL.Render

116import Squeal.PostgreSQL.Schema

117import Squeal.PostgreSQL.Schema

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

@@ -40,11 +40,6 @@ module Squeal.PostgreSQL.Schema

40 , NullityType (..)

41 , RowType

42 , FromType

43− -- * Haskell to Postgres Types

44− , PG

45− , NullPG

46− , TuplePG

47− , RowPG

48 -- * Schema Types

43 -- * Schema Types

49 , ColumnType

44 , ColumnType

50 , ColumnsType

45 , ColumnsType

@@ -78,7 +73,6 @@ module Squeal.PostgreSQL.Schema

78 -- * Enumerated Labels

73 -- * Enumerated Labels

79 , IsPGlabel (..)

74 , IsPGlabel (..)

80 , PGlabel (..)

75 , PGlabel (..)

81− , LabelsPG

82 -- * Grouping

76 -- * Grouping

83 , Grouping (..)

77 , Grouping (..)

84 , GroupedBy

78 , GroupedBy

@@ -123,29 +117,18 @@ module Squeal.PostgreSQL.Schema

123

117

124import Control.Category

118import Control.Category

125import Control.DeepSeq

119import Control.DeepSeq

126−import Data.Aeson (Value)

127import Data.ByteString (ByteString)

120import Data.ByteString (ByteString)

128−import Data.Int (Int16, Int32, Int64)

129import Data.Kind

121import Data.Kind

130import Data.Monoid hiding (All)

122import Data.Monoid hiding (All)

131−import Data.Scientific (Scientific)

132import Data.String

123import Data.String

133−import Data.Text (Text)

134−import Data.Time

135−import Data.Word (Word16, Word32, Word64)

136import Data.Type.Bool

124import Data.Type.Bool

137−import Data.UUID.Types (UUID)

125+import Data.Word (Word32)

138import Generics.SOP

126import Generics.SOP

139−import Generics.SOP.Record

140import GHC.OverloadedLabels

127import GHC.OverloadedLabels

141import GHC.TypeLits

128import GHC.TypeLits

142−import Network.IP.Addr

143import Prelude hiding (id, (.))

129import Prelude hiding (id, (.))

144

130

145−import qualified Data.ByteString.Lazy as Lazy

146−import qualified Data.Text.Lazy as Lazy

147import qualified GHC.Generics as GHC

131import qualified GHC.Generics as GHC

148−import qualified Generics.SOP.Type.Metadata as Type

149

132

150import Squeal.PostgreSQL.Render

133import Squeal.PostgreSQL.Render

151

134

@@ -774,151 +757,6 @@ instance All KnownSymbol labels => RenderSQL (NP PGlabel labels) where

774 . hcollapse

757 . hcollapse

775 . hcmap (Proxy @KnownSymbol) (K . renderSQL)

758 . hcmap (Proxy @KnownSymbol) (K . renderSQL)

776

759

777−{- | The `PG` type family embeds a subset of Haskell types

778−as Postgres types. As an open type family, `PG` is extensible.

779−

780−>>> :kind! PG LocalTime

781−PG LocalTime :: PGType

782−= 'PGtimestamp

783−

784−>>> newtype MyDouble = My Double

785−>>> type instance PG MyDouble = 'PGfloat8

786−-}

787−type family PG (hask :: Type) :: PGType

788−type instance PG Bool = 'PGbool

789−type instance PG Int16 = 'PGint2

790−type instance PG Int32 = 'PGint4

791−type instance PG Int64 = 'PGint8

792−type instance PG Word16 = 'PGint2

793−type instance PG Word32 = 'PGint4

794−type instance PG Word64 = 'PGint8

795−type instance PG Scientific = 'PGnumeric

796−type instance PG Float = 'PGfloat4

797−type instance PG Double = 'PGfloat8

798−type instance PG Char = 'PGchar 1

799−type instance PG Text = 'PGtext

800−type instance PG Lazy.Text = 'PGtext

801−type instance PG String = 'PGtext

802−type instance PG ByteString = 'PGbytea

803−type instance PG Lazy.ByteString = 'PGbytea

804−type instance PG LocalTime = 'PGtimestamp

805−type instance PG UTCTime = 'PGtimestamptz

806−type instance PG Day = 'PGdate

807−type instance PG TimeOfDay = 'PGtime

808−type instance PG (TimeOfDay, TimeZone) = 'PGtimetz

809−type instance PG DiffTime = 'PGinterval

810−type instance PG UUID = 'PGuuid

811−type instance PG (NetAddr IP) = 'PGinet

812−type instance PG Value = 'PGjson

813−

814−{-| The `LabelsPG` type family calculates the constructors of a

815−Haskell enum type.

816−

817−>>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic

818−>>> instance Generic Schwarma

819−>>> instance HasDatatypeInfo Schwarma

820−>>> :kind! LabelsPG Schwarma

821−LabelsPG Schwarma :: [Type.ConstructorName]

822−= '["Beef", "Lamb", "Chicken"]

823−-}

824−type family LabelsPG (hask :: Type) :: [Type.ConstructorName] where

825− LabelsPG hask =

826− ConstructorNamesOf (ConstructorsOf (DatatypeInfoOf hask))

827−

828−{- | `RowPG` turns a Haskell record type into a `RowType`.

829−

830−>>> data Person = Person { name :: Text, age :: Int32 } deriving GHC.Generic

831−>>> instance Generic Person

832−>>> instance HasDatatypeInfo Person

833−>>> :kind! RowPG Person

834−RowPG Person :: [(Symbol, NullityType)]

835−= '["name" ::: 'NotNull 'PGtext, "age" ::: 'NotNull 'PGint4]

836−-}

837−type family RowPG (hask :: Type) :: RowType where

838− RowPG (hask1, hask2) = Join (RowPG hask1) (RowPG hask2)

839− RowPG (hask1, hask2, hask3) =

840− Join (RowPG hask1) (RowPG (hask2, hask3))

841− RowPG (hask1, hask2, hask3, hask4) =

842− Join (RowPG hask1) (RowPG (hask2, hask3, hask4))

843− RowPG (hask1, hask2, hask3, hask4, hask5) =

844− Join (RowPG hask1) (RowPG (hask2, hask3, hask4, hask5))

845− RowPG (P (col ::: head)) = '[col ::: NullPG head]

846− RowPG hask = RowOf (RecordCodeOf hask)

847−

848−type family RowOf (fields :: [(Symbol, Type)]) :: RowType where

849− RowOf '[] = '[]

850− RowOf (field ': fields) = FieldPG field ': RowOf fields

851−

852−type family FieldPG (field :: (Symbol, Type)) :: (Symbol, NullityType) where

853− FieldPG (field ::: hask) = field ::: NullPG hask

854−

855−{- | `NullPG` turns a Haskell type into a `NullityType`.

856−

857−>>> :kind! NullPG Double

858−NullPG Double :: NullityType

859−= 'NotNull 'PGfloat8

860−>>> :kind! NullPG (Maybe Double)

861−NullPG (Maybe Double) :: NullityType

862−= 'Null 'PGfloat8

863−-}

864−type family NullPG (hask :: Type) :: NullityType where

865− NullPG (Maybe hask) = 'Null (PG hask)

866− NullPG hask = 'NotNull (PG hask)

867−

868−{- | `TuplePG` turns a Haskell tuple type (including record types) into

869−the corresponding list of `NullityType`s.

870−

871−>>> :kind! TuplePG (Double, Maybe Char)

872−TuplePG (Double, Maybe Char) :: [NullityType]

873−= '[ 'NotNull 'PGfloat8, 'Null ('PGchar 1)]

874−-}

875−type family TuplePG (hask :: Type) :: [NullityType] where

876− TuplePG hask = TupleOf (TupleCodeOf hask (Code hask))

877−

878−type family TupleOf (tuple :: [Type]) :: [NullityType] where

879− TupleOf '[] = '[]

880− TupleOf (hask ': tuple) = NullPG hask ': TupleOf tuple

881−

882−type family TupleCodeOf (hask :: Type) (code :: [[Type]]) :: [Type] where

883− TupleCodeOf hask '[tuple] = tuple

884− TupleCodeOf hask '[] =

885− TypeError

886− ( 'Text "The type `" :<>: 'ShowType hask :<>: 'Text "' is not a tuple type."

887− :$$: 'Text "It is a void type with no constructors."

888− )

889− TupleCodeOf hask (_ ': _ ': _) =

890− TypeError

891− ( 'Text "The type `" :<>: 'ShowType hask :<>: 'Text "' is not a tuple type."

892− :$$: 'Text "It is a sum type with more than one constructor."

893− )

894−

895−-- | Calculates constructors of a datatype.

896−type family ConstructorsOf (datatype :: Type.DatatypeInfo)

897− :: [Type.ConstructorInfo] where

898− ConstructorsOf ('Type.ADT _module _datatype constructors) =

899− constructors

900− ConstructorsOf ('Type.Newtype _module _datatype constructor) =

901− '[constructor]

902−

903−-- | Calculates the name of a nullary constructor, otherwise

904−-- generates a type error.

905−type family ConstructorNameOf (constructors :: Type.ConstructorInfo)

906− :: Type.ConstructorName where

907− ConstructorNameOf ('Type.Constructor name) = name

908− ConstructorNameOf ('Type.Infix name _assoc _fix) = TypeError

909− ('Text "ConstructorNameOf error: non-nullary constructor "

910− ':<>: 'Text name)

911− ConstructorNameOf ('Type.Record name _fields) = TypeError

912− ('Text "ConstructorNameOf error: non-nullary constructor "

913− ':<>: 'Text name)

914−

915−-- | Calculate the names of nullary constructors.

916−type family ConstructorNamesOf (constructors :: [Type.ConstructorInfo])

917− :: [Type.ConstructorName] where

918− ConstructorNamesOf '[] = '[]

919− ConstructorNamesOf (constructor ': constructors) =

920− ConstructorNameOf constructor ': ConstructorNamesOf constructors

921−

922-- | Is a type a valid JSON key?

760-- | Is a type a valid JSON key?

923type PGJsonKey = '[ 'PGint2, 'PGint4, 'PGtext ]

761type PGJsonKey = '[ 'PGint2, 'PGint4, 'PGtext ]

924

762