git.iko.soy/squeal
on dev help sign in
enum decoding
commit3148d4119437c62c38e7cd66d488c0a6c3350b00 authorEitan Chatav <eitan.chatav@gmail.com> dateSun 15 Apr 2018, 21:32 (9 years ago) parent0f3aa2f
2 files changed+30
compare with dev
unifiedsplit
squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs+17 squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+13
squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs+17
@@ -46,6 +46,7 @@ module Squeal.PostgreSQL.Binary
4646
4747import BinaryParser
4848import Data.Aeson hiding (Null)
49+import Data.Char (toUpper)
4950import Data.Int
5051import Data.Kind
5152import Data.Scientific
@@ -56,6 +57,7 @@ import Data.Word
5657import Generics.SOP
5758import GHC.TypeLits
5859import Network.IP.Addr
60+import Text.Read (readMaybe)
5961
6062import qualified Data.ByteString.Lazy as Lazy
6163import qualified Data.ByteString as Strict hiding (unpack)
@@ -203,6 +205,21 @@ instance FromValue pg y => FromValue ('PGfixarray n pg) (Vector (Maybe y)) where
203205 fromValue _ = Decoding.array
204206 (Decoding.dimensionArray Vector.replicateM
205207 (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)
206223instance
207224 ( SListI fields
208225 , IsMaybes ys
squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+13
@@ -99,6 +99,8 @@ module Squeal.PostgreSQL.Schema
9999 -- * Generics
100100 , SameField
101101 , SameFields
102+ , SameLabel
103+ , SameLabels
102104 -- * Schema
103105 , SchemumType (..)
104106 , SchemaType
@@ -606,6 +608,17 @@ type family SameFields
606608 columns
607609 = SOP.AllZip SameField fields columns
608610
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+
609622-- | Check if a `TableConstraint` involves a column
610623type family ConstraintInvolves column constraint where
611624 ConstraintInvolves column ('Check columns) = column `Elem` columns