git.iko.soy/rel8
on db148ff help sign in
rel8/src/Rel8/Type/Enum.hs
86 lines 2.5 kB history raw
1{-# language DataKinds #-}
2{-# language FlexibleContexts #-}
3{-# language FlexibleInstances #-}
4{-# language GADTs #-}
5{-# language ScopedTypeVariables #-}
6{-# language StandaloneKindSignatures #-}
7{-# language TypeApplications #-}
8{-# language TypeOperators #-}
9{-# language UndecidableInstances #-}
11module Rel8.Type.Enum
12 ( Enum(..)
13 )
14where
16-- base
17import Data.Kind ( Constraint, Type )
18import Data.Proxy ( Proxy( Proxy ) )
19import GHC.Generics
20 ( Generic, Rep, from, to
21 , (:+:)( L1, R1 ), M1( M1 ), U1( U1 ), Meta( MetaCons )
22 , D, C
23 )
24import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )
25import Prelude hiding ( Enum )
27-- hasql
28import qualified Hasql.Decoders as Hasql
30-- opaleye
31import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
33-- rel8
34import Rel8.Type ( DBType, typeInformation )
35import Rel8.Type.Information ( TypeInformation(..) )
37-- text
38import Data.Text ( unpack )
41-- | 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
43-- Postgres @enum@ type.
44--
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).
50type Enum :: Symbol -> Type -> Type
51newtype Enum name a = Enum
52 { unEnum :: a
53 }
56instance (KnownSymbol name, Generic a, GEnum (Rep a)) => DBType (Enum name a)
57 where
58 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)
62 }
65type GEnum :: (Type -> Type) -> Constraint
66class GEnum rep where
67 gdecode :: [(String, rep x)]
68 gencode :: rep x -> String
71instance GEnum rep => GEnum (M1 D c rep) where
72 gdecode = fmap M1 <$> gdecode
73 gencode (M1 a) = gencode a
76instance (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
82instance (KnownSymbol name, a ~ U1) =>
83 GEnum (M1 C ('MetaCons name f r) a)
84 where
85 gdecode = [(symbolVal (Proxy @name), M1 U1)]
86 gencode _ = symbolVal (Proxy @name)