@@ -1,27 +1,27 @@
1+{-# language AllowAmbiguousTypes #-}
2+{-# language BlockArguments #-}
13{-# language DataKinds #-}
24{-# language FlexibleContexts #-}
35{-# language GADTs #-}
6+{-# language NamedFieldPuns #-}
47{-# language ScopedTypeVariables #-}
58{-# language StandaloneKindSignatures #-}
69{-# language TypeApplications #-}
7−{-# language TypeOperators #-}
810{-# language UndecidableInstances #-}
11+{-# language UndecidableSuperClasses #-}
12+{-# language ViewPatterns #-}
913
1014module Rel8.Type.Composite
1115 ( Composite( Composite )
16+ , DBComposite( compositeFields, compositeTypeName )
17+ , compose, decompose
1218 )
1319where
1420
1521-- base
16−import Control.Applicative ( liftA2 )
22+import Data.Functor.Const ( Const( Const ), getConst )
1723import 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 )
24+import Prelude
2525
2626-- hasql
2727import qualified Hasql.Decoders as Hasql
@@ -30,55 +30,85 @@ import qualified Hasql.Decoders as Hasql
3030import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
3131
3232-- rel8
33−import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )
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 )
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 )
3446import Rel8.Type ( DBType, typeInformation )
47+import Rel8.Type.Eq ( DBEq )
3548import Rel8.Type.Information ( TypeInformation(..) )
49+import Rel8.Type.Ord ( DBOrd )
50+
51+-- semigroupoids
52+import Data.Functor.Apply ( WrappedApplicative(..) )
3653
3754
3855-- | A deriving-via helper type for column types that store a Haskell product
3956-- type in a single Postgres column using a Postgres composite type.
4057--
4158-- 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
59+-- (created with @CREATE TYPE@). Use 'DBComposite' to specify the name of this
60+-- Postgres type and the names of the individual fields (for projecting with
61+-- 'decompose').
62+type Composite :: Type -> Type
63+newtype Composite a = Composite
4664 { unComposite :: a
4765 }
4866
4967
50−instance (KnownSymbol name, Generic a, GComposite (Rep a)) =>
51− DBType (Composite name a)
52− where
68+instance DBComposite a => DBType (Composite a) where
5369 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)
70+ { decode = Hasql.composite (Composite . fromHKD <$> decoder)
71+ , encode = encoder . lit . toColumns . toHKD . unComposite
72+ , typeName = compositeTypeName @a
5773 }
5874
5975
60−type GComposite :: (Type -> Type) -> Constraint
61−class GComposite rep where
62− gdecode :: Hasql.Composite (rep x)
63− gencode :: rep x -> [Opaleye.PrimExpr]
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+
82+type DBComposite :: Type -> Constraint
83+class (DBType a, HKDable a) => DBComposite a where
84+ compositeFields :: HKD a Name
85+ compositeTypeName :: String
86+
87+
88+compose :: DBComposite a => HKD a Expr -> Expr a
89+compose = castExpr . fromPrimExpr . encoder
6490
6591
66−instance GComposite rep => GComposite (M1 i c rep) where
67− gdecode = M1 <$> gdecode
68− gencode (M1 a) = gencode a
92+decompose :: forall a. DBComposite a => Expr a -> HKD a Expr
93+decompose (toPrimExpr -> a) = fromColumns $ htabulate \field ->
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)
6999
70100
71−instance (GComposite a, GComposite b) => GComposite (a :*: b) where
72− gdecode = liftA2 (:*:) gdecode gdecode
73− gencode (a :*: b) = gencode a <> gencode b
101+decoder :: Table Result a => Hasql.Composite a
102+decoder = fmap fromColumns $ unwrapApplicative $ htabulateA \field ->
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
74108
75109
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
110+encoder :: Table Expr a => a -> Opaleye.PrimExpr
111+encoder (toColumns -> a) = Opaleye.FunExpr "ROW" exprs
112+ where
113+ exprs = getConst $ htabulateA \field -> case hfield a field of
114+ DB (toPrimExpr -> expr) -> Const [expr]