git.iko.soy/rel8
on 2d11a08 help sign in
rel8/src/Rel8/Schema/Generic.hs
1019 lines 33 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.Field ( Field )
58import Rel8.Schema.HTable ( HTable )
59import Rel8.Schema.HTable.Either ( HEitherTable )
60import Rel8.Schema.HTable.Identity ( HIdentity(..) )
61import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
62import Rel8.Schema.HTable.List ( HListTable )
63import Rel8.Schema.HTable.Maybe ( HMaybeTable )
64import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
65import Rel8.Schema.HTable.Pair ( HPair(..) )
66import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
67import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
68import Rel8.Schema.HTable.These ( HTheseTable )
69import Rel8.Schema.HTable.Trio ( HTrio(..) )
70import Rel8.Schema.HTable.Vectorize ( hrelabel )
71import qualified Rel8.Schema.Kind as K
72import Rel8.Schema.Spec ( Spec( Spec ), KTable )
73import Rel8.Schema.Structure
74 ( IsStructure, Shape(..), Shape1, Shape2
75 , Structure
76 )
77import Rel8.Table
78 ( Table, Columns, Context, fromColumns, toColumns
79 )
80import Rel8.Table.Either ( EitherTable )
81import Rel8.Table.Lifted
82 ( fromColumns1, toColumns1
83 , fromColumns2, toColumns2
84 )
85import Rel8.Table.List ( ListTable )
86import Rel8.Table.Maybe ( MaybeTable(..) )
87import Rel8.Table.NonEmpty ( NonEmptyTable )
88import Rel8.Table.These ( TheseTable )
90-- these
91import Data.These ( These )
94instance (Rel8able t, TableHelper context) => Table context (t context) where
95 type Columns (t context) = GRep t
96 type Context (t context) = context
97 fromColumns = gfromColumns
98 toColumns = gtoColumns
101type TableHelper :: K.Context -> Constraint
102class TableHelper context where
103 gfromColumns :: Rel8able t => GRep t (Col context) -> t context
104 gtoColumns :: Rel8able t => t context -> GRep t (Col context)
107instance TableHelper Aggregate where
108 gfromColumns = fromAggregateColumns
109 gtoColumns = toAggregateColumns
112instance TableHelper Expr where
113 gfromColumns = fromExprColumns
114 gtoColumns = toExprColumns
117instance TableHelper Insertion where
118 gfromColumns = fromInsertionColumns
119 gtoColumns = toInsertionColumns
122instance TableHelper Identity where
123 gfromColumns = fromIdentityColumns
124 gtoColumns = toIdentityColumns
127instance TableHelper Name where
128 gfromColumns = fromNameColumns
129 gtoColumns = toNameColumns
132-- | This type class allows you to define custom 'Table's using higher-kinded
133-- data types. Higher-kinded data types are data types of the pattern:
134--
135-- @
136-- data MyType f =
137-- MyType { field1 :: Column f T1 OR HK1 f
138-- , field2 :: Column f T2 OR HK2 f
139-- , ...
140-- , fieldN :: Column f Tn OR HKn f
141-- }
142-- @
143--
144-- where @Tn@ is any Haskell type, and @HKn@ is any higher-kinded type.
145--
146-- That is, higher-kinded data are records where all fields in the record are
147-- all either of the type @Column f T@ (for any @T@), or are themselves
148-- higher-kinded data:
149--
150-- [Nested]
151--
152-- @
153-- data Nested f =
154-- Nested { nested1 :: MyType f
155-- , nested2 :: MyType f
156-- }
157-- @
158--
159-- The @Rel8able@ type class is used to give us a special mapping operation
160-- that lets us change the type parameter @f@.
161--
162-- [Supplying @Rel8able@ instances]
163--
164-- This type class should be derived generically for all table types in your
165-- project. To do this, enable the @DeriveAnyType@ and @DeriveGeneric@ language
166-- extensions:
167--
168-- @
169-- \{\-\# LANGUAGE DeriveAnyClass, DeriveGeneric #-\}
170--
171-- data MyType f = MyType { fieldA :: Column f T }
172-- deriving ( GHC.Generics.Generic, Rel8able )
173-- @
174type Rel8able :: KTable -> Constraint
175class HTable (GRep t) => Rel8able t where
176 type GRep t :: K.HTable
178 fromAggregateColumns :: GRep t (Col Aggregate) -> t Aggregate
179 toAggregateColumns :: t Aggregate -> GRep t (Col Aggregate)
181 fromExprColumns :: GRep t (Col Expr) -> t Expr
182 toExprColumns :: t Expr -> GRep t (Col Expr)
184 fromInsertionColumns :: GRep t (Col Insertion) -> t Insertion
185 toInsertionColumns :: t Insertion -> GRep t (Col Insertion)
187 fromIdentityColumns :: GRep t (Col Identity) -> t Identity
188 toIdentityColumns :: t Identity -> GRep t (Col Identity)
190 fromNameColumns :: GRep t (Col Name) -> t Name
191 toNameColumns :: t Name -> GRep t (Col Name)
193 type GRep t = GColumns (Rep (t Structure))
195 default fromAggregateColumns ::
196 ( Generic (t Aggregate)
197 , GColumns (Rep (t Structure)) ~ GRep t
198 , GRel8able Aggregate (Rep (t Structure)) (Rep (t Aggregate))
199 ) => GRep t (Col Aggregate) -> t Aggregate
200 fromAggregateColumns = to . fromGColumns @_ @(Rep (t Structure))
202 default toAggregateColumns ::
203 ( Generic (t Aggregate)
204 , GColumns (Rep (t Structure)) ~ GRep t
205 , GRel8able Aggregate (Rep (t Structure)) (Rep (t Aggregate))
206 ) => t Aggregate -> GRep t (Col Aggregate)
207 toAggregateColumns = toGColumns @_ @(Rep (t Structure)) . from
209 default fromExprColumns ::
210 ( Generic (t Expr)
211 , GColumns (Rep (t Structure)) ~ GRep t
212 , GRel8able Expr (Rep (t Structure)) (Rep (t Expr))
213 ) => GRep t (Col Expr) -> t Expr
214 fromExprColumns = to . fromGColumns @_ @(Rep (t Structure))
216 default toExprColumns ::
217 ( Generic (t Expr)
218 , GColumns (Rep (t Structure)) ~ GRep t
219 , GRel8able Expr (Rep (t Structure)) (Rep (t Expr))
220 ) => t Expr -> GRep t (Col Expr)
221 toExprColumns = toGColumns @_ @(Rep (t Structure)) . from
223 default fromInsertionColumns ::
224 ( Generic (t Insertion)
225 , GColumns (Rep (t Structure)) ~ GRep t
226 , GRel8able Insertion (Rep (t Structure)) (Rep (t Insertion))
227 ) => GRep t (Col Insertion) -> t Insertion
228 fromInsertionColumns = to . fromGColumns @_ @(Rep (t Structure))
230 default toInsertionColumns ::
231 ( Generic (t Insertion)
232 , GColumns (Rep (t Structure)) ~ GRep t
233 , GRel8able Insertion (Rep (t Structure)) (Rep (t Insertion))
234 ) => t Insertion -> GRep t (Col Insertion)
235 toInsertionColumns = toGColumns @_ @(Rep (t Structure)) . from
237 default fromIdentityColumns ::
238 ( Generic (t Identity)
239 , GColumns (Rep (t Structure)) ~ GRep t
240 , GRel8able Identity (Rep (t Structure)) (Rep (t Identity))
241 ) => GRep t (Col Identity) -> t Identity
242 fromIdentityColumns = to . fromGColumns @_ @(Rep (t Structure))
244 default toIdentityColumns ::
245 ( Generic (t Identity)
246 , GColumns (Rep (t Structure)) ~ GRep t
247 , GRel8able Identity (Rep (t Structure)) (Rep (t Identity))
248 ) => t Identity -> GRep t (Col Identity)
249 toIdentityColumns = toGColumns @_ @(Rep (t Structure)) . from
251 default fromNameColumns ::
252 ( Generic (t Name)
253 , GColumns (Rep (t Structure)) ~ GRep t
254 , GRel8able Name (Rep (t Structure)) (Rep (t Name))
255 ) => GRep t (Col Name) -> t Name
256 fromNameColumns = to . fromGColumns @_ @(Rep (t Structure))
258 default toNameColumns ::
259 ( Generic (t Name)
260 , GColumns (Rep (t Structure)) ~ GRep t
261 , GRel8able Name (Rep (t Structure)) (Rep (t Name))
262 ) => t Name -> GRep t (Col Name)
263 toNameColumns = toGColumns @_ @(Rep (t Structure)) . from
266type GColumns :: (Type -> Type) -> K.HTable
267type family GColumns structure where
268 GColumns (M1 D _ structure) = GColumns structure
269 GColumns (M1 C _ structure) = GColumns structure
270 GColumns (a :*: b) = HPair (GColumns a) (GColumns b)
271 GColumns (M1 S ('MetaSel ('Just label) _ _ _) (K1 _ structure)) =
272 K1Columns label structure
275type GRel8able :: K.Context -> (Type -> Type) -> (Type -> Type) -> Constraint
276class GRel8able context structure rep where
277 fromGColumns :: GColumns structure (Col context) -> rep x
278 toGColumns :: rep x -> GColumns structure (Col context)
281instance GRel8able context structure rep => GRel8able context (M1 D c structure) (M1 D c rep) where
282 fromGColumns = M1 . fromGColumns @context @structure @rep
283 toGColumns (M1 a) = toGColumns @context @structure @rep a
286instance GRel8able context structure rep => GRel8able context (M1 C c structure) (M1 C c rep) where
287 fromGColumns = M1 . fromGColumns @context @structure @rep
288 toGColumns (M1 a) = toGColumns @context @structure @rep a
291instance (GRel8able context structure1 rep1, GRel8able context structure2 rep2) =>
292 GRel8able context (structure1 :*: structure2) (rep1 :*: rep2)
293 where
294 fromGColumns (HPair a b) =
295 fromGColumns @context @structure1 @rep1 a :*:
296 fromGColumns @context @structure2 @rep2 b
297 toGColumns (a :*: b) =
298 HPair
299 (toGColumns @context @structure1 @rep1 a)
300 (toGColumns @context @structure2 @rep2 b)
303instance
304 ( K1Table label context isStructure structure a
305 , meta ~ 'MetaSel ('Just label) _su _ss _ds
306 , structureK1 ~ K1 i structure
307 , k1 ~ K1 i a
308 ) => GRel8able context (M1 S meta structureK1) (M1 S meta k1)
309 where
310 fromGColumns = M1 . K1 . fromK1Columns @label @_ @_ @structure
311 toGColumns (M1 (K1 a)) = toK1Columns @label @_ @_ @structure a
314type K1Columns :: Symbol -> Type -> K.HTable
315type family K1Columns label structure where
316 K1Columns label (Shape1 'Column ('Spec '[] necessity nullability blueprint)) =
317 HIdentity ('Spec '[label] necessity nullability blueprint)
318 K1Columns _label (Shape1 'Column ('Spec (label ': labels) necessity nullability blueprint)) =
319 HIdentity ('Spec (label ': labels) necessity nullability blueprint)
320 K1Columns label (Shape2 'Either a b) =
321 HLabel label (HEitherTable (K1Columns "Left" a) (K1Columns "Right" b))
322 K1Columns label (Shape1 'List a) = HListTable (K1Columns label a)
323 K1Columns label (Shape1 'Maybe a) = HLabel label (HMaybeTable (K1Columns "Just" a))
324 K1Columns label (Shape1 'NonEmpty a) = HNonEmptyTable (K1Columns label a)
325 K1Columns label (Shape2 'These a b) =
326 HLabel label (HTheseTable (K1Columns "Here" a) (K1Columns "There" b))
327 K1Columns label (a, b) =
328 HLabel label
329 (HPair
330 (K1Columns "fst" a)
331 (K1Columns "snd" b))
332 K1Columns label (a, b, c) =
333 HLabel label
334 (HTrio
335 (K1Columns "fst" a)
336 (K1Columns "snd" b)
337 (K1Columns "trd" c))
338 K1Columns label (a, b, c, d) =
339 HLabel label
340 (HQuartet
341 (K1Columns "fst" a)
342 (K1Columns "snd" b)
343 (K1Columns "trd" c)
344 (K1Columns "frt" d))
345 K1Columns label (a, b, c, d, e) =
346 HLabel label
347 (HQuintet
348 (K1Columns "fst" a)
349 (K1Columns "snd" b)
350 (K1Columns "trd" c)
351 (K1Columns "frt" d)
352 (K1Columns "fft" e))
353 K1Columns label a = HLabel label (Columns a)
356type K1Table :: Symbol -> K.Context -> Bool -> Type -> Type -> Constraint
357class isStructure ~ IsStructure structure =>
358 K1Table label context isStructure structure a
359 where
360 fromK1Columns :: K1Columns label structure (Col context) -> a
361 toK1Columns :: a -> K1Columns label structure (Col context)
364instance
365 ( x ~ Field Aggregate '[] necessity db a
366 ) => K1Table label Aggregate 'True (Shape1 'Column ('Spec '[] necessity db a)) x
367 where
368 fromK1Columns (HIdentity (Aggregation a)) = a
369 toK1Columns = HIdentity . Aggregation
370 {-# INLINABLE fromK1Columns #-}
371 {-# INLINABLE toK1Columns #-}
374instance
375 ( x ~ Field Aggregate (label ': labels) necessity db a
376 ) => K1Table _label Aggregate 'True (Shape1 'Column ('Spec (label ': labels) necessity db a)) x
377 where
378 fromK1Columns (HIdentity (Aggregation a)) = a
379 toK1Columns = HIdentity . Aggregation
380 {-# INLINABLE fromK1Columns #-}
381 {-# INLINABLE toK1Columns #-}
384instance
385 ( x ~ Field Expr '[] necessity db a
386 ) => K1Table label Expr 'True (Shape1 'Column ('Spec '[] necessity db a)) x
387 where
388 fromK1Columns (HIdentity (DB a)) = a
389 toK1Columns = HIdentity . DB
390 {-# INLINABLE fromK1Columns #-}
391 {-# INLINABLE toK1Columns #-}
394instance
395 ( x ~ Field Expr (label ': labels) necessity db a
396 ) => K1Table _label Expr 'True (Shape1 'Column ('Spec (label ': labels) necessity db a)) x
397 where
398 fromK1Columns (HIdentity (DB a)) = a
399 toK1Columns = HIdentity . DB
400 {-# INLINABLE fromK1Columns #-}
401 {-# INLINABLE toK1Columns #-}
404instance
405 ( x ~ Field Insertion '[] necessity db a
406 , KnownNecessity necessity
407 ) => K1Table label Insertion 'True (Shape1 'Column ('Spec '[] necessity db a)) x
408 where
409 fromK1Columns (HIdentity insert) = case insert of
410 RequiredInsert a -> a
411 OptionalInsert ma -> ma
412 toK1Columns a = HIdentity $ case necessitySing @necessity of
413 SRequired -> RequiredInsert a
414 SOptional -> OptionalInsert a
415 {-# INLINABLE fromK1Columns #-}
416 {-# INLINABLE toK1Columns #-}
419instance
420 ( x ~ Field Insertion (label ': labels) necessity db a
421 , KnownNecessity necessity
422 ) => K1Table _label Insertion 'True (Shape1 'Column ('Spec (label ': labels) necessity db a)) x
423 where
424 fromK1Columns (HIdentity insert) = case insert of
425 RequiredInsert a -> a
426 OptionalInsert ma -> ma
427 toK1Columns a = HIdentity $ case necessitySing @necessity of
428 SRequired -> RequiredInsert a
429 SOptional -> OptionalInsert a
430 {-# INLINABLE fromK1Columns #-}
431 {-# INLINABLE toK1Columns #-}
434instance
435 ( x ~ Field Identity '[] necessity db a
436 ) => K1Table label Identity 'True (Shape1 'Column ('Spec '[] necessity db a)) x
437 where
438 fromK1Columns (HIdentity (Result a)) = a
439 toK1Columns = HIdentity . Result
440 {-# INLINABLE fromK1Columns #-}
441 {-# INLINABLE toK1Columns #-}
444instance
445 ( x ~ Field Identity (label ': labels) necessity db a
446 ) => K1Table _label Identity 'True (Shape1 'Column ('Spec (label ': labels) necessity db a)) x
447 where
448 fromK1Columns (HIdentity (Result a)) = a
449 toK1Columns = HIdentity . Result
450 {-# INLINABLE fromK1Columns #-}
451 {-# INLINABLE toK1Columns #-}
454instance
455 ( x ~ Field Name '[] necessity db a
456 ) => K1Table _label Name 'True (Shape1 'Column ('Spec (label ': labels) necessity db a)) x
457 where
458 fromK1Columns (HIdentity (NameCol a)) = Name a
459 toK1Columns (Name a) = HIdentity (NameCol a)
460 {-# INLINABLE fromK1Columns #-}
461 {-# INLINABLE toK1Columns #-}
464instance
465 ( x ~ Field Name (label ': labels) necessity db a
466 ) => K1Table label Name 'True (Shape1 'Column ('Spec '[] necessity db a)) x
467 where
468 fromK1Columns = Name . (\(NameCol a) -> a) . unlabeler . unHIdentity
469 toK1Columns = HIdentity . labeler . NameCol . (\(Name a) -> a)
470 {-# INLINABLE fromK1Columns #-}
471 {-# INLINABLE toK1Columns #-}
474instance
475 ( HTable (K1Columns "Left" structure1)
476 , HTable (K1Columns "Right" structure2)
477 , K1Table "Left" Aggregate (IsStructure structure1) structure1 a
478 , K1Table "Right" Aggregate (IsStructure structure2) structure2 b
479 , e ~ EitherTable a b
480 ) => K1Table label Aggregate 'True (Shape2 'Either structure1 structure2) e
481 where
482 fromK1Columns =
483 fromColumns2
484 (fromK1Columns @"Left" @_ @_ @structure1)
485 (fromK1Columns @"Right" @_ @_ @structure2) .
486 hunlabel unlabeler
487 toK1Columns =
488 hlabel labeler .
489 toColumns2
490 (toK1Columns @"Left" @_ @_ @structure1)
491 (toK1Columns @"Right" @_ @_ @structure2)
492 {-# INLINABLE fromK1Columns #-}
493 {-# INLINABLE toK1Columns #-}
496instance
497 ( HTable (K1Columns "Left" structure1)
498 , HTable (K1Columns "Right" structure2)
499 , K1Table "Left" Expr (IsStructure structure1) structure1 a
500 , K1Table "Right" Expr (IsStructure structure2) structure2 b
501 , e ~ EitherTable a b
502 ) => K1Table label Expr 'True (Shape2 'Either structure1 structure2) e
503 where
504 fromK1Columns =
505 fromColumns2
506 (fromK1Columns @"Left" @_ @_ @structure1)
507 (fromK1Columns @"Right" @_ @_ @structure2) .
508 hunlabel unlabeler
509 toK1Columns =
510 hlabel labeler .
511 toColumns2
512 (toK1Columns @"Left" @_ @_ @structure1)
513 (toK1Columns @"Right" @_ @_ @structure2)
514 {-# INLINABLE fromK1Columns #-}
515 {-# INLINABLE toK1Columns #-}
518instance
519 ( HTable (K1Columns "Left" structure1)
520 , HTable (K1Columns "Right" structure2)
521 , K1Table "Left" Insertion (IsStructure structure1) structure1 a
522 , K1Table "Right" Insertion (IsStructure structure2) structure2 b
523 , e ~ EitherTable a b
524 ) => K1Table label Insertion 'True (Shape2 'Either structure1 structure2) e
525 where
526 fromK1Columns =
527 fromColumns2
528 (fromK1Columns @"Left" @_ @_ @structure1)
529 (fromK1Columns @"Right" @_ @_ @structure2) .
530 hunlabel unlabeler
531 toK1Columns =
532 hlabel labeler .
533 toColumns2
534 (toK1Columns @"Left" @_ @_ @structure1)
535 (toK1Columns @"Right" @_ @_ @structure2)
536 {-# INLINABLE fromK1Columns #-}
537 {-# INLINABLE toK1Columns #-}
540instance
541 ( HTable (K1Columns "Left" structure1)
542 , HTable (K1Columns "Right" structure2)
543 , K1Table "Left" Identity (IsStructure structure1) structure1 a
544 , K1Table "Right" Identity (IsStructure structure2) structure2 b
545 , e ~ Either a b
546 ) => K1Table label Identity 'True (Shape2 'Either structure1 structure2) e
547 where
548 fromK1Columns
549 = bimap
550 (fromK1Columns @"Left" @_ @_ @structure1)
551 (fromK1Columns @"Right" @_ @_ @structure2)
552 . fromHEitherTable
553 . hunlabel unlabeler
554 toK1Columns
555 = hlabel labeler
556 . toHEitherTable
557 . bimap
558 (toK1Columns @"Left" @_ @_ @structure1)
559 (toK1Columns @"Right" @_ @_ @structure2)
560 {-# INLINABLE fromK1Columns #-}
561 {-# INLINABLE toK1Columns #-}
564instance
565 ( HTable (K1Columns "Left" structure1)
566 , HTable (K1Columns "Right" structure2)
567 , K1Table "Left" Name (IsStructure structure1) structure1 a
568 , K1Table "Right" Name (IsStructure structure2) structure2 b
569 , e ~ EitherTable a b
570 ) => K1Table label Name 'True (Shape2 'Either structure1 structure2) e
571 where
572 fromK1Columns =
573 fromColumns2
574 (fromK1Columns @"Left" @_ @_ @structure1)
575 (fromK1Columns @"Right" @_ @_ @structure2) .
576 hunlabel unlabeler
577 toK1Columns =
578 hlabel labeler .
579 toColumns2
580 (toK1Columns @"Left" @_ @_ @structure1)
581 (toK1Columns @"Right" @_ @_ @structure2)
582 {-# INLINABLE fromK1Columns #-}
583 {-# INLINABLE toK1Columns #-}
586instance
587 ( Table Aggregate a
588 , K1Columns label structure ~ HLabel label (Columns a)
589 , as ~ ListTable a
590 ) => K1Table label Aggregate 'True (Shape1 'List structure) as
591 where
592 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
593 toK1Columns = hrelabel (hlabel hlabeler) . toColumns
594 {-# INLINABLE fromK1Columns #-}
595 {-# INLINABLE toK1Columns #-}
598instance
599 ( Table Expr a
600 , K1Columns label structure ~ HLabel label (Columns a)
601 , as ~ ListTable a
602 ) => K1Table label Expr 'True (Shape1 'List structure) as
603 where
604 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
605 toK1Columns = hrelabel (hlabel hlabeler) . toColumns
606 {-# INLINABLE fromK1Columns #-}
607 {-# INLINABLE toK1Columns #-}
610instance
611 ( Table Insertion a
612 , K1Columns label structure ~ HLabel label (Columns a)
613 , as ~ ListTable a
614 ) => K1Table label Insertion '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 Identity (IsStructure structure) structure a
624 , HTable (K1Columns label structure)
625 , as ~ [a]
626 ) => K1Table label Identity 'True (Shape1 'List structure) as
627 where
628 fromK1Columns = fmap (fromK1Columns @label @_ @_ @structure) . fromHListTable
629 toK1Columns = toHListTable . fmap (toK1Columns @label @_ @_ @structure)
630 {-# INLINABLE fromK1Columns #-}
631 {-# INLINABLE toK1Columns #-}
634instance
635 ( Table Name a
636 , K1Columns label structure ~ HLabel label (Columns a)
637 , as ~ ListTable a
638 ) => K1Table label Name 'True (Shape1 'List structure) as
639 where
640 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
641 toK1Columns = hrelabel (hlabel hlabeler) . toColumns
642 {-# INLINABLE fromK1Columns #-}
643 {-# INLINABLE toK1Columns #-}
646instance
647 ( HTable (K1Columns "Just" structure)
648 , K1Table "Just" Aggregate (IsStructure structure) structure a
649 , ma ~ MaybeTable a
650 ) => K1Table label Aggregate 'True (Shape1 'Maybe structure) ma
651 where
652 fromK1Columns =
653 fromColumns1 (fromK1Columns @"Just" @_ @_ @structure) .
654 hunlabel unlabeler
655 toK1Columns =
656 hlabel labeler .
657 toColumns1 (toK1Columns @"Just" @_ @_ @structure)
658 {-# INLINABLE fromK1Columns #-}
659 {-# INLINABLE toK1Columns #-}
662instance
663 ( HTable (K1Columns "Just" structure)
664 , K1Table "Just" Expr (IsStructure structure) structure a
665 , ma ~ MaybeTable a
666 ) => K1Table label Expr 'True (Shape1 'Maybe structure) ma
667 where
668 fromK1Columns =
669 fromColumns1 (fromK1Columns @"Just" @_ @_ @structure) .
670 hunlabel unlabeler
671 toK1Columns =
672 hlabel labeler .
673 toColumns1 (toK1Columns @"Just" @_ @_ @structure)
674 {-# INLINABLE fromK1Columns #-}
675 {-# INLINABLE toK1Columns #-}
678instance
679 ( HTable (K1Columns "Just" structure)
680 , K1Table "Just" Insertion (IsStructure structure) structure a
681 , ma ~ MaybeTable a
682 ) => K1Table label Insertion 'True (Shape1 'Maybe structure) ma
683 where
684 fromK1Columns =
685 fromColumns1 (fromK1Columns @"Just" @_ @_ @structure) .
686 hunlabel unlabeler
687 toK1Columns =
688 hlabel labeler .
689 toColumns1 (toK1Columns @"Just" @_ @_ @structure)
690 {-# INLINABLE fromK1Columns #-}
691 {-# INLINABLE toK1Columns #-}
694instance
695 ( HTable (K1Columns "Just" structure)
696 , K1Table "Just" Identity (IsStructure structure) structure a
697 , ma ~ Maybe a
698 ) => K1Table label Identity 'True (Shape1 'Maybe structure) ma
699 where
700 fromK1Columns
701 = fmap (fromK1Columns @"Just" @_ @_ @structure)
702 . fromHMaybeTable
703 . hunlabel unlabeler
704 toK1Columns
705 = hlabel labeler
706 . toHMaybeTable
707 . fmap (toK1Columns @"Just" @_ @_ @structure)
708 {-# INLINABLE fromK1Columns #-}
709 {-# INLINABLE toK1Columns #-}
712instance
713 ( HTable (K1Columns "Just" structure)
714 , K1Table "Just" Name (IsStructure structure) structure a
715 , ma ~ MaybeTable a
716 ) => K1Table label Name 'True (Shape1 'Maybe structure) ma
717 where
718 fromK1Columns =
719 fromColumns1 (fromK1Columns @"Just" @_ @_ @structure) .
720 hunlabel unlabeler
721 toK1Columns =
722 hlabel labeler .
723 toColumns1 (toK1Columns @"Just" @_ @_ @structure)
724 {-# INLINABLE fromK1Columns #-}
725 {-# INLINABLE toK1Columns #-}
728instance
729 ( Table Aggregate a
730 , K1Columns label structure ~ HLabel label (Columns a)
731 , as ~ NonEmptyTable a
732 ) => K1Table label Aggregate 'True (Shape1 'NonEmpty structure) as
733 where
734 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
735 toK1Columns = hrelabel (hlabel hlabeler) . toColumns
736 {-# INLINABLE fromK1Columns #-}
737 {-# INLINABLE toK1Columns #-}
740instance
741 ( Table Expr a
742 , K1Columns label structure ~ HLabel label (Columns a)
743 , as ~ NonEmptyTable a
744 ) => K1Table label Expr 'True (Shape1 'NonEmpty structure) as
745 where
746 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
747 toK1Columns = hrelabel (hlabel hlabeler) . toColumns
748 {-# INLINABLE fromK1Columns #-}
749 {-# INLINABLE toK1Columns #-}
752instance
753 ( Table Insertion a
754 , K1Columns label structure ~ HLabel label (Columns a)
755 , as ~ NonEmptyTable a
756 ) => K1Table label Insertion 'True (Shape1 'NonEmpty structure) as
757 where
758 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
759 toK1Columns = hrelabel (hlabel hlabeler) . toColumns
760 {-# INLINABLE fromK1Columns #-}
761 {-# INLINABLE toK1Columns #-}
764instance
765 ( K1Table label Identity (IsStructure structure) structure a
766 , HTable (K1Columns label structure)
767 , as ~ NonEmpty a
768 ) => K1Table label Identity 'True (Shape1 'NonEmpty structure) as
769 where
770 fromK1Columns = fmap (fromK1Columns @label @_ @_ @structure) . fromHNonEmptyTable
771 toK1Columns = toHNonEmptyTable . fmap (toK1Columns @label @_ @_ @structure)
772 {-# INLINABLE fromK1Columns #-}
773 {-# INLINABLE toK1Columns #-}
776instance
777 ( Table Name a
778 , K1Columns label structure ~ HLabel label (Columns a)
779 , as ~ NonEmptyTable a
780 ) => K1Table label Name 'True (Shape1 'NonEmpty structure) as
781 where
782 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
783 toK1Columns = hrelabel (hlabel hlabeler) . toColumns
784 {-# INLINABLE fromK1Columns #-}
785 {-# INLINABLE toK1Columns #-}
788instance
789 ( HTable (K1Columns "Here" structure1)
790 , HTable (K1Columns "There" structure2)
791 , K1Table "Here" Aggregate (IsStructure structure1) structure1 a
792 , K1Table "There" Aggregate (IsStructure structure2) structure2 b
793 , e ~ TheseTable a b
794 ) => K1Table label Aggregate 'True (Shape2 'These structure1 structure2) e
795 where
796 fromK1Columns =
797 fromColumns2
798 (fromK1Columns @"Here" @_ @_ @structure1)
799 (fromK1Columns @"There" @_ @_ @structure2) .
800 hunlabel unlabeler
801 toK1Columns =
802 hlabel labeler .
803 toColumns2
804 (toK1Columns @"Here" @_ @_ @structure1)
805 (toK1Columns @"There" @_ @_ @structure2)
806 {-# INLINABLE fromK1Columns #-}
807 {-# INLINABLE toK1Columns #-}
810instance
811 ( HTable (K1Columns "Here" structure1)
812 , HTable (K1Columns "There" structure2)
813 , K1Table "Here" Expr (IsStructure structure1) structure1 a
814 , K1Table "There" Expr (IsStructure structure2) structure2 b
815 , e ~ TheseTable a b
816 ) => K1Table label Expr 'True (Shape2 'These structure1 structure2) e
817 where
818 fromK1Columns =
819 fromColumns2
820 (fromK1Columns @"Here" @_ @_ @structure1)
821 (fromK1Columns @"There" @_ @_ @structure2) .
822 hunlabel unlabeler
823 toK1Columns =
824 hlabel labeler .
825 toColumns2
826 (toK1Columns @"Here" @_ @_ @structure1)
827 (toK1Columns @"There" @_ @_ @structure2)
828 {-# INLINABLE fromK1Columns #-}
829 {-# INLINABLE toK1Columns #-}
832instance
833 ( HTable (K1Columns "Here" structure1)
834 , HTable (K1Columns "There" structure2)
835 , K1Table "Here" Insertion (IsStructure structure1) structure1 a
836 , K1Table "There" Insertion (IsStructure structure2) structure2 b
837 , e ~ TheseTable a b
838 ) => K1Table label Insertion 'True (Shape2 'These structure1 structure2) e
839 where
840 fromK1Columns =
841 fromColumns2
842 (fromK1Columns @"Here" @_ @_ @structure1)
843 (fromK1Columns @"There" @_ @_ @structure2) .
844 hunlabel unlabeler
845 toK1Columns =
846 hlabel labeler .
847 toColumns2
848 (toK1Columns @"Here" @_ @_ @structure1)
849 (toK1Columns @"There" @_ @_ @structure2)
850 {-# INLINABLE fromK1Columns #-}
851 {-# INLINABLE toK1Columns #-}
854instance
855 ( HTable (K1Columns "Here" structure1)
856 , HTable (K1Columns "There" structure2)
857 , K1Table "Here" Identity (IsStructure structure1) structure1 a
858 , K1Table "There" Identity (IsStructure structure2) structure2 b
859 , e ~ These a b
860 ) => K1Table label Identity 'True (Shape2 'These structure1 structure2) e
861 where
862 fromK1Columns
863 = bimap
864 (fromK1Columns @"Here" @_ @_ @structure1)
865 (fromK1Columns @"There" @_ @_ @structure2)
866 . fromHTheseTable
867 . hunlabel unlabeler
868 toK1Columns
869 = hlabel labeler
870 . toHTheseTable
871 . bimap
872 (toK1Columns @"Here" @_ @_ @structure1)
873 (toK1Columns @"There" @_ @_ @structure2)
874 {-# INLINABLE fromK1Columns #-}
875 {-# INLINABLE toK1Columns #-}
878instance
879 ( HTable (K1Columns "Here" structure1)
880 , HTable (K1Columns "There" structure2)
881 , K1Table "Here" Name (IsStructure structure1) structure1 a
882 , K1Table "There" Name (IsStructure structure2) structure2 b
883 , e ~ TheseTable a b
884 ) => K1Table label Name 'True (Shape2 'These structure1 structure2) e
885 where
886 fromK1Columns =
887 fromColumns2
888 (fromK1Columns @"Here" @_ @_ @structure1)
889 (fromK1Columns @"There" @_ @_ @structure2) .
890 hunlabel unlabeler
891 toK1Columns =
892 hlabel labeler .
893 toColumns2
894 (toK1Columns @"Here" @_ @_ @structure1)
895 (toK1Columns @"There" @_ @_ @structure2)
896 {-# INLINABLE fromK1Columns #-}
897 {-# INLINABLE toK1Columns #-}
900instance
901 ( K1Table "fst" context (IsStructure structure1) structure1 a1
902 , K1Table "snd" context (IsStructure structure2) structure2 a2
903 , HTable (K1Columns "fst" structure1)
904 , HTable (K1Columns "snd" structure2)
905 , Labelable context
906 , a ~ (a1, a2)
907 ) => K1Table label context 'True (structure1, structure2) a
908 where
909 fromK1Columns (hunlabel unlabeler -> (HPair a b)) =
910 ( fromK1Columns @"fst" @_ @_ @structure1 a
911 , fromK1Columns @"snd" @_ @_ @structure2 b
912 )
913 toK1Columns (a, b) = hlabel labeler $ HPair
914 { hfst = toK1Columns @"fst" @_ @_ @structure1 a
915 , hsnd = toK1Columns @"snd" @_ @_ @structure2 b
916 }
917 {-# INLINABLE fromK1Columns #-}
918 {-# INLINABLE toK1Columns #-}
921instance
922 ( K1Table "fst" context (IsStructure structure1) structure1 a1
923 , K1Table "snd" context (IsStructure structure2) structure2 a2
924 , K1Table "trd" context (IsStructure structure3) structure3 a3
925 , HTable (K1Columns "fst" structure1)
926 , HTable (K1Columns "snd" structure2)
927 , HTable (K1Columns "trd" structure3)
928 , Labelable context
929 , a ~ (a1, a2, a3)
930 ) => K1Table label context 'True (structure1, structure2, structure3) a
931 where
932 fromK1Columns (hunlabel unlabeler -> (HTrio a b c)) =
933 ( fromK1Columns @"fst" @_ @_ @structure1 a
934 , fromK1Columns @"snd" @_ @_ @structure2 b
935 , fromK1Columns @"trd" @_ @_ @structure3 c
936 )
937 toK1Columns (a, b, c) = hlabel labeler $ HTrio
938 { hfst = toK1Columns @"fst" @_ @_ @structure1 a
939 , hsnd = toK1Columns @"snd" @_ @_ @structure2 b
940 , htrd = toK1Columns @"trd" @_ @_ @structure3 c
941 }
942 {-# INLINABLE fromK1Columns #-}
943 {-# INLINABLE toK1Columns #-}
946instance
947 ( K1Table "fst" context (IsStructure structure1) structure1 a1
948 , K1Table "snd" context (IsStructure structure2) structure2 a2
949 , K1Table "trd" context (IsStructure structure3) structure3 a3
950 , K1Table "frt" context (IsStructure structure3) structure4 a4
951 , HTable (K1Columns "fst" structure1)
952 , HTable (K1Columns "snd" structure2)
953 , HTable (K1Columns "trd" structure3)
954 , HTable (K1Columns "frt" structure4)
955 , Labelable context
956 , a ~ (a1, a2, a3, a4)
957 ) => K1Table label context 'True (structure1, structure2, structure3, structure4) a
958 where
959 fromK1Columns (hunlabel unlabeler -> (HQuartet a b c d)) =
960 ( fromK1Columns @"fst" @_ @_ @structure1 a
961 , fromK1Columns @"snd" @_ @_ @structure2 b
962 , fromK1Columns @"trd" @_ @_ @structure3 c
963 , fromK1Columns @"frt" @_ @_ @structure4 d
964 )
965 toK1Columns (a, b, c, d) = hlabel labeler $ HQuartet
966 { hfst = toK1Columns @"fst" @_ @_ @structure1 a
967 , hsnd = toK1Columns @"snd" @_ @_ @structure2 b
968 , htrd = toK1Columns @"trd" @_ @_ @structure3 c
969 , hfrt = toK1Columns @"frt" @_ @_ @structure4 d
970 }
971 {-# INLINABLE fromK1Columns #-}
972 {-# INLINABLE toK1Columns #-}
975instance
976 ( K1Table "fst" context (IsStructure structure1) structure1 a1
977 , K1Table "snd" context (IsStructure structure2) structure2 a2
978 , K1Table "trd" context (IsStructure structure3) structure3 a3
979 , K1Table "frt" context (IsStructure structure3) structure4 a4
980 , K1Table "fft" context (IsStructure structure3) structure5 a5
981 , HTable (K1Columns "fst" structure1)
982 , HTable (K1Columns "snd" structure2)
983 , HTable (K1Columns "trd" structure3)
984 , HTable (K1Columns "frt" structure4)
985 , HTable (K1Columns "fft" structure5)
986 , Labelable context
987 , a ~ (a1, a2, a3, a4, a5)
988 ) => K1Table label context 'True (structure1, structure2, structure3, structure4, structure5) a
989 where
990 fromK1Columns (hunlabel unlabeler -> (HQuintet a b c d e)) =
991 ( fromK1Columns @"fst" @_ @_ @structure1 a
992 , fromK1Columns @"snd" @_ @_ @structure2 b
993 , fromK1Columns @"trd" @_ @_ @structure3 c
994 , fromK1Columns @"frt" @_ @_ @structure4 d
995 , fromK1Columns @"fft" @_ @_ @structure5 e
996 )
997 toK1Columns (a, b, c, d, e) = hlabel labeler $ HQuintet
998 { hfst = toK1Columns @"fst" @_ @_ @structure1 a
999 , hsnd = toK1Columns @"snd" @_ @_ @structure2 b
1000 , htrd = toK1Columns @"trd" @_ @_ @structure3 c
1001 , hfrt = toK1Columns @"frt" @_ @_ @structure4 d
1002 , hfft = toK1Columns @"fft" @_ @_ @structure5 e
1004 {-# INLINABLE fromK1Columns #-}
1005 {-# INLINABLE toK1Columns #-}
1008instance
1009 ( IsStructure structure ~ 'False
1010 , K1Columns label structure ~ HLabel label (Columns structure)
1011 , Columns structure ~ Columns a
1012 , Labelable context
1013 , Table context a
1014 ) => K1Table label context 'False structure a
1015 where
1016 fromK1Columns = fromColumns . hunlabel unlabeler
1017 toK1Columns = hlabel labeler . toColumns
1018 {-# INLINABLE fromK1Columns #-}
1019 {-# INLINABLE toK1Columns #-}