git.iko.soy/squeal
on dev help sign in
enum decoding
3148d41Eitan Chatav
squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs+17
compare with dev
unifiedsplit
@@ -46,6 +46,7 @@ module Squeal.PostgreSQL.Binary
46
46
47import BinaryParser
47import BinaryParser
48import Data.Aeson hiding (Null)
48import Data.Aeson hiding (Null)
49+import Data.Char (toUpper)
49import Data.Int
50import Data.Int
50import Data.Kind
51import Data.Kind
51import Data.Scientific
52import Data.Scientific
@@ -56,6 +57,7 @@ import Data.Word
56import Generics.SOP
57import Generics.SOP
57import GHC.TypeLits
58import GHC.TypeLits
58import Network.IP.Addr
59import Network.IP.Addr
60+import Text.Read (readMaybe)
59
61
60import qualified Data.ByteString.Lazy as Lazy
62import qualified Data.ByteString.Lazy as Lazy
61import qualified Data.ByteString as Strict hiding (unpack)
63import qualified Data.ByteString as Strict hiding (unpack)
@@ -203,6 +205,21 @@ instance FromValue pg y => FromValue ('PGfixarray n pg) (Vector (Maybe y)) where
203 fromValue _ = Decoding.array
205 fromValue _ = Decoding.array
204 (Decoding.dimensionArray Vector.replicateM
206 (Decoding.dimensionArray Vector.replicateM
205 (Decoding.nullableValueArray (fromValue (Proxy @pg))))
207 (Decoding.nullableValueArray (fromValue (Proxy @pg))))
208+instance
209+ ( IsEnumType y
210+ , Read y
211+ -- , SameLabels (DatatypeInfoOf y) labels
212+ --
213+ -- uncomment above constraint when GHC issue #11671 is fixed
214+ -- Allow labels starting with uppercase with OverloadedLabels
215+ -- https://ghc.haskell.org/trac/ghc/ticket/11671?cversion=0&cnum_hist=8
216+ ) => FromValue ('PGenum labels) y where
217+ fromValue _ =
218+ let
219+ upper "" = ""
220+ upper (ch:chs) = toUpper ch : chs
221+ in
222+ Decoding.enum (readMaybe . upper . Strict.unpack)
206instance
223instance
207 ( SListI fields
224 ( SListI fields
208 , IsMaybes ys
225 , IsMaybes ys
squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+13
@@ -99,6 +99,8 @@ module Squeal.PostgreSQL.Schema
99 -- * Generics
99 -- * Generics
100 , SameField
100 , SameField
101 , SameFields
101 , SameFields
102+ , SameLabel
103+ , SameLabels
102 -- * Schema
104 -- * Schema
103 , SchemumType (..)
105 , SchemumType (..)
104 , SchemaType
106 , SchemaType
@@ -606,6 +608,17 @@ type family SameFields
606 columns
608 columns
607 = SOP.AllZip SameField fields columns
609 = SOP.AllZip SameField fields columns
608
610
611+class SameLabel
612+ (constrInfo :: Type.ConstructorInfo) (label :: Symbol) where
613+instance name ~ label => SameLabel ('Type.Constructor name) label
614+
615+type family SameLabels
616+ (datatypeInfo :: Type.DatatypeInfo) (labels :: [Symbol])
617+ :: Constraint where
618+ SameLabels
619+ ('Type.ADT _module _datatype constructors) labels
620+ = SOP.AllZip SameLabel constructors labels
621+
609-- | Check if a `TableConstraint` involves a column
622-- | Check if a `TableConstraint` involves a column
610type family ConstraintInvolves column constraint where
623type family ConstraintInvolves column constraint where
611 ConstraintInvolves column ('Check columns) = column `Elem` columns
624 ConstraintInvolves column ('Check columns) = column `Elem` columns