@@ -1,27 +1,34 @@
1+{-# language AllowAmbiguousTypes #-}
12{-# language DataKinds #-}
23{-# language FlexibleContexts #-}
34{-# language FlexibleInstances #-}
4−{-# language GADTs #-}
5+{-# language LambdaCase #-}
6+{-# language RankNTypes #-}
57{-# language ScopedTypeVariables #-}
68{-# language StandaloneKindSignatures #-}
79{-# language TypeApplications #-}
10+{-# language TypeFamilies #-}
811{-# language TypeOperators #-}
912{-# language UndecidableInstances #-}
1013
1114module Rel8.Type.Enum
12− ( Enum(..)
15+ ( Enum( Enum )
16+ , DBEnum( enumValue, enumTypeName )
17+ , Enumable
1318 )
1419where
1520
1621-- base
22+import Control.Applicative ( (<|>) )
23+import Control.Arrow ( (&&&) )
1724import Data.Kind ( Constraint, Type )
1825import Data.Proxy ( Proxy( Proxy ) )
1926import GHC.Generics
2027 ( Generic, Rep, from, to
21− , (:+:)( L1, R1 ), M1( M1 ), U1( U1 ), Meta( MetaCons )
22− , D, C
28+ , (:+:)( L1, R1 ), M1( M1 ), U1( U1 )
29+ , D, C, Meta( MetaCons )
2330 )
24−import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )
31+import GHC.TypeLits ( KnownSymbol, symbolVal )
2532import Prelude hiding ( Enum )
2633
2734-- hasql
@@ -32,55 +39,93 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
3239
3340-- rel8
3441import Rel8.Type ( DBType, typeInformation )
42+import Rel8.Type.Eq ( DBEq )
3543import Rel8.Type.Information ( TypeInformation(..) )
44+import Rel8.Type.Ord ( DBOrd, DBMax, DBMin )
3645
3746-- text
38−import Data.Text ( unpack )
47+import Data.Text ( pack )
3948
4049
4150-- | A deriving-via helper type for column types that store an \"enum\" type
4251-- (in Haskell terms, a sum type where all constructors are nullary) using a
4352-- Postgres @enum@ type.
4453--
45−-- Note that this must map to a specific type in your database's schema
46−-- (explicitly created with @CREATE TYPE ... AS ENUM@). The @name@ parameter
47−-- of @Enum@ should be the name of this type. Note also the names of the
48−-- Postgres @enum@'s values are assumed to match exactly the names of the
49−-- constructors of the Haskell type (up to and including case sensitivity).
50−type Enum :: Symbol -> Type -> Type
51−newtype Enum name a = Enum
54+-- Note that this should map to a specific type in your database's schema
55+-- (explicitly created with @CREATE TYPE ... AS ENUM@). Use 'DBEnum' to
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
58+-- @enum@ are assumed to match exactly exactly the names of the constructors
59+-- of the Haskell type (up to and including case sensitivity).
60+type Enum :: Type -> Type
61+newtype Enum a = Enum
5262 { unEnum :: a
5363 }
5464
5565
56−instance (KnownSymbol name, Generic a, GEnum (Rep a)) => DBType (Enum name a)
57− where
66+instance DBEnum a => DBType (Enum a) where
5867 typeInformation = TypeInformation
59− { decode = Hasql.enum ((`lookup` (fmap (Enum . to) <$> gdecode)) . unpack)
60− , encode = Opaleye.ConstExpr . Opaleye.StringLit . gencode . from . unEnum
61− , typeName = symbolVal (Proxy @name)
68+ { decode =
69+ Hasql.enum $
70+ flip lookup $
71+ map ((pack . enumValue &&& Enum) . to) $
72+ genumerate @(Rep a)
73+ , encode =
74+ Opaleye.ConstExpr .
75+ Opaleye.StringLit .
76+ enumValue @a .
77+ unEnum
78+ , typeName = enumTypeName @a
6279 }
6380
6481
65−type GEnum :: (Type -> Type) -> Constraint
66−class GEnum rep where
67− gdecode :: [(String, rep x)]
68− gencode :: rep x -> String
82+instance DBEnum a => DBEq (Enum a)
83+
84+
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+
6993
94+type DBEnum :: Type -> Constraint
95+class (DBType a, Enumable a) => DBEnum a where
96+ enumValue :: a -> String
97+ enumValue = gshow @(Rep a) . from
7098
71−instance GEnum rep => GEnum (M1 D c rep) where
72− gdecode = fmap M1 <$> gdecode
73− gencode (M1 a) = gencode a
99+ enumTypeName :: String
74100
75101
76−instance (GEnum a, GEnum b) => GEnum (a :+: b) where
77− gdecode = (fmap L1 <$> gdecode) <> (fmap R1 <$> gdecode)
78− gencode (L1 a) = gencode a
79− gencode (R1 a) = gencode a
102+class (Generic a, GEnumable (Rep a)) => Enumable a
103+instance (Generic a, GEnumable (Rep a)) => Enumable a
80104
81105
82−instance (KnownSymbol name, a ~ U1) =>
83− GEnum (M1 C ('MetaCons name f r) a)
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
125+ ( meta ~ 'MetaCons name _fixity _isRecord
126+ , KnownSymbol name
127+ )
128+ => GEnumable (M1 C meta U1)
84129 where
85− gdecode = [(symbolVal (Proxy @name), M1 U1)]
86− gencode _ = symbolVal (Proxy @name)
130+ genumerate = [M1 U1]
131+ gshow (M1 U1) = symbolVal (Proxy @name)