git.iko.soy/rel8
on master help sign in
Add DBEnum class for specifying enum value names for Enum
83466c9Shane O'Brien
src/Rel8/Type/Enum.hs+78−33
compare with master
unifiedsplit
@@ -1,27 +1,34 @@
1+{-# language AllowAmbiguousTypes #-}
1{-# language DataKinds #-}
2{-# language DataKinds #-}
2{-# language FlexibleContexts #-}
3{-# language FlexibleContexts #-}
3{-# language FlexibleInstances #-}
4{-# language FlexibleInstances #-}
4−{-# language GADTs #-}
5+{-# language LambdaCase #-}
6+{-# language RankNTypes #-}
5{-# language ScopedTypeVariables #-}
7{-# language ScopedTypeVariables #-}
6{-# language StandaloneKindSignatures #-}
8{-# language StandaloneKindSignatures #-}
7{-# language TypeApplications #-}
9{-# language TypeApplications #-}
10+{-# language TypeFamilies #-}
8{-# language TypeOperators #-}
11{-# language TypeOperators #-}
9{-# language UndecidableInstances #-}
12{-# language UndecidableInstances #-}
10
13
11module Rel8.Type.Enum
14module Rel8.Type.Enum
12− ( Enum(..)
15+ ( Enum( Enum )
16+ , DBEnum( enumValue, enumTypeName )
17+ , Enumable
13 )
18 )
14where
19where
15
20
16-- base
21-- base
22+import Control.Applicative ( (<|>) )
23+import Control.Arrow ( (&&&) )
17import Data.Kind ( Constraint, Type )
24import Data.Kind ( Constraint, Type )
18import Data.Proxy ( Proxy( Proxy ) )
25import Data.Proxy ( Proxy( Proxy ) )
19import GHC.Generics
26import GHC.Generics
20 ( Generic, Rep, from, to
27 ( Generic, Rep, from, to
21− , (:+:)( L1, R1 ), M1( M1 ), U1( U1 ), Meta( MetaCons )
28+ , (:+:)( L1, R1 ), M1( M1 ), U1( U1 )
22− , D, C
29+ , D, C, Meta( MetaCons )
23 )
30 )
24−import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )
31+import GHC.TypeLits ( KnownSymbol, symbolVal )
25import Prelude hiding ( Enum )
32import Prelude hiding ( Enum )
26
33
27-- hasql
34-- hasql
@@ -32,55 +39,93 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
32
39
33-- rel8
40-- rel8
34import Rel8.Type ( DBType, typeInformation )
41import Rel8.Type ( DBType, typeInformation )
42+import Rel8.Type.Eq ( DBEq )
35import Rel8.Type.Information ( TypeInformation(..) )
43import Rel8.Type.Information ( TypeInformation(..) )
44+import Rel8.Type.Ord ( DBOrd, DBMax, DBMin )
36
45
37-- text
46-- text
38−import Data.Text ( unpack )
47+import Data.Text ( pack )
39
48
40
49
41-- | A deriving-via helper type for column types that store an \"enum\" type
50-- | A deriving-via helper type for column types that store an \"enum\" type
42-- (in Haskell terms, a sum type where all constructors are nullary) using a
51-- (in Haskell terms, a sum type where all constructors are nullary) using a
43-- Postgres @enum@ type.
52-- Postgres @enum@ type.
44--
53--
45−-- Note that this must map to a specific type in your database's schema
54+-- Note that this should map to a specific type in your database's schema
46−-- (explicitly created with @CREATE TYPE ... AS ENUM@). The @name@ parameter
55+-- (explicitly created with @CREATE TYPE ... AS ENUM@). Use 'DBEnum' to
47−-- of @Enum@ should be the name of this type. Note also the names of the
56+-- specify the name of this Postgres type and the names of the individual
57+-- values. If left unspecified, the names of the values of the Postgres
48−-- Postgres @enum@'s values are assumed to match exactly the names of the
58+-- @enum@ are assumed to match exactly exactly the names of the constructors
49−-- constructors of the Haskell type (up to and including case sensitivity).
59+-- of the Haskell type (up to and including case sensitivity).
50−type Enum :: Symbol -> Type -> Type
60+type Enum :: Type -> Type
51−newtype Enum name a = Enum
61+newtype Enum a = Enum
52 { unEnum :: a
62 { unEnum :: a
53 }
63 }
54
64
55
65
56−instance (KnownSymbol name, Generic a, GEnum (Rep a)) => DBType (Enum name a)
66+instance DBEnum a => DBType (Enum a) where
57− where
58 typeInformation = TypeInformation
67 typeInformation = TypeInformation
59− { decode = Hasql.enum ((`lookup` (fmap (Enum . to) <$> gdecode)) . unpack)
68+ { decode =
69+ Hasql.enum $
70+ flip lookup $
71+ map ((pack . enumValue &&& Enum) . to) $
72+ genumerate @(Rep a)
73+ , encode =
60− , encode = Opaleye.ConstExpr . Opaleye.StringLit . gencode . from . unEnum
74+ Opaleye.ConstExpr .
61− , typeName = symbolVal (Proxy @name)
75+ Opaleye.StringLit .
76+ enumValue @a .
77+ unEnum
78+ , typeName = enumTypeName @a
62 }
79 }
63
80
64
81
65−type GEnum :: (Type -> Type) -> Constraint
82+instance DBEnum a => DBEq (Enum a)
66−class GEnum rep where
83+
67− gdecode :: [(String, rep x)]
84+
68− gencode :: rep x -> String
85+instance DBEnum a => DBOrd (Enum a)
86+
87+
88+instance DBEnum a => DBMax (Enum a)
89+
90+
91+instance DBEnum a => DBMin (Enum a)
92+
69
93
94+type DBEnum :: Type -> Constraint
95+class (DBType a, Enumable a) => DBEnum a where
96+ enumValue :: a -> String
97+ enumValue = gshow @(Rep a) . from
70
98
71−instance GEnum rep => GEnum (M1 D c rep) where
99+ enumTypeName :: String
72− gdecode = fmap M1 <$> gdecode
73− gencode (M1 a) = gencode a
74
100
75
101
76−instance (GEnum a, GEnum b) => GEnum (a :+: b) where
102+class (Generic a, GEnumable (Rep a)) => Enumable a
77− gdecode = (fmap L1 <$> gdecode) <> (fmap R1 <$> gdecode)
103+instance (Generic a, GEnumable (Rep a)) => Enumable a
78− gencode (L1 a) = gencode a
79− gencode (R1 a) = gencode a
80
104
81
105
82−instance (KnownSymbol name, a ~ U1) =>
106+type GEnumable :: (Type -> Type) -> Constraint
107+class GEnumable rep where
108+ genumerate :: [rep x]
109+ gshow :: rep x -> String
110+
111+
112+instance GEnumable rep => GEnumable (M1 D meta rep) where
113+ genumerate = M1 <$> genumerate
114+ gshow (M1 rep) = gshow rep
115+
116+
117+instance (GEnumable a, GEnumable b) => GEnumable (a :+: b) where
118+ genumerate = L1 <$> genumerate <|> R1 <$> genumerate
119+ gshow = \case
120+ L1 a -> gshow a
121+ R1 a -> gshow a
122+
123+
124+instance
83− GEnum (M1 C ('MetaCons name f r) a)
125+ ( meta ~ 'MetaCons name _fixity _isRecord
126+ , KnownSymbol name
127+ )
128+ => GEnumable (M1 C meta U1)
84 where
129 where
85− gdecode = [(symbolVal (Proxy @name), M1 U1)]
130+ genumerate = [M1 U1]
86− gencode _ = symbolVal (Proxy @name)
131+ gshow (M1 U1) = symbolVal (Proxy @name)