git.iko.soy/rel8
on 97d89cf help sign in
rel8/src/Rel8/Type/Composite.hs
134 lines 4.5 kB history raw
1{-# language AllowAmbiguousTypes #-}
2{-# language BlockArguments #-}
3{-# language DataKinds #-}
4{-# language FlexibleContexts #-}
5{-# language GADTs #-}
6{-# language NamedFieldPuns #-}
7{-# language ScopedTypeVariables #-}
8{-# language StandaloneKindSignatures #-}
9{-# language TypeApplications #-}
10{-# language UndecidableInstances #-}
11{-# language UndecidableSuperClasses #-}
12{-# language ViewPatterns #-}
14module Rel8.Type.Composite
15 ( Composite( Composite )
16 , DBComposite( compositeFields, compositeTypeName )
17 , compose, decompose
18 )
19where
21-- base
22import Data.Functor.Const ( Const( Const ), getConst )
23import Data.Kind ( Constraint, Type )
24import Prelude
26-- hasql
27import qualified Hasql.Decoders as Hasql
29-- opaleye
30import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
32-- rel8
33import Rel8.Expr ( Expr( E ) )
34import Rel8.Expr.Opaleye ( castExpr, fromPrimExpr, toPrimExpr )
35import Rel8.Schema.HTable ( HTable, hfield, hspecs, htabulate, htabulateA )
36import Rel8.Schema.Name ( Name( N, Name ) )
37import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
38import Rel8.Schema.Result ( Result( R ) )
39import Rel8.Schema.Spec ( SSpec( SSpec, nullity, info ) )
40import Rel8.Table ( fromColumns, toColumns, fromResult, toResult )
41import Rel8.Table.Eq ( EqTable )
42import Rel8.Table.HKD ( HKD, HKDable )
43import Rel8.Table.Ord ( OrdTable )
44import Rel8.Table.Rel8able ()
45import Rel8.Table.Serialize ( litHTable )
46import Rel8.Type ( DBType, typeInformation )
47import Rel8.Type.Eq ( DBEq )
48import Rel8.Type.Information ( TypeInformation(..) )
49import Rel8.Type.Ord ( DBOrd, DBMax, DBMin )
51-- semigroupoids
52import Data.Functor.Apply ( WrappedApplicative(..) )
55-- | A deriving-via helper type for column types that store a Haskell product
56-- type in a single Postgres column using a Postgres composite type.
57--
58-- Note that this must map to a specific extant type in your database's schema
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').
62type Composite :: Type -> Type
63newtype Composite a = Composite
64 { unComposite :: a
65 }
68instance DBComposite a => DBType (Composite a) where
69 typeInformation = TypeInformation
70 { decode = Hasql.composite (Composite . fromResult @_ @(HKD a Expr) <$> decoder)
71 , encode = encoder . litHTable . toResult @_ @(HKD a Expr) . unComposite
72 , typeName = compositeTypeName @a
73 }
76instance (DBComposite a, EqTable (HKD a Expr)) => DBEq (Composite a)
79instance (DBComposite a, OrdTable (HKD a Expr)) => DBOrd (Composite a)
82instance (DBComposite a, OrdTable (HKD a Expr)) => DBMax (Composite a)
85instance (DBComposite a, OrdTable (HKD a Expr)) => DBMin (Composite a)
88-- | 'DBComposite' is used to associate composite type metadata with a Haskell
89-- type.
90type DBComposite :: Type -> Constraint
91class (DBType a, HKDable a) => DBComposite a where
92 -- | The names of all fields in the composite type that @a@ maps to.
93 compositeFields :: HKD a Name
95 -- | The name of the composite type that @a@ maps to.
96 compositeTypeName :: String
99-- | Collapse a 'HKD' into a PostgreSQL composite type.
100--
101-- 'HKD' values are represented in queries by having a column for each field in
102-- the corresponding Haskell type. 'compose' collapses these columns into a
103-- single column expression, by combining them into a PostgreSQL composite
104-- type.
105compose :: DBComposite a => HKD a Expr -> Expr a
106compose = castExpr . fromPrimExpr . encoder . toColumns
109-- | Expand a composite type into a 'HKD'.
110--
111-- 'decompose' is the inverse of 'compose'.
112decompose :: forall a. DBComposite a => Expr a -> HKD a Expr
113decompose (toPrimExpr -> a) = fromColumns $ htabulate \field ->
114 case hfield names field of
115 N (Name name) -> case hfield hspecs field of
116 SSpec {} -> E $ fromPrimExpr $ Opaleye.CompositeExpr a name
117 where
118 names = toColumns (compositeFields @a)
121decoder :: HTable t => Hasql.Composite (t Result)
122decoder = unwrapApplicative $ htabulateA \field ->
123 case hfield hspecs field of
124 SSpec {nullity, info} -> WrapApplicative $ R <$>
125 case nullity of
126 Null -> Hasql.field $ Hasql.nullable $ decode info
127 NotNull -> Hasql.field $ Hasql.nonNullable $ decode info
130encoder :: HTable t => t Expr -> Opaleye.PrimExpr
131encoder a = Opaleye.FunExpr "ROW" exprs
132 where
133 exprs = getConst $ htabulateA \field -> case hfield a field of
134 E (toPrimExpr -> expr) -> Const [expr]