git.iko.soy/rel8
on 04e24ae help sign in
rel8/src/Rel8/Schema/Generic.hs
1062 lines 36 kB history raw
1{-# language AllowAmbiguousTypes #-}
2{-# language DataKinds #-}
3{-# language DisambiguateRecordFields #-}
4{-# language DefaultSignatures #-}
5{-# language FlexibleContexts #-}
6{-# language FlexibleInstances #-}
7{-# language GADTs #-}
8{-# language MultiParamTypeClasses #-}
9{-# language ScopedTypeVariables #-}
10{-# language StandaloneKindSignatures #-}
11{-# language TypeApplications #-}
12{-# language TypeFamilies #-}
13{-# language TypeOperators #-}
14{-# language UndecidableInstances #-}
15{-# language ViewPatterns #-}
17{-# options_ghc -fno-warn-orphans #-}
19module Rel8.Schema.Generic
20 ( Rel8able
21 )
22where
24-- base
25import Data.Bifunctor ( bimap )
26import Data.Functor.Identity ( Identity )
27import Data.Kind ( Constraint, Type )
28import Data.List.NonEmpty ( NonEmpty )
29import GHC.Generics
30 ( Generic, Rep, from, to
31 , (:*:)( (:*:) ), K1( K1 ), M1( M1 )
32 , D, C, S
33 , Meta( MetaSel )
34 )
35import GHC.TypeLits ( Symbol )
36import Prelude
38-- rel8
39import Rel8.Aggregate ( Aggregate )
40import Rel8.Expr ( Expr )
41import Rel8.Kind.Necessity
42 ( SNecessity( SRequired, SOptional )
43 , KnownNecessity, necessitySing
44 )
45import Rel8.Schema.Context
46import Rel8.Schema.Context.Identity
47 ( fromHEitherTable, toHEitherTable
48 , fromHListTable, toHListTable
49 , fromHMaybeTable, toHMaybeTable
50 , fromHNonEmptyTable, toHNonEmptyTable
51 , fromHTheseTable, toHTheseTable
52 )
53import Rel8.Schema.Context.Label
54 ( Labelable, labeler, unlabeler
55 , hlabeler, hunlabeler
56 )
57import Rel8.Schema.Context.Nullify ( Nullifiable )
58import Rel8.Schema.Field ( Field )
59import Rel8.Schema.HTable ( HTable )
60import Rel8.Schema.HTable.Either ( HEitherTable )
61import Rel8.Schema.HTable.Identity ( HIdentity(..) )
62import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
63import Rel8.Schema.HTable.List ( HListTable )
64import Rel8.Schema.HTable.Maybe ( HMaybeTable )
65import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
66import Rel8.Schema.HTable.Pair ( HPair(..) )
67import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
68import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
69import Rel8.Schema.HTable.These ( HTheseTable )
70import Rel8.Schema.HTable.Trio ( HTrio(..) )
71import Rel8.Schema.HTable.Vectorize ( hrelabel )
72import qualified Rel8.Schema.Kind as K
73import Rel8.Schema.Spec ( Spec( Spec ), KTable )
74import Rel8.Schema.Structure
75 ( IsStructure, Shape(..), Shape1, Shape2
76 , Structure
77 )
78import Rel8.Table
79 ( Table, Columns, Context, fromColumns, toColumns
80 )
81import Rel8.Table.Either ( EitherTable )
82import Rel8.Table.Lifted
83 ( fromColumns1, toColumns1
84 , fromColumns2, toColumns2
85 )
86import Rel8.Table.List ( ListTable )
87import Rel8.Table.Maybe ( MaybeTable(..) )
88import Rel8.Table.NonEmpty ( NonEmptyTable )
89import Rel8.Table.These ( TheseTable )
91-- these
92import Data.These ( These )
95instance (Rel8able t, TableHelper (IsSpecialContext context) context) =>
96 Table context (t context)
97 where
98 type Columns (t context) = GRep t
99 type Context (t context) = context
100 fromColumns = gfromColumns
101 toColumns = gtoColumns
104type TableHelper :: Bool -> K.Context -> Constraint
105class IsSpecialContext context ~ isSpecialContext =>
106 TableHelper isSpecialContext context
107 where
108 gfromColumns :: Rel8able t => GRep t (Col context) -> t context
109 gtoColumns :: Rel8able t => t context -> GRep t (Col context)
112instance TableHelper 'True Aggregate where
113 gfromColumns = fromAggregateColumns
114 gtoColumns = toAggregateColumns
117instance TableHelper 'True Expr where
118 gfromColumns = fromExprColumns
119 gtoColumns = toExprColumns
122instance TableHelper 'True Insertion where
123 gfromColumns = fromInsertionColumns
124 gtoColumns = toInsertionColumns
127instance TableHelper 'True Identity where
128 gfromColumns = fromIdentityColumns
129 gtoColumns = toIdentityColumns
132instance (IsSpecialContext context ~ 'False, Labelable context, Nullifiable context) =>
133 TableHelper 'False context
134 where
135 gfromColumns = fromUnspecialColumns
136 gtoColumns = toUnspecialColumns
139-- | This type class allows you to define custom 'Table's using higher-kinded
140-- data types. Higher-kinded data types are data types of the pattern:
141--
142-- @
143-- data MyType f =
144-- MyType { field1 :: Column f T1 OR HK1 f
145-- , field2 :: Column f T2 OR HK2 f
146-- , ...
147-- , fieldN :: Column f Tn OR HKn f
148-- }
149-- @
150--
151-- where @Tn@ is any Haskell type, and @HKn@ is any higher-kinded type.
152--
153-- That is, higher-kinded data are records where all fields in the record are
154-- all either of the type @Column f T@ (for any @T@), or are themselves
155-- higher-kinded data:
156--
157-- [Nested]
158--
159-- @
160-- data Nested f =
161-- Nested { nested1 :: MyType f
162-- , nested2 :: MyType f
163-- }
164-- @
165--
166-- The @Rel8able@ type class is used to give us a special mapping operation
167-- that lets us change the type parameter @f@.
168--
169-- [Supplying @Rel8able@ instances]
170--
171-- This type class should be derived generically for all table types in your
172-- project. To do this, enable the @DeriveAnyType@ and @DeriveGeneric@ language
173-- extensions:
174--
175-- @
176-- \{\-\# LANGUAGE DeriveAnyClass, DeriveGeneric #-\}
177--
178-- data MyType f = MyType { fieldA :: Column f T }
179-- deriving ( GHC.Generics.Generic, Rel8able )
180-- @
181type Rel8able :: KTable -> Constraint
182class HTable (GRep t) => Rel8able t where
183 type GRep t :: K.HTable
185 fromAggregateColumns :: GRep t (Col Aggregate) -> t Aggregate
186 toAggregateColumns :: t Aggregate -> GRep t (Col Aggregate)
188 fromExprColumns :: GRep t (Col Expr) -> t Expr
189 toExprColumns :: t Expr -> GRep t (Col Expr)
191 fromInsertionColumns :: GRep t (Col Insertion) -> t Insertion
192 toInsertionColumns :: t Insertion -> GRep t (Col Insertion)
194 fromIdentityColumns :: GRep t (Col Identity) -> t Identity
195 toIdentityColumns :: t Identity -> GRep t (Col Identity)
197 fromUnspecialColumns ::
198 ( IsSpecialContext context ~ 'False
199 , Labelable context, Nullifiable context
200 )
201 => GRep t (Col context) -> t context
202 toUnspecialColumns ::
203 ( IsSpecialContext context ~ 'False
204 , Labelable context, Nullifiable context
205 )
206 => t context -> GRep t (Col context)
208 type GRep t = GColumns (Rep (t Structure))
210 default fromAggregateColumns ::
211 ( Generic (t Aggregate)
212 , GColumns (Rep (t Structure)) ~ GRep t
213 , GRel8able Aggregate (Rep (t Structure)) (Rep (t Aggregate))
214 ) => GRep t (Col Aggregate) -> t Aggregate
215 fromAggregateColumns = to . fromGColumns @_ @(Rep (t Structure))
217 default toAggregateColumns ::
218 ( Generic (t Aggregate)
219 , GColumns (Rep (t Structure)) ~ GRep t
220 , GRel8able Aggregate (Rep (t Structure)) (Rep (t Aggregate))
221 ) => t Aggregate -> GRep t (Col Aggregate)
222 toAggregateColumns = toGColumns @_ @(Rep (t Structure)) . from
224 default fromExprColumns ::
225 ( Generic (t Expr)
226 , GColumns (Rep (t Structure)) ~ GRep t
227 , GRel8able Expr (Rep (t Structure)) (Rep (t Expr))
228 ) => GRep t (Col Expr) -> t Expr
229 fromExprColumns = to . fromGColumns @_ @(Rep (t Structure))
231 default toExprColumns ::
232 ( Generic (t Expr)
233 , GColumns (Rep (t Structure)) ~ GRep t
234 , GRel8able Expr (Rep (t Structure)) (Rep (t Expr))
235 ) => t Expr -> GRep t (Col Expr)
236 toExprColumns = toGColumns @_ @(Rep (t Structure)) . from
238 default fromInsertionColumns ::
239 ( Generic (t Insertion)
240 , GColumns (Rep (t Structure)) ~ GRep t
241 , GRel8able Insertion (Rep (t Structure)) (Rep (t Insertion))
242 ) => GRep t (Col Insertion) -> t Insertion
243 fromInsertionColumns = to . fromGColumns @_ @(Rep (t Structure))
245 default toInsertionColumns ::
246 ( Generic (t Insertion)
247 , GColumns (Rep (t Structure)) ~ GRep t
248 , GRel8able Insertion (Rep (t Structure)) (Rep (t Insertion))
249 ) => t Insertion -> GRep t (Col Insertion)
250 toInsertionColumns = toGColumns @_ @(Rep (t Structure)) . from
252 default fromIdentityColumns ::
253 ( Generic (t Identity)
254 , GColumns (Rep (t Structure)) ~ GRep t
255 , GRel8able Identity (Rep (t Structure)) (Rep (t Identity))
256 ) => GRep t (Col Identity) -> t Identity
257 fromIdentityColumns = to . fromGColumns @_ @(Rep (t Structure))
259 default toIdentityColumns ::
260 ( Generic (t Identity)
261 , GColumns (Rep (t Structure)) ~ GRep t
262 , GRel8able Identity (Rep (t Structure)) (Rep (t Identity))
263 ) => t Identity -> GRep t (Col Identity)
264 toIdentityColumns = toGColumns @_ @(Rep (t Structure)) . from
266 default fromUnspecialColumns ::
267 ( Generic (t context)
268 , GColumns (Rep (t Structure)) ~ GRep t
269 , GRel8able context (Rep (t Structure)) (Rep (t context))
270 ) => GRep t (Col context) -> t context
271 fromUnspecialColumns = to . fromGColumns @_ @(Rep (t Structure))
273 default toUnspecialColumns ::
274 ( Generic (t context)
275 , GColumns (Rep (t Structure)) ~ GRep t
276 , GRel8able context (Rep (t Structure)) (Rep (t context))
277 ) => t context -> GRep t (Col context)
278 toUnspecialColumns = toGColumns @_ @(Rep (t Structure)) . from
281type GColumns :: (Type -> Type) -> K.HTable
282type family GColumns structure where
283 GColumns (M1 D _ structure) = GColumns structure
284 GColumns (M1 C _ structure) = GColumns structure
285 GColumns (a :*: b) = HPair (GColumns a) (GColumns b)
286 GColumns (M1 S ('MetaSel ('Just label) _ _ _) (K1 _ structure)) =
287 K1Columns label structure
290type GRel8able :: K.Context -> (Type -> Type) -> (Type -> Type) -> Constraint
291class GRel8able context structure rep where
292 fromGColumns :: GColumns structure (Col context) -> rep x
293 toGColumns :: rep x -> GColumns structure (Col context)
296instance GRel8able context structure rep => GRel8able context (M1 D c structure) (M1 D c rep) where
297 fromGColumns = M1 . fromGColumns @context @structure @rep
298 toGColumns (M1 a) = toGColumns @context @structure @rep a
301instance GRel8able context structure rep => GRel8able context (M1 C c structure) (M1 C c rep) where
302 fromGColumns = M1 . fromGColumns @context @structure @rep
303 toGColumns (M1 a) = toGColumns @context @structure @rep a
306instance (GRel8able context structure1 rep1, GRel8able context structure2 rep2) =>
307 GRel8able context (structure1 :*: structure2) (rep1 :*: rep2)
308 where
309 fromGColumns (HPair a b) =
310 fromGColumns @context @structure1 @rep1 a :*:
311 fromGColumns @context @structure2 @rep2 b
312 toGColumns (a :*: b) =
313 HPair
314 (toGColumns @context @structure1 @rep1 a)
315 (toGColumns @context @structure2 @rep2 b)
318instance
319 ( K1Table label isSpecialContext context isStructure structure a
320 , meta ~ 'MetaSel ('Just label) _su _ss _ds
321 , structureK1 ~ K1 i structure
322 , k1 ~ K1 i a
323 ) => GRel8able context (M1 S meta structureK1) (M1 S meta k1)
324 where
325 fromGColumns = M1 . K1 . fromK1Columns @label @_ @_ @_ @structure
326 toGColumns (M1 (K1 a)) = toK1Columns @label @_ @_ @_ @structure a
329type K1Columns :: Symbol -> Type -> K.HTable
330type family K1Columns label structure where
331 K1Columns label (Shape1 'Column ('Spec '[] necessity nullability blueprint)) =
332 HIdentity ('Spec '[label] necessity nullability blueprint)
333 K1Columns _label (Shape1 'Column ('Spec (label ': labels) necessity nullability blueprint)) =
334 HIdentity ('Spec (label ': labels) necessity nullability blueprint)
335 K1Columns label (Shape2 'Either a b) =
336 HLabel label (HEitherTable (K1Columns "Left" a) (K1Columns "Right" b))
337 K1Columns label (Shape1 'List a) = HListTable (K1Columns label a)
338 K1Columns label (Shape1 'Maybe a) = HLabel label (HMaybeTable (K1Columns "Just" a))
339 K1Columns label (Shape1 'NonEmpty a) = HNonEmptyTable (K1Columns label a)
340 K1Columns label (Shape2 'These a b) =
341 HLabel label (HTheseTable (K1Columns "Here" a) (K1Columns "There" b))
342 K1Columns label (a, b) =
343 HLabel label
344 (HPair
345 (K1Columns "fst" a)
346 (K1Columns "snd" b))
347 K1Columns label (a, b, c) =
348 HLabel label
349 (HTrio
350 (K1Columns "fst" a)
351 (K1Columns "snd" b)
352 (K1Columns "trd" c))
353 K1Columns label (a, b, c, d) =
354 HLabel label
355 (HQuartet
356 (K1Columns "fst" a)
357 (K1Columns "snd" b)
358 (K1Columns "trd" c)
359 (K1Columns "frt" d))
360 K1Columns label (a, b, c, d, e) =
361 HLabel label
362 (HQuintet
363 (K1Columns "fst" a)
364 (K1Columns "snd" b)
365 (K1Columns "trd" c)
366 (K1Columns "frt" d)
367 (K1Columns "fft" e))
368 K1Columns label a = HLabel label (Columns a)
371type K1Table :: Symbol -> Bool -> K.Context -> Bool -> Type -> Type -> Constraint
372class
373 ( isSpecialContext ~ IsSpecialContext context
374 , isStructure ~ IsStructure structure
375 ) => K1Table label isSpecialContext context isStructure structure a
376 where
377 fromK1Columns :: K1Columns label structure (Col context) -> a
378 toK1Columns :: a -> K1Columns label structure (Col context)
381instance
382 ( x ~ Field Aggregate '[] necessity db a
383 ) => K1Table label 'True Aggregate 'True (Shape1 'Column ('Spec '[] necessity db a)) x
384 where
385 fromK1Columns (HIdentity (Aggregation a)) = a
386 toK1Columns = HIdentity . Aggregation
387 {-# INLINABLE fromK1Columns #-}
388 {-# INLINABLE toK1Columns #-}
391instance
392 ( x ~ Field Aggregate (label ': labels) necessity db a
393 ) => K1Table _label 'True Aggregate 'True (Shape1 'Column ('Spec (label ': labels) necessity db a)) x
394 where
395 fromK1Columns (HIdentity (Aggregation a)) = a
396 toK1Columns = HIdentity . Aggregation
397 {-# INLINABLE fromK1Columns #-}
398 {-# INLINABLE toK1Columns #-}
401instance
402 ( x ~ Field Expr '[] necessity db a
403 ) => K1Table label 'True Expr 'True (Shape1 'Column ('Spec '[] necessity db a)) x
404 where
405 fromK1Columns (HIdentity (DB a)) = a
406 toK1Columns = HIdentity . DB
407 {-# INLINABLE fromK1Columns #-}
408 {-# INLINABLE toK1Columns #-}
411instance
412 ( x ~ Field Expr (label ': labels) necessity db a
413 ) => K1Table _label 'True Expr 'True (Shape1 'Column ('Spec (label ': labels) necessity db a)) x
414 where
415 fromK1Columns (HIdentity (DB a)) = a
416 toK1Columns = HIdentity . DB
417 {-# INLINABLE fromK1Columns #-}
418 {-# INLINABLE toK1Columns #-}
421instance
422 ( x ~ Field Insertion '[] necessity db a
423 , KnownNecessity necessity
424 ) => K1Table label 'True Insertion 'True (Shape1 'Column ('Spec '[] necessity db a)) x
425 where
426 fromK1Columns (HIdentity insert) = case insert of
427 RequiredInsert a -> a
428 OptionalInsert ma -> ma
429 toK1Columns a = HIdentity $ case necessitySing @necessity of
430 SRequired -> RequiredInsert a
431 SOptional -> OptionalInsert a
432 {-# INLINABLE fromK1Columns #-}
433 {-# INLINABLE toK1Columns #-}
436instance
437 ( x ~ Field Insertion (label ': labels) necessity db a
438 , KnownNecessity necessity
439 ) => K1Table _label 'True Insertion 'True (Shape1 'Column ('Spec (label ': labels) necessity db a)) x
440 where
441 fromK1Columns (HIdentity insert) = case insert of
442 RequiredInsert a -> a
443 OptionalInsert ma -> ma
444 toK1Columns a = HIdentity $ case necessitySing @necessity of
445 SRequired -> RequiredInsert a
446 SOptional -> OptionalInsert a
447 {-# INLINABLE fromK1Columns #-}
448 {-# INLINABLE toK1Columns #-}
451instance
452 ( x ~ Field Identity '[] necessity db a
453 ) => K1Table label 'True Identity 'True (Shape1 'Column ('Spec '[] necessity db a)) x
454 where
455 fromK1Columns (HIdentity (Result a)) = a
456 toK1Columns = HIdentity . Result
457 {-# INLINABLE fromK1Columns #-}
458 {-# INLINABLE toK1Columns #-}
461instance
462 ( x ~ Field Identity (label ': labels) necessity db a
463 ) => K1Table _label 'True Identity 'True (Shape1 'Column ('Spec (label ': labels) necessity db a)) x
464 where
465 fromK1Columns (HIdentity (Result a)) = a
466 toK1Columns = HIdentity . Result
467 {-# INLINABLE fromK1Columns #-}
468 {-# INLINABLE toK1Columns #-}
471instance
472 ( IsSpecialContext context ~ 'False
473 , x ~ context a
474 ) => K1Table _label 'False context 'True (Shape1 'Column ('Spec (label ': labels) necessity db a)) x
475 where
476 fromK1Columns (HIdentity (Col a)) = a
477 toK1Columns = HIdentity . Col
478 {-# INLINABLE fromK1Columns #-}
479 {-# INLINABLE toK1Columns #-}
482instance
483 ( IsSpecialContext context ~ 'False
484 , x ~ context a
485 , Labelable context
486 ) => K1Table label 'False context 'True (Shape1 'Column ('Spec '[] necessity db a)) x
487 where
488 fromK1Columns = (\(Col a) -> a) . unlabeler . unHIdentity
489 toK1Columns = HIdentity . labeler . Col
490 {-# INLINABLE fromK1Columns #-}
491 {-# INLINABLE toK1Columns #-}
494instance
495 ( HTable (K1Columns "Left" structure1)
496 , HTable (K1Columns "Right" structure2)
497 , K1Table "Left" 'True Aggregate (IsStructure structure1) structure1 a
498 , K1Table "Right" 'True Aggregate (IsStructure structure2) structure2 b
499 , e ~ EitherTable a b
500 ) => K1Table label 'True Aggregate 'True (Shape2 'Either structure1 structure2) e
501 where
502 fromK1Columns =
503 fromColumns2
504 (fromK1Columns @"Left" @_ @_ @_ @structure1)
505 (fromK1Columns @"Right" @_ @_ @_ @structure2) .
506 hunlabel unlabeler
507 toK1Columns =
508 hlabel labeler .
509 toColumns2
510 (toK1Columns @"Left" @_ @_ @_ @structure1)
511 (toK1Columns @"Right" @_ @_ @_ @structure2)
512 {-# INLINABLE fromK1Columns #-}
513 {-# INLINABLE toK1Columns #-}
516instance
517 ( HTable (K1Columns "Left" structure1)
518 , HTable (K1Columns "Right" structure2)
519 , K1Table "Left" 'True Expr (IsStructure structure1) structure1 a
520 , K1Table "Right" 'True Expr (IsStructure structure2) structure2 b
521 , e ~ EitherTable a b
522 ) => K1Table label 'True Expr 'True (Shape2 'Either structure1 structure2) e
523 where
524 fromK1Columns =
525 fromColumns2
526 (fromK1Columns @"Left" @_ @_ @_ @structure1)
527 (fromK1Columns @"Right" @_ @_ @_ @structure2) .
528 hunlabel unlabeler
529 toK1Columns =
530 hlabel labeler .
531 toColumns2
532 (toK1Columns @"Left" @_ @_ @_ @structure1)
533 (toK1Columns @"Right" @_ @_ @_ @structure2)
534 {-# INLINABLE fromK1Columns #-}
535 {-# INLINABLE toK1Columns #-}
538instance
539 ( HTable (K1Columns "Left" structure1)
540 , HTable (K1Columns "Right" structure2)
541 , K1Table "Left" 'True Insertion (IsStructure structure1) structure1 a
542 , K1Table "Right" 'True Insertion (IsStructure structure2) structure2 b
543 , e ~ EitherTable a b
544 ) => K1Table label 'True Insertion 'True (Shape2 'Either structure1 structure2) e
545 where
546 fromK1Columns =
547 fromColumns2
548 (fromK1Columns @"Left" @_ @_ @_ @structure1)
549 (fromK1Columns @"Right" @_ @_ @_ @structure2) .
550 hunlabel unlabeler
551 toK1Columns =
552 hlabel labeler .
553 toColumns2
554 (toK1Columns @"Left" @_ @_ @_ @structure1)
555 (toK1Columns @"Right" @_ @_ @_ @structure2)
556 {-# INLINABLE fromK1Columns #-}
557 {-# INLINABLE toK1Columns #-}
560instance
561 ( HTable (K1Columns "Left" structure1)
562 , HTable (K1Columns "Right" structure2)
563 , K1Table "Left" 'True Identity (IsStructure structure1) structure1 a
564 , K1Table "Right" 'True Identity (IsStructure structure2) structure2 b
565 , e ~ Either a b
566 ) => K1Table label 'True Identity 'True (Shape2 'Either structure1 structure2) e
567 where
568 fromK1Columns
569 = bimap
570 (fromK1Columns @"Left" @_ @_ @_ @structure1)
571 (fromK1Columns @"Right" @_ @_ @_ @structure2)
572 . fromHEitherTable
573 . hunlabel unlabeler
574 toK1Columns
575 = hlabel labeler
576 . toHEitherTable
577 . bimap
578 (toK1Columns @"Left" @_ @_ @_ @structure1)
579 (toK1Columns @"Right" @_ @_ @_ @structure2)
580 {-# INLINABLE fromK1Columns #-}
581 {-# INLINABLE toK1Columns #-}
584instance
585 ( HTable (K1Columns "Left" structure1)
586 , HTable (K1Columns "Right" structure2)
587 , K1Table "Left" 'False context (IsStructure structure1) structure1 a
588 , K1Table "Right" 'False context (IsStructure structure2) structure2 b
589 , IsSpecialContext context ~ 'False
590 , Labelable context
591 , Nullifiable context
592 , e ~ EitherTable a b
593 ) => K1Table label 'False context 'True (Shape2 'Either structure1 structure2) e
594 where
595 fromK1Columns =
596 fromColumns2
597 (fromK1Columns @"Left" @_ @_ @_ @structure1)
598 (fromK1Columns @"Right" @_ @_ @_ @structure2) .
599 hunlabel unlabeler
600 toK1Columns =
601 hlabel labeler .
602 toColumns2
603 (toK1Columns @"Left" @_ @_ @_ @structure1)
604 (toK1Columns @"Right" @_ @_ @_ @structure2)
605 {-# INLINABLE fromK1Columns #-}
606 {-# INLINABLE toK1Columns #-}
609instance
610 ( K1Table label 'True Aggregate (IsStructure structure) structure a
611 , Table Aggregate a
612 , K1Columns label structure ~ HLabel label (Columns a)
613 , as ~ ListTable a
614 ) => K1Table label 'True Aggregate 'True (Shape1 'List structure) as
615 where
616 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
617 toK1Columns = hrelabel (hlabel hlabeler) . toColumns
618 {-# INLINABLE fromK1Columns #-}
619 {-# INLINABLE toK1Columns #-}
622instance
623 ( K1Table label 'True Expr (IsStructure structure) structure a
624 , Table Expr a
625 , K1Columns label structure ~ HLabel label (Columns a)
626 , as ~ ListTable a
627 ) => K1Table label 'True Expr 'True (Shape1 'List structure) as
628 where
629 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
630 toK1Columns = hrelabel (hlabel hlabeler) . toColumns
631 {-# INLINABLE fromK1Columns #-}
632 {-# INLINABLE toK1Columns #-}
635instance
636 ( K1Table label 'True Insertion (IsStructure structure) structure a
637 , Table Insertion a
638 , K1Columns label structure ~ HLabel label (Columns a)
639 , as ~ ListTable a
640 ) => K1Table label 'True Insertion 'True (Shape1 'List structure) as
641 where
642 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
643 toK1Columns = hrelabel (hlabel hlabeler) . toColumns
644 {-# INLINABLE fromK1Columns #-}
645 {-# INLINABLE toK1Columns #-}
648instance
649 ( K1Table label 'True Identity (IsStructure structure) structure a
650 , HTable (K1Columns label structure)
651 , as ~ [a]
652 ) => K1Table label 'True Identity 'True (Shape1 'List structure) as
653 where
654 fromK1Columns = fmap (fromK1Columns @label @'True @Identity @_ @structure) . fromHListTable
655 toK1Columns = toHListTable . fmap (toK1Columns @label @'True @Identity @_ @structure)
656 {-# INLINABLE fromK1Columns #-}
657 {-# INLINABLE toK1Columns #-}
660instance
661 ( K1Table label 'False context (IsStructure structure) structure a
662 , IsSpecialContext context ~ 'False
663 , Table context a
664 , K1Columns label structure ~ HLabel label (Columns a)
665 , Labelable context
666 , as ~ ListTable a
667 ) => K1Table label 'False context 'True (Shape1 'List structure) as
668 where
669 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
670 toK1Columns = hrelabel (hlabel hlabeler) . toColumns
671 {-# INLINABLE fromK1Columns #-}
672 {-# INLINABLE toK1Columns #-}
675instance
676 ( HTable (K1Columns "Just" structure)
677 , K1Table "Just" 'True Aggregate (IsStructure structure) structure a
678 , ma ~ MaybeTable a
679 ) => K1Table label 'True Aggregate 'True (Shape1 'Maybe structure) ma
680 where
681 fromK1Columns =
682 fromColumns1 (fromK1Columns @"Just" @_ @_ @_ @structure) .
683 hunlabel unlabeler
684 toK1Columns =
685 hlabel labeler .
686 toColumns1 (toK1Columns @"Just" @_ @_ @_ @structure)
687 {-# INLINABLE fromK1Columns #-}
688 {-# INLINABLE toK1Columns #-}
691instance
692 ( HTable (K1Columns "Just" structure)
693 , K1Table "Just" 'True Expr (IsStructure structure) structure a
694 , ma ~ MaybeTable a
695 ) => K1Table label 'True Expr 'True (Shape1 'Maybe structure) ma
696 where
697 fromK1Columns =
698 fromColumns1 (fromK1Columns @"Just" @_ @_ @_ @structure) .
699 hunlabel unlabeler
700 toK1Columns =
701 hlabel labeler .
702 toColumns1 (toK1Columns @"Just" @_ @_ @_ @structure)
703 {-# INLINABLE fromK1Columns #-}
704 {-# INLINABLE toK1Columns #-}
707instance
708 ( HTable (K1Columns "Just" structure)
709 , K1Table "Just" 'True Insertion (IsStructure structure) structure a
710 , ma ~ MaybeTable a
711 ) => K1Table label 'True Insertion 'True (Shape1 'Maybe structure) ma
712 where
713 fromK1Columns =
714 fromColumns1 (fromK1Columns @"Just" @_ @_ @_ @structure) .
715 hunlabel unlabeler
716 toK1Columns =
717 hlabel labeler .
718 toColumns1 (toK1Columns @"Just" @_ @_ @_ @structure)
719 {-# INLINABLE fromK1Columns #-}
720 {-# INLINABLE toK1Columns #-}
723instance
724 ( HTable (K1Columns "Just" structure)
725 , K1Table "Just" 'True Identity (IsStructure structure) structure a
726 , ma ~ Maybe a
727 ) => K1Table label 'True Identity 'True (Shape1 'Maybe structure) ma
728 where
729 fromK1Columns
730 = fmap (fromK1Columns @"Just" @_ @_ @_ @structure)
731 . fromHMaybeTable
732 . hunlabel unlabeler
733 toK1Columns
734 = hlabel labeler
735 . toHMaybeTable
736 . fmap (toK1Columns @"Just" @_ @_ @_ @structure)
737 {-# INLINABLE fromK1Columns #-}
738 {-# INLINABLE toK1Columns #-}
741instance
742 ( HTable (K1Columns "Just" structure)
743 , K1Table "Just" 'False context (IsStructure structure) structure a
744 , IsSpecialContext context ~ 'False
745 , Labelable context
746 , Nullifiable context
747 , ma ~ MaybeTable a
748 ) => K1Table label 'False context 'True (Shape1 'Maybe structure) ma
749 where
750 fromK1Columns =
751 fromColumns1 (fromK1Columns @"Just" @_ @_ @_ @structure) .
752 hunlabel unlabeler
753 toK1Columns =
754 hlabel labeler .
755 toColumns1 (toK1Columns @"Just" @_ @_ @_ @structure)
756 {-# INLINABLE fromK1Columns #-}
757 {-# INLINABLE toK1Columns #-}
760instance
761 ( K1Table label 'True Aggregate (IsStructure structure) structure a
762 , Table Aggregate a
763 , K1Columns label structure ~ HLabel label (Columns a)
764 , as ~ NonEmptyTable a
765 ) => K1Table label 'True Aggregate 'True (Shape1 'NonEmpty structure) as
766 where
767 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
768 toK1Columns = hrelabel (hlabel hlabeler) . toColumns
769 {-# INLINABLE fromK1Columns #-}
770 {-# INLINABLE toK1Columns #-}
773instance
774 ( K1Table label 'True Expr (IsStructure structure) structure a
775 , Table Expr a
776 , K1Columns label structure ~ HLabel label (Columns a)
777 , as ~ NonEmptyTable a
778 ) => K1Table label 'True Expr 'True (Shape1 'NonEmpty structure) as
779 where
780 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
781 toK1Columns = hrelabel (hlabel hlabeler) . toColumns
782 {-# INLINABLE fromK1Columns #-}
783 {-# INLINABLE toK1Columns #-}
786instance
787 ( K1Table label 'True Insertion (IsStructure structure) structure a
788 , Table Insertion a
789 , K1Columns label structure ~ HLabel label (Columns a)
790 , as ~ NonEmptyTable a
791 ) => K1Table label 'True Insertion 'True (Shape1 'NonEmpty structure) as
792 where
793 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
794 toK1Columns = hrelabel (hlabel hlabeler) . toColumns
795 {-# INLINABLE fromK1Columns #-}
796 {-# INLINABLE toK1Columns #-}
799instance
800 ( K1Table label 'True Identity (IsStructure structure) structure a
801 , HTable (K1Columns label structure)
802 , as ~ NonEmpty a
803 ) => K1Table label 'True Identity 'True (Shape1 'NonEmpty structure) as
804 where
805 fromK1Columns = fmap (fromK1Columns @label @'True @Identity @_ @structure) . fromHNonEmptyTable
806 toK1Columns = toHNonEmptyTable . fmap (toK1Columns @label @'True @Identity @_ @structure)
807 {-# INLINABLE fromK1Columns #-}
808 {-# INLINABLE toK1Columns #-}
811instance
812 ( K1Table label 'False context (IsStructure structure) structure a
813 , IsSpecialContext context ~ 'False
814 , Table context a
815 , K1Columns label structure ~ HLabel label (Columns a)
816 , Labelable context
817 , as ~ NonEmptyTable a
818 ) => K1Table label 'False context 'True (Shape1 'NonEmpty structure) as
819 where
820 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
821 toK1Columns = hrelabel (hlabel hlabeler) . toColumns
822 {-# INLINABLE fromK1Columns #-}
823 {-# INLINABLE toK1Columns #-}
826instance
827 ( HTable (K1Columns "Here" structure1)
828 , HTable (K1Columns "There" structure2)
829 , K1Table "Here" 'True Aggregate (IsStructure structure1) structure1 a
830 , K1Table "There" 'True Aggregate (IsStructure structure2) structure2 b
831 , e ~ TheseTable a b
832 ) => K1Table label 'True Aggregate 'True (Shape2 'These structure1 structure2) e
833 where
834 fromK1Columns =
835 fromColumns2
836 (fromK1Columns @"Here" @_ @_ @_ @structure1)
837 (fromK1Columns @"There" @_ @_ @_ @structure2) .
838 hunlabel unlabeler
839 toK1Columns =
840 hlabel labeler .
841 toColumns2
842 (toK1Columns @"Here" @_ @_ @_ @structure1)
843 (toK1Columns @"There" @_ @_ @_ @structure2)
844 {-# INLINABLE fromK1Columns #-}
845 {-# INLINABLE toK1Columns #-}
848instance
849 ( HTable (K1Columns "Here" structure1)
850 , HTable (K1Columns "There" structure2)
851 , K1Table "Here" 'True Expr (IsStructure structure1) structure1 a
852 , K1Table "There" 'True Expr (IsStructure structure2) structure2 b
853 , e ~ TheseTable a b
854 ) => K1Table label 'True Expr 'True (Shape2 'These structure1 structure2) e
855 where
856 fromK1Columns =
857 fromColumns2
858 (fromK1Columns @"Here" @_ @_ @_ @structure1)
859 (fromK1Columns @"There" @_ @_ @_ @structure2) .
860 hunlabel unlabeler
861 toK1Columns =
862 hlabel labeler .
863 toColumns2
864 (toK1Columns @"Here" @_ @_ @_ @structure1)
865 (toK1Columns @"There" @_ @_ @_ @structure2)
866 {-# INLINABLE fromK1Columns #-}
867 {-# INLINABLE toK1Columns #-}
870instance
871 ( HTable (K1Columns "Here" structure1)
872 , HTable (K1Columns "There" structure2)
873 , K1Table "Here" 'True Insertion (IsStructure structure1) structure1 a
874 , K1Table "There" 'True Insertion (IsStructure structure2) structure2 b
875 , e ~ TheseTable a b
876 ) => K1Table label 'True Insertion 'True (Shape2 'These structure1 structure2) e
877 where
878 fromK1Columns =
879 fromColumns2
880 (fromK1Columns @"Here" @_ @_ @_ @structure1)
881 (fromK1Columns @"There" @_ @_ @_ @structure2) .
882 hunlabel unlabeler
883 toK1Columns =
884 hlabel labeler .
885 toColumns2
886 (toK1Columns @"Here" @_ @_ @_ @structure1)
887 (toK1Columns @"There" @_ @_ @_ @structure2)
888 {-# INLINABLE fromK1Columns #-}
889 {-# INLINABLE toK1Columns #-}
892instance
893 ( HTable (K1Columns "Here" structure1)
894 , HTable (K1Columns "There" structure2)
895 , K1Table "Here" 'True Identity (IsStructure structure1) structure1 a
896 , K1Table "There" 'True Identity (IsStructure structure2) structure2 b
897 , e ~ These a b
898 ) => K1Table label 'True Identity 'True (Shape2 'These structure1 structure2) e
899 where
900 fromK1Columns
901 = bimap
902 (fromK1Columns @"Here" @_ @_ @_ @structure1)
903 (fromK1Columns @"There" @_ @_ @_ @structure2)
904 . fromHTheseTable
905 . hunlabel unlabeler
906 toK1Columns
907 = hlabel labeler
908 . toHTheseTable
909 . bimap
910 (toK1Columns @"Here" @_ @_ @_ @structure1)
911 (toK1Columns @"There" @_ @_ @_ @structure2)
912 {-# INLINABLE fromK1Columns #-}
913 {-# INLINABLE toK1Columns #-}
916instance
917 ( HTable (K1Columns "Here" structure1)
918 , HTable (K1Columns "There" structure2)
919 , K1Table "Here" 'False context (IsStructure structure1) structure1 a
920 , K1Table "There" 'False context (IsStructure structure2) structure2 b
921 , IsSpecialContext context ~ 'False
922 , Labelable context
923 , Nullifiable context
924 , e ~ TheseTable a b
925 ) => K1Table label 'False context 'True (Shape2 'These structure1 structure2) e
926 where
927 fromK1Columns =
928 fromColumns2
929 (fromK1Columns @"Here" @_ @_ @_ @structure1)
930 (fromK1Columns @"There" @_ @_ @_ @structure2) .
931 hunlabel unlabeler
932 toK1Columns =
933 hlabel labeler .
934 toColumns2
935 (toK1Columns @"Here" @_ @_ @_ @structure1)
936 (toK1Columns @"There" @_ @_ @_ @structure2)
937 {-# INLINABLE fromK1Columns #-}
938 {-# INLINABLE toK1Columns #-}
942instance
943 ( K1Table "fst" isSpecialContext context (IsStructure structure1) structure1 a1
944 , K1Table "snd" isSpecialContext context (IsStructure structure2) structure2 a2
945 , HTable (K1Columns "fst" structure1)
946 , HTable (K1Columns "snd" structure2)
947 , Labelable context
948 , a ~ (a1, a2)
949 ) => K1Table label isSpecialContext context 'True (structure1, structure2) a
950 where
951 fromK1Columns (hunlabel unlabeler -> (HPair a b)) =
952 ( fromK1Columns @"fst" @_ @_ @_ @structure1 a
953 , fromK1Columns @"snd" @_ @_ @_ @structure2 b
954 )
955 toK1Columns (a, b) = hlabel labeler $ HPair
956 { hfst = toK1Columns @"fst" @_ @_ @_ @structure1 a
957 , hsnd = toK1Columns @"snd" @_ @_ @_ @structure2 b
958 }
959 {-# INLINABLE fromK1Columns #-}
960 {-# INLINABLE toK1Columns #-}
963instance
964 ( K1Table "fst" isSpecialContext context (IsStructure structure1) structure1 a1
965 , K1Table "snd" isSpecialContext context (IsStructure structure2) structure2 a2
966 , K1Table "trd" isSpecialContext context (IsStructure structure3) structure3 a3
967 , HTable (K1Columns "fst" structure1)
968 , HTable (K1Columns "snd" structure2)
969 , HTable (K1Columns "trd" structure3)
970 , Labelable context
971 , a ~ (a1, a2, a3)
972 ) => K1Table label isSpecialContext context 'True (structure1, structure2, structure3) a
973 where
974 fromK1Columns (hunlabel unlabeler -> (HTrio a b c)) =
975 ( fromK1Columns @"fst" @_ @_ @_ @structure1 a
976 , fromK1Columns @"snd" @_ @_ @_ @structure2 b
977 , fromK1Columns @"trd" @_ @_ @_ @structure3 c
978 )
979 toK1Columns (a, b, c) = hlabel labeler $ HTrio
980 { hfst = toK1Columns @"fst" @_ @_ @_ @structure1 a
981 , hsnd = toK1Columns @"snd" @_ @_ @_ @structure2 b
982 , htrd = toK1Columns @"trd" @_ @_ @_ @structure3 c
983 }
984 {-# INLINABLE fromK1Columns #-}
985 {-# INLINABLE toK1Columns #-}
988instance
989 ( K1Table "fst" isSpecialContext context (IsStructure structure1) structure1 a1
990 , K1Table "snd" isSpecialContext context (IsStructure structure2) structure2 a2
991 , K1Table "trd" isSpecialContext context (IsStructure structure3) structure3 a3
992 , K1Table "frt" isSpecialContext context (IsStructure structure3) structure4 a4
993 , HTable (K1Columns "fst" structure1)
994 , HTable (K1Columns "snd" structure2)
995 , HTable (K1Columns "trd" structure3)
996 , HTable (K1Columns "frt" structure4)
997 , Labelable context
998 , a ~ (a1, a2, a3, a4)
999 ) => K1Table label isSpecialContext context 'True (structure1, structure2, structure3, structure4) a
1000 where
1001 fromK1Columns (hunlabel unlabeler -> (HQuartet a b c d)) =
1002 ( fromK1Columns @"fst" @_ @_ @_ @structure1 a
1003 , fromK1Columns @"snd" @_ @_ @_ @structure2 b
1004 , fromK1Columns @"trd" @_ @_ @_ @structure3 c
1005 , fromK1Columns @"frt" @_ @_ @_ @structure4 d
1007 toK1Columns (a, b, c, d) = hlabel labeler $ HQuartet
1008 { hfst = toK1Columns @"fst" @_ @_ @_ @structure1 a
1009 , hsnd = toK1Columns @"snd" @_ @_ @_ @structure2 b
1010 , htrd = toK1Columns @"trd" @_ @_ @_ @structure3 c
1011 , hfrt = toK1Columns @"frt" @_ @_ @_ @structure4 d
1013 {-# INLINABLE fromK1Columns #-}
1014 {-# INLINABLE toK1Columns #-}
1017instance
1018 ( K1Table "fst" isSpecialContext context (IsStructure structure1) structure1 a1
1019 , K1Table "snd" isSpecialContext context (IsStructure structure2) structure2 a2
1020 , K1Table "trd" isSpecialContext context (IsStructure structure3) structure3 a3
1021 , K1Table "frt" isSpecialContext context (IsStructure structure3) structure4 a4
1022 , K1Table "fft" isSpecialContext context (IsStructure structure3) structure5 a5
1023 , HTable (K1Columns "fst" structure1)
1024 , HTable (K1Columns "snd" structure2)
1025 , HTable (K1Columns "trd" structure3)
1026 , HTable (K1Columns "frt" structure4)
1027 , HTable (K1Columns "fft" structure5)
1028 , Labelable context
1029 , a ~ (a1, a2, a3, a4, a5)
1030 ) => K1Table label isSpecialContext context 'True (structure1, structure2, structure3, structure4, structure5) a
1031 where
1032 fromK1Columns (hunlabel unlabeler -> (HQuintet a b c d e)) =
1033 ( fromK1Columns @"fst" @_ @_ @_ @structure1 a
1034 , fromK1Columns @"snd" @_ @_ @_ @structure2 b
1035 , fromK1Columns @"trd" @_ @_ @_ @structure3 c
1036 , fromK1Columns @"frt" @_ @_ @_ @structure4 d
1037 , fromK1Columns @"fft" @_ @_ @_ @structure5 e
1039 toK1Columns (a, b, c, d, e) = hlabel labeler $ HQuintet
1040 { hfst = toK1Columns @"fst" @_ @_ @_ @structure1 a
1041 , hsnd = toK1Columns @"snd" @_ @_ @_ @structure2 b
1042 , htrd = toK1Columns @"trd" @_ @_ @_ @structure3 c
1043 , hfrt = toK1Columns @"frt" @_ @_ @_ @structure4 d
1044 , hfft = toK1Columns @"fft" @_ @_ @_ @structure5 e
1046 {-# INLINABLE fromK1Columns #-}
1047 {-# INLINABLE toK1Columns #-}
1050instance
1051 ( IsSpecialContext context ~ isSpecialContext
1052 , IsStructure structure ~ 'False
1053 , K1Columns label structure ~ HLabel label (Columns structure)
1054 , Columns structure ~ Columns a
1055 , Labelable context
1056 , Table context a
1057 ) => K1Table label isSpecialContext context 'False structure a
1058 where
1059 fromK1Columns = fromColumns . hunlabel unlabeler
1060 toK1Columns = hlabel labeler . toColumns
1061 {-# INLINABLE fromK1Columns #-}
1062 {-# INLINABLE toK1Columns #-}