git.iko.soy/rel8
on master help sign in
Rewrite Composite in terms of HKD (allowing us to project fields)
def349eShane O'Brien
src/Rel8.hs+1−1
compare with master
unifiedsplit
@@ -14,7 +14,7 @@ module Rel8
14 , ReadShow(..)
14 , ReadShow(..)
15
15
16 -- **** Generic
16 -- **** Generic
17− , Composite(..)
17+ , Composite(..), DBComposite(..), compose, decompose
18 , Enum(..)
18 , Enum(..)
19
19
20 -- *** @TypeInformation@
20 -- *** @TypeInformation@
src/Rel8/Query/Exists.hs+1−1
@@ -54,7 +54,7 @@ with f a = a <$ whereExists (f a)
54
54
55
55
56-- | Like @with@, but with a custom membership test.
56-- | Like @with@, but with a custom membership test.
57−withBy :: (a -> b -> Expr Bool) -> Query b -> a -> Query a
57+withBy :: (a -> b -> Expr Bool) -> Query b -> a -> Query a
58withBy predicate bs = with $ \a -> bs >>= filter (predicate a)
58withBy predicate bs = with $ \a -> bs >>= filter (predicate a)
59
59
60
60
src/Rel8/Type/Composite.hs+69−39
@@ -1,27 +1,27 @@
1+{-# language AllowAmbiguousTypes #-}
2+{-# language BlockArguments #-}
1{-# language DataKinds #-}
3{-# language DataKinds #-}
2{-# language FlexibleContexts #-}
4{-# language FlexibleContexts #-}
3{-# language GADTs #-}
5{-# language GADTs #-}
6+{-# language NamedFieldPuns #-}
4{-# language ScopedTypeVariables #-}
7{-# language ScopedTypeVariables #-}
5{-# language StandaloneKindSignatures #-}
8{-# language StandaloneKindSignatures #-}
6{-# language TypeApplications #-}
9{-# language TypeApplications #-}
7−{-# language TypeOperators #-}
8{-# language UndecidableInstances #-}
10{-# language UndecidableInstances #-}
11+{-# language UndecidableSuperClasses #-}
12+{-# language ViewPatterns #-}
9
13
10module Rel8.Type.Composite
14module Rel8.Type.Composite
11 ( Composite( Composite )
15 ( Composite( Composite )
16+ , DBComposite( compositeFields, compositeTypeName )
17+ , compose, decompose
12 )
18 )
13where
19where
14
20
15-- base
21-- base
16−import Control.Applicative ( liftA2 )
22+import Data.Functor.Const ( Const( Const ), getConst )
17import Data.Kind ( Constraint, Type )
23import Data.Kind ( Constraint, Type )
18−import Data.Proxy ( Proxy( Proxy ) )
24+import Prelude
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
25
26-- hasql
26-- hasql
27import qualified Hasql.Decoders as Hasql
27import qualified Hasql.Decoders as Hasql
@@ -30,55 +30,85 @@ import qualified Hasql.Decoders as Hasql
30import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
30import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
31
31
32-- rel8
32-- rel8
33+import Rel8.Expr ( Col( DB ), Expr )
34+import Rel8.Expr.Opaleye ( castExpr, fromPrimExpr, toPrimExpr )
35+import Rel8.Schema.HTable ( hfield, hspecs, htabulate, htabulateA )
36+import Rel8.Schema.Name ( Col( NameCol ), Name )
33−import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )
37+import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
38+import Rel8.Schema.Result ( Col( Result ), Result )
39+import Rel8.Schema.Spec ( SSpec( SSpec, nullity, info ) )
40+import Rel8.Table ( Table, fromColumns, toColumns )
41+import Rel8.Table.Eq ( EqTable )
42+import Rel8.Table.HKD ( HKD, HKDable, fromHKD, toHKD )
43+import Rel8.Table.Ord ( OrdTable )
44+import Rel8.Table.Rel8able ()
45+import Rel8.Table.Serialize ( lit )
34import Rel8.Type ( DBType, typeInformation )
46import Rel8.Type ( DBType, typeInformation )
47+import Rel8.Type.Eq ( DBEq )
35import Rel8.Type.Information ( TypeInformation(..) )
48import Rel8.Type.Information ( TypeInformation(..) )
49+import Rel8.Type.Ord ( DBOrd )
50+
51+-- semigroupoids
52+import Data.Functor.Apply ( WrappedApplicative(..) )
36
53
37
54
38-- | A deriving-via helper type for column types that store a Haskell product
55-- | 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.
56-- type in a single Postgres column using a Postgres composite type.
40--
57--
41-- Note that this must map to a specific extant type in your database's schema
58-- 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
59+-- (created with @CREATE TYPE@). Use 'DBComposite' to specify the name of this
43−-- the name of this type.
60+-- Postgres type and the names of the individual fields (for projecting with
61+-- 'decompose').
44−type Composite :: Symbol -> Type -> Type
62+type Composite :: Type -> Type
45−newtype Composite name a = Composite
63+newtype Composite a = Composite
46 { unComposite :: a
64 { unComposite :: a
47 }
65 }
48
66
49
67
50−instance (KnownSymbol name, Generic a, GComposite (Rep a)) =>
51− DBType (Composite name a)
68+instance DBComposite a => DBType (Composite a) where
52− where
53 typeInformation = TypeInformation
69 typeInformation = TypeInformation
54− { decode = Hasql.composite (Composite . to <$> gdecode @(Rep a))
70+ { decode = Hasql.composite (Composite . fromHKD <$> decoder)
55− , encode = Opaleye.FunExpr "ROW" . gencode @(Rep a) . from . unComposite
71+ , encode = encoder . lit . toColumns . toHKD . unComposite
56− , typeName = symbolVal (Proxy @name)
72+ , typeName = compositeTypeName @a
57 }
73 }
58
74
59
75
76+instance (DBComposite a, EqTable (HKD a Expr)) => DBEq (Composite a)
77+
78+
79+instance (DBComposite a, OrdTable (HKD a Expr)) => DBOrd (Composite a)
80+
81+
60−type GComposite :: (Type -> Type) -> Constraint
82+type DBComposite :: Type -> Constraint
61−class GComposite rep where
83+class (DBType a, HKDable a) => DBComposite a where
62− gdecode :: Hasql.Composite (rep x)
84+ compositeFields :: HKD a Name
63− gencode :: rep x -> [Opaleye.PrimExpr]
85+ compositeTypeName :: String
86+
87+
88+compose :: DBComposite a => HKD a Expr -> Expr a
89+compose = castExpr . fromPrimExpr . encoder
64
90
65
91
66−instance GComposite rep => GComposite (M1 i c rep) where
92+decompose :: forall a. DBComposite a => Expr a -> HKD a Expr
67− gdecode = M1 <$> gdecode
93+decompose (toPrimExpr -> a) = fromColumns $ htabulate \field ->
68− gencode (M1 a) = gencode a
94+ case hfield names field of
95+ NameCol name -> case hfield hspecs field of
96+ SSpec {} -> DB $ fromPrimExpr $ Opaleye.CompositeExpr a name
97+ where
98+ names = toColumns (compositeFields @a)
69
99
70
100
71−instance (GComposite a, GComposite b) => GComposite (a :*: b) where
101+decoder :: Table Result a => Hasql.Composite a
72− gdecode = liftA2 (:*:) gdecode gdecode
102+decoder = fmap fromColumns $ unwrapApplicative $ htabulateA \field ->
73− gencode (a :*: b) = gencode a <> gencode b
103+ case hfield hspecs field of
104+ SSpec {nullity, info} -> WrapApplicative $ Result <$>
105+ case nullity of
106+ Null -> Hasql.field $ Hasql.nullable $ decode info
107+ NotNull -> Hasql.field $ Hasql.nonNullable $ decode info
74
108
75
109
76−instance Sql DBType a => GComposite (K1 i a) where
110+encoder :: Table Expr a => a -> Opaleye.PrimExpr
77− gdecode = fmap K1 $ Hasql.field $ case nullable @a of
111+encoder (toColumns -> a) = Opaleye.FunExpr "ROW" exprs
78− Null -> Hasql.nullable (decode typeInformation)
112+ where
79− NotNull -> Hasql.nonNullable (decode typeInformation)
113+ exprs = getConst $ htabulateA \field -> case hfield a field of
80− gencode (K1 a) = case nullable @a of
114+ DB (toPrimExpr -> expr) -> Const [expr]
81− Null -> [maybe null (encode typeInformation) a]
82− NotNull -> [encode typeInformation a]
83− where
84− null = Opaleye.ConstExpr Opaleye.NullLit