git.iko.soy/rel8
on 29cdfdb help sign in
rel8/src/Rel8/Type/Composite.hs
135 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.Functor.Identity ( Identity( Identity ) )
24import Data.Kind ( Constraint, Type )
25import Prelude
27-- hasql
28import qualified Hasql.Decoders as Hasql
30-- opaleye
31import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
33-- rel8
34import Rel8.Expr ( Expr )
35import Rel8.Expr.Opaleye ( castExpr, fromPrimExpr, toPrimExpr )
36import Rel8.Schema.HTable ( HTable, hfield, hspecs, htabulate, htabulateA )
37import Rel8.Schema.Name ( Name( Name ) )
38import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
39import Rel8.Schema.Result ( Result )
40import Rel8.Schema.Spec ( Spec( Spec, nullity, info ) )
41import Rel8.Table ( fromColumns, toColumns, fromResult, toResult )
42import Rel8.Table.Eq ( EqTable )
43import Rel8.Table.HKD ( HKD, HKDable )
44import Rel8.Table.Ord ( OrdTable )
45import Rel8.Table.Rel8able ()
46import Rel8.Table.Serialize ( litHTable )
47import Rel8.Type ( DBType, typeInformation )
48import Rel8.Type.Eq ( DBEq )
49import Rel8.Type.Information ( TypeInformation(..) )
50import Rel8.Type.Ord ( DBOrd, DBMax, DBMin )
52-- semigroupoids
53import Data.Functor.Apply ( WrappedApplicative(..) )
56-- | A deriving-via helper type for column types that store a Haskell product
57-- type in a single Postgres column using a Postgres composite type.
58--
59-- Note that this must map to a specific extant type in your database's schema
60-- (created with @CREATE TYPE@). Use 'DBComposite' to specify the name of this
61-- Postgres type and the names of the individual fields (for projecting with
62-- 'decompose').
63type Composite :: Type -> Type
64newtype Composite a = Composite
65 { unComposite :: a
66 }
69instance DBComposite a => DBType (Composite a) where
70 typeInformation = TypeInformation
71 { decode = Hasql.composite (Composite . fromResult @_ @(HKD a Expr) <$> decoder)
72 , encode = encoder . litHTable . toResult @_ @(HKD a Expr) . unComposite
73 , typeName = compositeTypeName @a
74 }
77instance (DBComposite a, EqTable (HKD a Expr)) => DBEq (Composite a)
80instance (DBComposite a, OrdTable (HKD a Expr)) => DBOrd (Composite a)
83instance (DBComposite a, OrdTable (HKD a Expr)) => DBMax (Composite a)
86instance (DBComposite a, OrdTable (HKD a Expr)) => DBMin (Composite a)
89-- | 'DBComposite' is used to associate composite type metadata with a Haskell
90-- type.
91type DBComposite :: Type -> Constraint
92class (DBType a, HKDable a) => DBComposite a where
93 -- | The names of all fields in the composite type that @a@ maps to.
94 compositeFields :: HKD a Name
96 -- | The name of the composite type that @a@ maps to.
97 compositeTypeName :: String
100-- | Collapse a 'HKD' into a PostgreSQL composite type.
101--
102-- 'HKD' values are represented in queries by having a column for each field in
103-- the corresponding Haskell type. 'compose' collapses these columns into a
104-- single column expression, by combining them into a PostgreSQL composite
105-- type.
106compose :: DBComposite a => HKD a Expr -> Expr a
107compose = castExpr . fromPrimExpr . encoder . toColumns
110-- | Expand a composite type into a 'HKD'.
111--
112-- 'decompose' is the inverse of 'compose'.
113decompose :: forall a. DBComposite a => Expr a -> HKD a Expr
114decompose (toPrimExpr -> a) = fromColumns $ htabulate \field ->
115 case hfield names field of
116 Name name -> case hfield hspecs field of
117 Spec {} -> fromPrimExpr $ Opaleye.CompositeExpr a name
118 where
119 names = toColumns (compositeFields @a)
122decoder :: HTable t => Hasql.Composite (t Result)
123decoder = unwrapApplicative $ htabulateA \field ->
124 case hfield hspecs field of
125 Spec {nullity, info} -> WrapApplicative $ Identity <$>
126 case nullity of
127 Null -> Hasql.field $ Hasql.nullable $ decode info
128 NotNull -> Hasql.field $ Hasql.nonNullable $ decode info
131encoder :: HTable t => t Expr -> Opaleye.PrimExpr
132encoder a = Opaleye.FunExpr "ROW" exprs
133 where
134 exprs = getConst $ htabulateA \field -> case hfield a field of
135 expr -> Const [toPrimExpr expr]