git.iko.soy/rel8
on master help sign in
Add Enum and Composite deriving via helpers
commit7c4c6ff9304699ae3ece734f4c8dcc4762a6f90d authorShane O'Brien <shane.obrien@circuithub.com> dateSun 18 Apr 2021, 21:34 (6 years ago) parentb8ff282
3 files changed+172
compare with master
unifiedsplit
rel8.cabal+2 src/Rel8/Type/Composite.hs+84 src/Rel8/Type/Enum.hs+86
rel8.cabal+2
@@ -151,7 +151,9 @@ library
151151 Rel8.Type
152152 Rel8.Type.Array
153153 Rel8.Type.Array1D
154+ Rel8.Type.Composite
154155 Rel8.Type.Eq
156+ Rel8.Type.Enum
155157 Rel8.Type.Information
156158 Rel8.Type.JSONEncoded
157159 Rel8.Type.JSONBEncoded
src/Rel8/Type/Composite.hsnew file+84
@@ -0,0 +1,84 @@
1+{-# language DataKinds #-}
2+{-# language FlexibleContexts #-}
3+{-# language GADTs #-}
4+{-# language ScopedTypeVariables #-}
5+{-# language StandaloneKindSignatures #-}
6+{-# language TypeApplications #-}
7+{-# language TypeOperators #-}
8+{-# language UndecidableInstances #-}
9+
10+module Rel8.Type.Composite
11+ ( Composite( Composite )
12+ )
13+where
14+
15+-- base
16+import Control.Applicative ( liftA2 )
17+import Data.Kind ( Constraint, Type )
18+import Data.Proxy ( Proxy( Proxy ) )
19+import GHC.Generics
20+ ( Generic, Rep, from, to
21+ , (:*:)( (:*:) ), K1( K1 ), M1( M1 )
22+ )
23+import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )
24+import Prelude hiding ( null )
25+
26+-- hasql
27+import qualified Hasql.Decoders as Hasql
28+
29+-- opaleye
30+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
31+
32+-- rel8
33+import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )
34+import Rel8.Type ( DBType, typeInformation )
35+import Rel8.Type.Information ( TypeInformation(..) )
36+
37+
38+-- | A deriving-via helper type for column types that store a Haskell product
39+-- type in a single Postgres column using a Postgres composite type.
40+--
41+-- Note that this must map to a specific extant type in your database's schema
42+-- (created with @CREATE TYPE@). The @name@ parameter of @Composite@ should be
43+-- the name of this type.
44+type Composite :: Symbol -> Type -> Type
45+newtype Composite name a = Composite
46+ { unComposite :: a
47+ }
48+
49+
50+instance (KnownSymbol name, Generic a, GComposite (Rep a)) =>
51+ DBType (Composite name a)
52+ where
53+ typeInformation = TypeInformation
54+ { decode = Hasql.composite (Composite . to <$> gdecode @(Rep a))
55+ , encode = Opaleye.FunExpr "ROW" . gencode @(Rep a) . from . unComposite
56+ , typeName = symbolVal (Proxy @name)
57+ }
58+
59+
60+type GComposite :: (Type -> Type) -> Constraint
61+class GComposite rep where
62+ gdecode :: Hasql.Composite (rep x)
63+ gencode :: rep x -> [Opaleye.PrimExpr]
64+
65+
66+instance GComposite rep => GComposite (M1 i c rep) where
67+ gdecode = M1 <$> gdecode
68+ gencode (M1 a) = gencode a
69+
70+
71+instance (GComposite a, GComposite b) => GComposite (a :*: b) where
72+ gdecode = liftA2 (:*:) gdecode gdecode
73+ gencode (a :*: b) = gencode a <> gencode b
74+
75+
76+instance Sql DBType a => GComposite (K1 i a) where
77+ gdecode = fmap K1 $ Hasql.field $ case nullable @a of
78+ Null -> Hasql.nullable (decode typeInformation)
79+ NotNull -> Hasql.nonNullable (decode typeInformation)
80+ gencode (K1 a) = case nullable @a of
81+ Null -> [maybe null (encode typeInformation) a]
82+ NotNull -> [encode typeInformation a]
83+ where
84+ null = Opaleye.ConstExpr Opaleye.NullLit
src/Rel8/Type/Enum.hsnew file+86
@@ -0,0 +1,86 @@
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 #-}
10+
11+module Rel8.Type.Enum
12+ ( Enum(..)
13+ )
14+where
15+
16+-- base
17+import Data.Kind ( Constraint, Type )
18+import Data.Proxy ( Proxy( Proxy ) )
19+import GHC.Generics
20+ ( Generic, Rep, from, to
21+ , (:+:)( L1, R1 ), M1( M1 ), U1( U1 ), Meta( MetaCons )
22+ , D, C
23+ )
24+import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )
25+import Prelude hiding ( Enum )
26+
27+-- hasql
28+import qualified Hasql.Decoders as Hasql
29+
30+-- opaleye
31+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
32+
33+-- rel8
34+import Rel8.Type ( DBType, typeInformation )
35+import Rel8.Type.Information ( TypeInformation(..) )
36+
37+-- text
38+import Data.Text ( unpack )
39+
40+
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).
50+type Enum :: Symbol -> Type -> Type
51+newtype Enum name a = Enum
52+ { unEnum :: a
53+ }
54+
55+
56+instance (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+ }
63+
64+
65+type GEnum :: (Type -> Type) -> Constraint
66+class GEnum rep where
67+ gdecode :: [(String, rep x)]
68+ gencode :: rep x -> String
69+
70+
71+instance GEnum rep => GEnum (M1 D c rep) where
72+ gdecode = fmap M1 <$> gdecode
73+ gencode (M1 a) = gencode a
74+
75+
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
80+
81+
82+instance (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)