git.iko.soy/rel8
on master help sign in
The guts of the new Generic construction machinery
2cdc394Shane O'Brien
rel8.cabal+2−1
compare with master
unifiedsplit
@@ -26,7 +26,6 @@ library
26 , these
26 , these
27 , time
27 , time
28 , uuid
28 , uuid
29− , lens, generic-lens
30 default-language:
29 default-language:
31 Haskell2010
30 Haskell2010
32 ghc-options:
31 ghc-options:
@@ -78,6 +77,8 @@ library
78 Rel8.Kind.Labels
77 Rel8.Kind.Labels
79 Rel8.Kind.Necessity
78 Rel8.Kind.Necessity
80
79
80+ Rel8.Generic.Construction.ADT
81+ Rel8.Generic.Construction.Record
81 Rel8.Generic.Map
82 Rel8.Generic.Map
82 Rel8.Generic.Record
83 Rel8.Generic.Record
83 Rel8.Generic.Reify
84 Rel8.Generic.Reify
src/Rel8/Generic/Construction/ADT.hsnew file+355
@@ -0,0 +1,355 @@
1+{-# language AllowAmbiguousTypes #-}
2+{-# language BlockArguments #-}
3+{-# language DataKinds #-}
4+{-# language FlexibleInstances #-}
5+{-# language MultiParamTypeClasses #-}
6+{-# language RankNTypes #-}
7+{-# language ScopedTypeVariables #-}
8+{-# language StandaloneKindSignatures #-}
9+{-# language TupleSections #-}
10+{-# language TypeApplications #-}
11+{-# language TypeFamilies #-}
12+{-# language TypeOperators #-}
13+{-# language UndecidableInstances #-}
14+
15+module Rel8.Generic.Construction.ADT
16+ ( GConstructable
17+ , GBuildADT, gbuildADT, gunbuildADT
18+ , GConstructADT, gconstructADT, gdeconstructADT
19+ , GFields, CorepFields, gftabulate, gfindex
20+ , GConstructors, CorepConstructors, gctabulate, gcindex
21+ )
22+where
23+
24+-- base
25+import Data.Bifunctor ( first )
26+import Data.Functor.Identity ( runIdentity )
27+import Data.Kind ( Constraint, Type )
28+import Data.List.NonEmpty ( NonEmpty )
29+import Data.Proxy ( Proxy( Proxy ) )
30+import GHC.Generics
31+ ( (:+:), (:*:)( (:*:) ), M1, U1
32+ , C, D
33+ , Meta( MetaCons )
34+ )
35+import GHC.TypeLits ( KnownSymbol, symbolVal )
36+import Prelude hiding ( null )
37+
38+-- rel8
39+import Rel8.FCF ( Exp )
40+import Rel8.Generic.Construction.Record
41+ ( GConstruct, GConstructable, gconstruct, gdeconstruct
42+ , GFields, Corep, gtabulate, gindex
43+ , FromColumns, ToColumns
44+ )
45+import Rel8.Generic.Table.ADT ( GColumnsADT, GColumnsADT' )
46+import Rel8.Generic.Table.Record ( GColumns )
47+import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler )
48+import Rel8.Schema.HTable ( HTable )
49+import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
50+import Rel8.Schema.HTable.Nullify ( HNullify, hnulls, hnullify, hunnullify )
51+import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )
52+import Rel8.Schema.HTable.Type ( HType )
53+import Rel8.Schema.Null ( Nullify )
54+import Rel8.Schema.Spec ( Spec( Spec ), SSpec )
55+import qualified Rel8.Schema.Kind as K
56+import Rel8.Type.Tag ( Tag( Tag ) )
57+
58+-- text
59+import Data.Text ( pack )
60+
61+
62+type Null :: K.HContext -> Type
63+type Null context = forall labels necessity a. ()
64+ => SSpec ('Spec labels necessity a)
65+ -> context ('Spec labels necessity (Nullify a))
66+
67+
68+type Nullifier :: K.HContext -> Type
69+type Nullifier context = forall labels necessity a. ()
70+ => SSpec ('Spec labels necessity a)
71+ -> context ('Spec labels necessity a)
72+ -> context ('Spec labels necessity (Nullify a))
73+
74+
75+type Unnullifier :: K.HContext -> Type
76+type Unnullifier context = forall labels necessity a. ()
77+ => SSpec ('Spec labels necessity a)
78+ -> context ('Spec labels necessity (Nullify a))
79+ -> context ('Spec labels necessity a)
80+
81+
82+type GConstructADT
83+ :: (Type -> Exp Type)
84+ -> (Type -> Type) -> Type -> Type -> Type
85+type family GConstructADT f rep r x where
86+ GConstructADT f (M1 D _ rep) r x = GConstructADT f rep r x
87+ GConstructADT f (a :+: b) r x = GConstructADT f a r (GConstructADT f b r x)
88+ GConstructADT f (M1 C _ rep) r x = GConstruct f rep r -> x
89+
90+
91+type GConstructors :: (Type -> Exp Type) -> (Type -> Type) -> Type -> Type
92+type family GConstructors f rep where
93+ GConstructors f (M1 D _ rep) = GConstructors f rep
94+ GConstructors f (a :+: b) = GConstructors f a :*: GConstructors f b
95+ GConstructors f (M1 C _ rep) = (->) (GFields f rep)
96+
97+
98+type CorepConstructors :: (Type -> Exp Type) -> (Type -> Type) -> Constraint
99+class CorepConstructors f rep where
100+ gctabulate :: (GConstructors f rep r -> a) -> GConstructADT f rep r a
101+ gcindex :: GConstructADT f rep r a -> GConstructors f rep r -> a
102+
103+
104+instance CorepConstructors f rep => CorepConstructors f (M1 D meta rep) where
105+ gctabulate = gctabulate @f @rep
106+ gcindex = gcindex @f @rep
107+
108+
109+instance (CorepConstructors f a, CorepConstructors f b) =>
110+ CorepConstructors f (a :+: b)
111+ where
112+ gctabulate f =
113+ gctabulate @f @a \a -> gctabulate @f @b \b -> f (a :*: b)
114+ gcindex f (a :*: b) = gcindex @f @b (gcindex @f @a f a) b
115+
116+
117+instance Corep f rep => CorepConstructors f (M1 C meta rep) where
118+ gctabulate f = f . gindex @f @rep
119+ gcindex f = f . gtabulate @f @rep
120+
121+
122+type GBuildADT :: (Type -> Exp Type) -> (Type -> Type) -> Type -> Type
123+type family GBuildADT f rep r where
124+ GBuildADT f (M1 D _ rep) r = GBuildADT f rep r
125+ GBuildADT f (a :+: b) r = GBuildADT f a (GBuildADT f b r)
126+ GBuildADT f (M1 C _ rep) r = GConstruct f rep r
127+
128+
129+type GFieldsADT :: (Type -> Exp Type) -> (Type -> Type) -> Type
130+type family GFieldsADT f rep where
131+ GFieldsADT f (M1 D _ rep) = GFieldsADT f rep
132+ GFieldsADT f (a :+: b) = (GFieldsADT f a, GFieldsADT f b)
133+ GFieldsADT f (M1 C _ rep) = GFields f rep
134+
135+
136+type CorepFields :: (Type -> Exp Type) -> (Type -> Type) -> Constraint
137+class CorepFields f rep where
138+ gftabulate :: (GFieldsADT f rep -> a) -> GBuildADT f rep a
139+ gfindex :: GBuildADT f rep a -> GFieldsADT f rep -> a
140+
141+
142+instance CorepFields f rep => CorepFields f (M1 D meta rep) where
143+ gftabulate = gftabulate @f @rep
144+ gfindex = gfindex @f @rep
145+
146+
147+instance (CorepFields f a, CorepFields f b) => CorepFields f (a :+: b)
148+ where
149+ gftabulate f =
150+ gftabulate @f @a \a -> gftabulate @f @b \b -> f (a, b)
151+ gfindex f (a, b) = gfindex @f @b (gfindex @f @a f a) b
152+
153+
154+instance Corep f rep => CorepFields f (M1 C meta rep) where
155+ gftabulate = gtabulate @f @rep
156+ gfindex = gindex @f @rep
157+
158+
159+type GConstructableADT
160+ :: (Type -> Exp Constraint)
161+ -> (Type -> Exp K.HTable)
162+ -> (Type -> Exp Type)
163+ -> K.HContext -> (Type -> Type) -> Constraint
164+class GConstructableADT _Table _Columns f context rep where
165+ gbuildADT :: ()
166+ => ToColumns _Table _Columns f context
167+ -> (Tag -> Nullifier context)
168+ -> HType Tag context
169+ -> GFieldsADT f rep
170+ -> GColumnsADT _Columns rep context
171+
172+ gunbuildADT :: ()
173+ => FromColumns _Table _Columns f context
174+ -> (Tag -> Unnullifier context)
175+ -> GColumnsADT _Columns rep context
176+ -> (HType Tag context, GFieldsADT f rep)
177+
178+ gconstructADT :: ()
179+ => ToColumns _Table _Columns f context
180+ -> Null context
181+ -> Nullifier context
182+ -> (Tag -> HType Tag context)
183+ -> GConstructors f rep (GColumnsADT _Columns rep context)
184+
185+ gdeconstructADT :: ()
186+ => FromColumns _Table _Columns f context
187+ -> (Tag -> Unnullifier context)
188+ -> GConstructors f rep r
189+ -> GColumnsADT _Columns rep context
190+ -> (HType Tag context, NonEmpty (Tag, r))
191+
192+
193+instance
194+ ( htable ~ HLabel "tag" (HType Tag)
195+ , GConstructableADT' _Table _Columns f context htable rep
196+ , HLabelable context
197+ )
198+ => GConstructableADT _Table _Columns f context (M1 D meta rep)
199+ where
200+ gbuildADT toColumns nullifier =
201+ gbuildADT' @_Table @_Columns @f @context @htable @rep toColumns nullifier .
202+ hlabel hlabeler
203+
204+ gunbuildADT fromColumns unnullifier =
205+ first (hunlabel hunlabeler) .
206+ gunbuildADT' @_Table @_Columns @f @context @htable @rep fromColumns unnullifier
207+
208+ gconstructADT toColumns null nullifier mk =
209+ gconstructADT' @_Table @_Columns @f @context @htable @rep toColumns null nullifier
210+ (hlabel hlabeler . mk)
211+
212+ gdeconstructADT fromColumns unnullifier cases =
213+ first (hunlabel hunlabeler) .
214+ gdeconstructADT' @_Table @_Columns @f @context @htable @rep fromColumns unnullifier cases
215+
216+
217+type GConstructableADT'
218+ :: (Type -> Exp Constraint)
219+ -> (Type -> Exp K.HTable)
220+ -> (Type -> Exp Type)
221+ -> K.HContext -> K.HTable -> (Type -> Type) -> Constraint
222+class GConstructableADT' _Table _Columns f context htable rep where
223+ gbuildADT' :: ()
224+ => ToColumns _Table _Columns f context
225+ -> (Tag -> Nullifier context)
226+ -> htable context
227+ -> GFieldsADT f rep
228+ -> GColumnsADT' _Columns htable rep context
229+
230+ gunbuildADT' :: ()
231+ => FromColumns _Table _Columns f context
232+ -> (Tag -> Unnullifier context)
233+ -> GColumnsADT' _Columns htable rep context
234+ -> (htable context, GFieldsADT f rep)
235+
236+ gconstructADT' :: ()
237+ => ToColumns _Table _Columns f context
238+ -> Null context
239+ -> Nullifier context
240+ -> (Tag -> htable context)
241+ -> GConstructors f rep (GColumnsADT' _Columns htable rep context)
242+
243+ gdeconstructADT' :: ()
244+ => FromColumns _Table _Columns f context
245+ -> (Tag -> Unnullifier context)
246+ -> GConstructors f rep r
247+ -> GColumnsADT' _Columns htable rep context
248+ -> (htable context, NonEmpty (Tag, r))
249+
250+ gfill :: ()
251+ => Null context
252+ -> htable context
253+ -> GColumnsADT' _Columns htable rep context
254+
255+
256+instance
257+ ( htable' ~ GColumnsADT' _Columns htable a
258+ , Functor (GConstructors f a)
259+ , GConstructableADT' _Table _Columns f context htable a
260+ , GConstructableADT' _Table _Columns f context htable' b
261+ )
262+ => GConstructableADT' _Table _Columns f context htable (a :+: b)
263+ where
264+ gbuildADT' toColumns nullifier htable (a, b) =
265+ gbuildADT' @_Table @_Columns @f @context @htable' @b toColumns nullifier
266+ (gbuildADT' @_Table @_Columns @f @context @htable @a toColumns nullifier htable a)
267+ b
268+
269+ gunbuildADT' fromColumns unnullifier columns =
270+ case gunbuildADT' @_Table @_Columns @f @context @htable' @b fromColumns unnullifier columns of
271+ (htable', b) ->
272+ case gunbuildADT' @_Table @_Columns @f @context @htable @a fromColumns unnullifier htable' of
273+ (htable, a) -> (htable, (a, b))
274+
275+ gconstructADT' toColumns null nullifier mk =
276+ fmap (gfill @_Table @_Columns @f @context @htable' @b null) (gconstructADT' @_Table @_Columns @f @context @htable @a toColumns null nullifier mk) :*:
277+ gconstructADT' @_Table @_Columns @f @context @htable' @b toColumns null nullifier (gfill @_Table @_Columns @f @context @htable @a null . mk)
278+
279+ gdeconstructADT' fromColumns unnullifier (a :*: b) columns =
280+ case gdeconstructADT' @_Table @_Columns @f @context @htable' @b fromColumns unnullifier b columns of
281+ (htable', cases) ->
282+ case gdeconstructADT' @_Table @_Columns @f @context @htable @a fromColumns unnullifier a htable' of
283+ (htable, cases') -> (htable, cases' <> cases)
284+
285+ gfill null =
286+ gfill @_Table @_Columns @f @context @htable' @b null .
287+ gfill @_Table @_Columns @f @context @htable @a null
288+
289+
290+instance (meta ~ 'MetaCons label _fixity _isRecord, KnownSymbol label) =>
291+ GConstructableADT' _Table _Columns f context htable (M1 C meta U1)
292+ where
293+ gbuildADT' _ _ = const
294+ gunbuildADT' _ _ = (, ())
295+ gconstructADT' _ _ _ f _ = f tag
296+ where
297+ tag = Tag $ pack $ symbolVal (Proxy @label)
298+ gdeconstructADT' _ _ r htable = (htable, pure (tag, r ()))
299+ where
300+ tag = Tag $ pack $ symbolVal (Proxy @label)
301+ gfill _ = id
302+
303+
304+instance {-# OVERLAPPABLE #-}
305+ ( HTable (GColumns _Columns rep)
306+ , KnownSymbol label
307+ , meta ~ 'MetaCons label _fixity _isRecord
308+ , HLabelable context
309+ , GConstructable _Table _Columns f context rep
310+ , GColumnsADT' _Columns htable (M1 C meta rep) ~
311+ HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))
312+ )
313+ => GConstructableADT' _Table _Columns f context htable (M1 C meta rep)
314+ where
315+ gbuildADT' toColumns nullifier htable =
316+ HProduct htable .
317+ hlabel hlabeler .
318+ hnullify (nullifier tag) .
319+ gconstruct @_Table @_Columns @f @context @rep toColumns
320+ where
321+ tag = Tag $ pack $ symbolVal (Proxy @label)
322+
323+ gunbuildADT' fromColumns unnullifier (HProduct htable a) =
324+ ( htable
325+ , gdeconstruct @_Table @_Columns @f @context @rep fromColumns $
326+ runIdentity $
327+ hunnullify (\spec -> pure . unnullifier tag spec) $
328+ hunlabel hunlabeler
329+ a
330+ )
331+ where
332+ tag = Tag $ pack $ symbolVal (Proxy @label)
333+
334+ gconstructADT' toColumns _ nullifier mk =
335+ HProduct htable .
336+ hlabel hlabeler .
337+ hnullify nullifier .
338+ gconstruct @_Table @_Columns @f @context @rep toColumns
339+ where
340+ tag = Tag $ pack $ symbolVal (Proxy @label)
341+ htable = mk tag
342+
343+ gdeconstructADT' fromColumns unnullifier r (HProduct htable columns) =
344+ ( htable
345+ , pure (tag, r a)
346+ )
347+ where
348+ a = gdeconstruct @_Table @_Columns @f @context @rep fromColumns $
349+ runIdentity $
350+ hunnullify (\spec -> pure . unnullifier tag spec) $
351+ hunlabel hunlabeler
352+ columns
353+ tag = Tag $ pack $ symbolVal (Proxy @label)
354+
355+ gfill null htable = HProduct htable (hlabel hlabeler (hnulls null))
src/Rel8/Generic/Construction/Record.hsnew file+160
@@ -0,0 +1,160 @@
1+{-# language AllowAmbiguousTypes #-}
2+{-# language BlockArguments #-}
3+{-# language DataKinds #-}
4+{-# language FlexibleInstances #-}
5+{-# language MultiParamTypeClasses #-}
6+{-# language RankNTypes #-}
7+{-# language ScopedTypeVariables #-}
8+{-# language StandaloneKindSignatures #-}
9+{-# language TypeApplications #-}
10+{-# language TypeFamilies #-}
11+{-# language TypeOperators #-}
12+{-# language UndecidableInstances #-}
13+
14+module Rel8.Generic.Construction.Record
15+ ( GConstruct, GConstructable, gconstruct, gdeconstruct
16+ , GFields, Corep, gtabulate, gindex
17+ , FromColumns, ToColumns
18+ )
19+where
20+
21+-- base
22+import Data.Kind ( Constraint, Type )
23+import Data.Proxy ( Proxy( Proxy ) )
24+import GHC.Generics
25+ ( (:*:), K1, M1, U1
26+ , D, C, S, Meta( MetaSel )
27+ )
28+import GHC.TypeLits ( KnownSymbol )
29+import Prelude
30+
31+-- rel8
32+import Rel8.FCF ( Eval, Exp )
33+import Rel8.Generic.Table.Record ( GColumns )
34+import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler )
35+import Rel8.Schema.HTable ( HTable )
36+import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
37+import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )
38+import qualified Rel8.Schema.Kind as K
39+
40+
41+type FromColumns
42+ :: (Type -> Exp Constraint)
43+ -> (Type -> Exp K.HTable)
44+ -> (Type -> Exp Type)
45+ -> K.HContext
46+ -> Type
47+type FromColumns _Table _Columns f context = forall proxy x.
48+ Eval (_Table x) => proxy x -> Eval (_Columns x) context -> Eval (f x)
49+
50+
51+type ToColumns
52+ :: (Type -> Exp Constraint)
53+ -> (Type -> Exp K.HTable)
54+ -> (Type -> Exp Type)
55+ -> K.HContext
56+ -> Type
57+type ToColumns _Table _Columns f context = forall proxy x.
58+ Eval (_Table x) => proxy x -> Eval (f x) -> Eval (_Columns x) context
59+
60+
61+type GConstruct :: (Type -> Exp Type) -> (Type -> Type) -> Type -> Type
62+type family GConstruct f rep r where
63+ GConstruct f (M1 _ _ rep) r = GConstruct f rep r
64+ GConstruct f (a :*: b) r = GConstruct f a (GConstruct f b r)
65+ GConstruct _ U1 r = r
66+ GConstruct f (K1 _ a) r = Eval (f a) -> r
67+
68+
69+type GFields :: (Type -> Exp Type) -> (Type -> Type) -> Type
70+type family GFields f rep where
71+ GFields f (M1 _ _ rep) = GFields f rep
72+ GFields f (a :*: b) = (GFields f a, GFields f b)
73+ GFields _ U1 = ()
74+ GFields f (K1 _ a) = Eval (f a)
75+
76+
77+type Corep :: (Type -> Exp Type) -> (Type -> Type) -> Constraint
78+class Corep f rep where
79+ gtabulate :: (GFields f rep -> a) -> GConstruct f rep a
80+ gindex :: GConstruct f rep a -> GFields f rep -> a
81+
82+
83+instance Corep f rep => Corep f (M1 i meta rep) where
84+ gtabulate = gtabulate @f @rep
85+ gindex = gindex @f @rep
86+
87+
88+instance (Corep f a, Corep f b) =>
89+ Corep f (a :*: b)
90+ where
91+ gtabulate f = gtabulate @f @a \a -> gtabulate @f @b \b -> f (a, b)
92+ gindex f (a, b) = gindex @f @b (gindex @f @a f a) b
93+
94+
95+instance Corep f U1 where
96+ gtabulate = ($ ())
97+ gindex = const
98+
99+
100+instance Corep f (K1 i a) where
101+ gtabulate = id
102+ gindex = id
103+
104+
105+type GConstructable
106+ :: (Type -> Exp Constraint)
107+ -> (Type -> Exp K.HTable)
108+ -> (Type -> Exp Type)
109+ -> K.HContext -> (Type -> Type) -> Constraint
110+class GConstructable _Table _Columns f context rep where
111+ gconstruct :: ()
112+ => ToColumns _Table _Columns f context
113+ -> GFields f rep
114+ -> GColumns _Columns rep context
115+ gdeconstruct :: ()
116+ => FromColumns _Table _Columns f context
117+ -> GColumns _Columns rep context
118+ -> GFields f rep
119+
120+
121+instance (GConstructable _Table _Columns f context rep) =>
122+ GConstructable _Table _Columns f context (M1 D meta rep)
123+ where
124+ gconstruct = gconstruct @_Table @_Columns @f @context @rep
125+ gdeconstruct = gdeconstruct @_Table @_Columns @f @context @rep
126+
127+
128+instance (GConstructable _Table _Columns f context rep) =>
129+ GConstructable _Table _Columns f context (M1 C meta rep)
130+ where
131+ gconstruct = gconstruct @_Table @_Columns @f @context @rep
132+ gdeconstruct = gdeconstruct @_Table @_Columns @f @context @rep
133+
134+
135+instance
136+ ( GConstructable _Table _Columns f context a
137+ , GConstructable _Table _Columns f context b
138+ )
139+ => GConstructable _Table _Columns f context (a :*: b)
140+ where
141+ gconstruct toColumns (a, b) = HProduct
142+ (gconstruct @_Table @_Columns @f @context @a toColumns a)
143+ (gconstruct @_Table @_Columns @f @context @b toColumns b)
144+ gdeconstruct fromColumns (HProduct a b) =
145+ ( gdeconstruct @_Table @_Columns @f @context @a fromColumns a
146+ , gdeconstruct @_Table @_Columns @f @context @b fromColumns b
147+ )
148+
149+
150+instance
151+ ( Eval (_Table a)
152+ , HTable (Eval (_Columns a))
153+ , HLabelable context
154+ , KnownSymbol label
155+ , meta ~ 'MetaSel ('Just label) _su _ss _ds
156+ )
157+ => GConstructable _Table _Columns f context (M1 S meta (K1 i a))
158+ where
159+ gconstruct toColumns = hlabel hlabeler . toColumns (Proxy @a)
160+ gdeconstruct fromColumns = fromColumns (Proxy @a) . hunlabel hunlabeler
src/Rel8/Generic/Table/ADT.hs+2−1
@@ -15,6 +15,7 @@
15
15
16module Rel8.Generic.Table.ADT
16module Rel8.Generic.Table.ADT
17 ( GTableADT, GColumnsADT, gfromColumnsADT, gtoColumnsADT, gtableADT
17 ( GTableADT, GColumnsADT, gfromColumnsADT, gtoColumnsADT, gtableADT
18+ , GTableADT', GColumnsADT'
18 , GToExprsADT, gfromResultADT, gtoResultADT
19 , GToExprsADT, gfromResultADT, gtoResultADT
19 )
20 )
20where
21where
@@ -347,7 +348,7 @@ instance {-# OVERLAPPABLE #-}
347 tag' = Tag $ pack $ symbolVal (Proxy @label)
348 tag' = Tag $ pack $ symbolVal (Proxy @label)
348
349
349 gtoResultADT' toResult tag = \case
350 gtoResultADT' toResult tag = \case
350− Nothing -> HProduct (tag tag') (hlabel labeler (hnulls null))
351+ Nothing -> HProduct (tag tag') (hlabel labeler (hnulls (const null)))
351 Just (M1 rep) -> HProduct (tag tag') $
352 Just (M1 rep) -> HProduct (tag tag') $
352 hlabel labeler $
353 hlabel labeler $
353 hnullify nullifier $
354 hnullify nullifier $
src/Rel8/Schema/HTable/Nullify.hs+3−2
@@ -68,10 +68,11 @@ instance MapSpec Nullify where
68
68
69hnulls :: HTable t
69hnulls :: HTable t
70 => (forall labels necessity a. ()
70 => (forall labels necessity a. ()
71+ => SSpec ('Spec labels necessity a)
71− => context ('Spec labels necessity (Maybe a)))
72+ -> context ('Spec labels necessity (Type.Nullify a)))
72 -> HNullify t context
73 -> HNullify t context
73hnulls null = HNullify $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of
74hnulls null = HNullify $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of
74− SSpec {} -> null
75+ spec@SSpec {} -> null spec
75{-# INLINABLE hnulls #-}
76{-# INLINABLE hnulls #-}
76
77
77
78
src/Rel8/Table.hs+3−3
@@ -250,11 +250,11 @@ instance (Table Result a, Table Result b) => Table Result (Either a b) where
250 Left table -> HEitherTable
250 Left table -> HEitherTable
251 { htag = HIdentity (Result IsLeft)
251 { htag = HIdentity (Result IsLeft)
252 , hleft = hlabel labeler (hnullify nullifier (toColumns table))
252 , hleft = hlabel labeler (hnullify nullifier (toColumns table))
253− , hright = hlabel labeler (hnulls null)
253+ , hright = hlabel labeler (hnulls (const null))
254 }
254 }
255 Right table -> HEitherTable
255 Right table -> HEitherTable
256 { htag = HIdentity (Result IsRight)
256 { htag = HIdentity (Result IsRight)
257− , hleft = hlabel labeler (hnulls null)
257+ , hleft = hlabel labeler (hnulls (const null))
258 , hright = hlabel labeler (hnullify nullifier (toColumns table))
258 , hright = hlabel labeler (hnullify nullifier (toColumns table))
259 }
259 }
260
260
@@ -281,7 +281,7 @@ instance Table Result a => Table Result (Maybe a) where
281 toColumns = \case
281 toColumns = \case
282 Nothing -> HMaybeTable
282 Nothing -> HMaybeTable
283 { htag = HIdentity (Result Nothing)
283 { htag = HIdentity (Result Nothing)
284− , hjust = hlabel labeler (hnulls null)
284+ , hjust = hlabel labeler (hnulls (const null))
285 }
285 }
286 Just table -> HMaybeTable
286 Just table -> HMaybeTable
287 { htag = HIdentity (Result (Just IsJust))
287 { htag = HIdentity (Result (Just IsJust))