git.iko.soy/rel8
on 1be93da help sign in
rel8/src/Rel8/Schema/Generic.hs
1047 lines 34 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, KnownSymbol )
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 , KnownSymbol label
481 ) => K1Table label Aggregate 'True (Shape2 'Either structure1 structure2) e
482 where
483 fromK1Columns =
484 fromColumns2
485 (fromK1Columns @"Left" @_ @_ @structure1)
486 (fromK1Columns @"Right" @_ @_ @structure2) .
487 hunlabel unlabeler
488 toK1Columns =
489 hlabel labeler .
490 toColumns2
491 (toK1Columns @"Left" @_ @_ @structure1)
492 (toK1Columns @"Right" @_ @_ @structure2)
493 {-# INLINABLE fromK1Columns #-}
494 {-# INLINABLE toK1Columns #-}
497instance
498 ( HTable (K1Columns "Left" structure1)
499 , HTable (K1Columns "Right" structure2)
500 , K1Table "Left" Expr (IsStructure structure1) structure1 a
501 , K1Table "Right" Expr (IsStructure structure2) structure2 b
502 , e ~ EitherTable a b
503 , KnownSymbol label
504 ) => K1Table label Expr 'True (Shape2 'Either structure1 structure2) e
505 where
506 fromK1Columns =
507 fromColumns2
508 (fromK1Columns @"Left" @_ @_ @structure1)
509 (fromK1Columns @"Right" @_ @_ @structure2) .
510 hunlabel unlabeler
511 toK1Columns =
512 hlabel labeler .
513 toColumns2
514 (toK1Columns @"Left" @_ @_ @structure1)
515 (toK1Columns @"Right" @_ @_ @structure2)
516 {-# INLINABLE fromK1Columns #-}
517 {-# INLINABLE toK1Columns #-}
520instance
521 ( HTable (K1Columns "Left" structure1)
522 , HTable (K1Columns "Right" structure2)
523 , K1Table "Left" Insertion (IsStructure structure1) structure1 a
524 , K1Table "Right" Insertion (IsStructure structure2) structure2 b
525 , e ~ EitherTable a b
526 , KnownSymbol label
527 ) => K1Table label Insertion 'True (Shape2 'Either structure1 structure2) e
528 where
529 fromK1Columns =
530 fromColumns2
531 (fromK1Columns @"Left" @_ @_ @structure1)
532 (fromK1Columns @"Right" @_ @_ @structure2) .
533 hunlabel unlabeler
534 toK1Columns =
535 hlabel labeler .
536 toColumns2
537 (toK1Columns @"Left" @_ @_ @structure1)
538 (toK1Columns @"Right" @_ @_ @structure2)
539 {-# INLINABLE fromK1Columns #-}
540 {-# INLINABLE toK1Columns #-}
543instance
544 ( HTable (K1Columns "Left" structure1)
545 , HTable (K1Columns "Right" structure2)
546 , K1Table "Left" Identity (IsStructure structure1) structure1 a
547 , K1Table "Right" Identity (IsStructure structure2) structure2 b
548 , e ~ Either a b
549 , KnownSymbol label
550 ) => K1Table label Identity 'True (Shape2 'Either structure1 structure2) e
551 where
552 fromK1Columns
553 = bimap
554 (fromK1Columns @"Left" @_ @_ @structure1)
555 (fromK1Columns @"Right" @_ @_ @structure2)
556 . fromHEitherTable
557 . hunlabel unlabeler
558 toK1Columns
559 = hlabel labeler
560 . toHEitherTable
561 . bimap
562 (toK1Columns @"Left" @_ @_ @structure1)
563 (toK1Columns @"Right" @_ @_ @structure2)
564 {-# INLINABLE fromK1Columns #-}
565 {-# INLINABLE toK1Columns #-}
568instance
569 ( HTable (K1Columns "Left" structure1)
570 , HTable (K1Columns "Right" structure2)
571 , K1Table "Left" Name (IsStructure structure1) structure1 a
572 , K1Table "Right" Name (IsStructure structure2) structure2 b
573 , e ~ EitherTable a b
574 , KnownSymbol label
575 ) => K1Table label Name 'True (Shape2 'Either structure1 structure2) e
576 where
577 fromK1Columns =
578 fromColumns2
579 (fromK1Columns @"Left" @_ @_ @structure1)
580 (fromK1Columns @"Right" @_ @_ @structure2) .
581 hunlabel unlabeler
582 toK1Columns =
583 hlabel labeler .
584 toColumns2
585 (toK1Columns @"Left" @_ @_ @structure1)
586 (toK1Columns @"Right" @_ @_ @structure2)
587 {-# INLINABLE fromK1Columns #-}
588 {-# INLINABLE toK1Columns #-}
591instance
592 ( Table Aggregate a
593 , K1Columns label structure ~ HLabel label (Columns a)
594 , as ~ ListTable a
595 , KnownSymbol label
596 ) => K1Table label Aggregate 'True (Shape1 'List structure) as
597 where
598 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
599 toK1Columns = hrelabel (hlabel hlabeler) . toColumns
600 {-# INLINABLE fromK1Columns #-}
601 {-# INLINABLE toK1Columns #-}
604instance
605 ( Table Expr a
606 , K1Columns label structure ~ HLabel label (Columns a)
607 , as ~ ListTable a
608 , KnownSymbol label
609 ) => K1Table label Expr 'True (Shape1 'List structure) as
610 where
611 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
612 toK1Columns = hrelabel (hlabel hlabeler) . toColumns
613 {-# INLINABLE fromK1Columns #-}
614 {-# INLINABLE toK1Columns #-}
617instance
618 ( Table Insertion a
619 , K1Columns label structure ~ HLabel label (Columns a)
620 , as ~ ListTable a
621 , KnownSymbol label
622 ) => K1Table label Insertion 'True (Shape1 'List structure) as
623 where
624 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
625 toK1Columns = hrelabel (hlabel hlabeler) . toColumns
626 {-# INLINABLE fromK1Columns #-}
627 {-# INLINABLE toK1Columns #-}
630instance
631 ( K1Table label Identity (IsStructure structure) structure a
632 , HTable (K1Columns label structure)
633 , as ~ [a]
634 ) => K1Table label Identity 'True (Shape1 'List structure) as
635 where
636 fromK1Columns = fmap (fromK1Columns @label @_ @_ @structure) . fromHListTable
637 toK1Columns = toHListTable . fmap (toK1Columns @label @_ @_ @structure)
638 {-# INLINABLE fromK1Columns #-}
639 {-# INLINABLE toK1Columns #-}
642instance
643 ( Table Name a
644 , K1Columns label structure ~ HLabel label (Columns a)
645 , as ~ ListTable a
646 , KnownSymbol label
647 ) => K1Table label Name 'True (Shape1 'List structure) as
648 where
649 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
650 toK1Columns = hrelabel (hlabel hlabeler) . toColumns
651 {-# INLINABLE fromK1Columns #-}
652 {-# INLINABLE toK1Columns #-}
655instance
656 ( HTable (K1Columns "Just" structure)
657 , K1Table "Just" Aggregate (IsStructure structure) structure a
658 , ma ~ MaybeTable a
659 , KnownSymbol label
660 ) => K1Table label Aggregate 'True (Shape1 'Maybe structure) ma
661 where
662 fromK1Columns =
663 fromColumns1 (fromK1Columns @"Just" @_ @_ @structure) .
664 hunlabel unlabeler
665 toK1Columns =
666 hlabel labeler .
667 toColumns1 (toK1Columns @"Just" @_ @_ @structure)
668 {-# INLINABLE fromK1Columns #-}
669 {-# INLINABLE toK1Columns #-}
672instance
673 ( HTable (K1Columns "Just" structure)
674 , K1Table "Just" Expr (IsStructure structure) structure a
675 , ma ~ MaybeTable a
676 , KnownSymbol label
677 ) => K1Table label Expr 'True (Shape1 'Maybe structure) ma
678 where
679 fromK1Columns =
680 fromColumns1 (fromK1Columns @"Just" @_ @_ @structure) .
681 hunlabel unlabeler
682 toK1Columns =
683 hlabel labeler .
684 toColumns1 (toK1Columns @"Just" @_ @_ @structure)
685 {-# INLINABLE fromK1Columns #-}
686 {-# INLINABLE toK1Columns #-}
689instance
690 ( HTable (K1Columns "Just" structure)
691 , K1Table "Just" Insertion (IsStructure structure) structure a
692 , ma ~ MaybeTable a
693 , KnownSymbol label
694 ) => K1Table label Insertion 'True (Shape1 'Maybe structure) ma
695 where
696 fromK1Columns =
697 fromColumns1 (fromK1Columns @"Just" @_ @_ @structure) .
698 hunlabel unlabeler
699 toK1Columns =
700 hlabel labeler .
701 toColumns1 (toK1Columns @"Just" @_ @_ @structure)
702 {-# INLINABLE fromK1Columns #-}
703 {-# INLINABLE toK1Columns #-}
706instance
707 ( HTable (K1Columns "Just" structure)
708 , K1Table "Just" Identity (IsStructure structure) structure a
709 , ma ~ Maybe a
710 , KnownSymbol label
711 ) => K1Table label Identity 'True (Shape1 'Maybe structure) ma
712 where
713 fromK1Columns
714 = fmap (fromK1Columns @"Just" @_ @_ @structure)
715 . fromHMaybeTable
716 . hunlabel unlabeler
717 toK1Columns
718 = hlabel labeler
719 . toHMaybeTable
720 . fmap (toK1Columns @"Just" @_ @_ @structure)
721 {-# INLINABLE fromK1Columns #-}
722 {-# INLINABLE toK1Columns #-}
725instance
726 ( HTable (K1Columns "Just" structure)
727 , K1Table "Just" Name (IsStructure structure) structure a
728 , ma ~ MaybeTable a
729 , KnownSymbol label
730 ) => K1Table label Name 'True (Shape1 'Maybe structure) ma
731 where
732 fromK1Columns =
733 fromColumns1 (fromK1Columns @"Just" @_ @_ @structure) .
734 hunlabel unlabeler
735 toK1Columns =
736 hlabel labeler .
737 toColumns1 (toK1Columns @"Just" @_ @_ @structure)
738 {-# INLINABLE fromK1Columns #-}
739 {-# INLINABLE toK1Columns #-}
742instance
743 ( Table Aggregate a
744 , K1Columns label structure ~ HLabel label (Columns a)
745 , as ~ NonEmptyTable a
746 , KnownSymbol label
747 ) => K1Table label Aggregate 'True (Shape1 'NonEmpty structure) as
748 where
749 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
750 toK1Columns = hrelabel (hlabel hlabeler) . toColumns
751 {-# INLINABLE fromK1Columns #-}
752 {-# INLINABLE toK1Columns #-}
755instance
756 ( Table Expr a
757 , K1Columns label structure ~ HLabel label (Columns a)
758 , as ~ NonEmptyTable a
759 , KnownSymbol label
760 ) => K1Table label Expr 'True (Shape1 'NonEmpty structure) as
761 where
762 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
763 toK1Columns = hrelabel (hlabel hlabeler) . toColumns
764 {-# INLINABLE fromK1Columns #-}
765 {-# INLINABLE toK1Columns #-}
768instance
769 ( Table Insertion a
770 , K1Columns label structure ~ HLabel label (Columns a)
771 , as ~ NonEmptyTable a
772 , KnownSymbol label
773 ) => K1Table label Insertion 'True (Shape1 'NonEmpty structure) as
774 where
775 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
776 toK1Columns = hrelabel (hlabel hlabeler) . toColumns
777 {-# INLINABLE fromK1Columns #-}
778 {-# INLINABLE toK1Columns #-}
781instance
782 ( K1Table label Identity (IsStructure structure) structure a
783 , HTable (K1Columns label structure)
784 , as ~ NonEmpty a
785 ) => K1Table label Identity 'True (Shape1 'NonEmpty structure) as
786 where
787 fromK1Columns = fmap (fromK1Columns @label @_ @_ @structure) . fromHNonEmptyTable
788 toK1Columns = toHNonEmptyTable . fmap (toK1Columns @label @_ @_ @structure)
789 {-# INLINABLE fromK1Columns #-}
790 {-# INLINABLE toK1Columns #-}
793instance
794 ( Table Name a
795 , K1Columns label structure ~ HLabel label (Columns a)
796 , as ~ NonEmptyTable a
797 , KnownSymbol label
798 ) => K1Table label Name 'True (Shape1 'NonEmpty structure) as
799 where
800 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
801 toK1Columns = hrelabel (hlabel hlabeler) . toColumns
802 {-# INLINABLE fromK1Columns #-}
803 {-# INLINABLE toK1Columns #-}
806instance
807 ( HTable (K1Columns "Here" structure1)
808 , HTable (K1Columns "There" structure2)
809 , K1Table "Here" Aggregate (IsStructure structure1) structure1 a
810 , K1Table "There" Aggregate (IsStructure structure2) structure2 b
811 , e ~ TheseTable a b
812 , KnownSymbol label
813 ) => K1Table label Aggregate 'True (Shape2 'These structure1 structure2) e
814 where
815 fromK1Columns =
816 fromColumns2
817 (fromK1Columns @"Here" @_ @_ @structure1)
818 (fromK1Columns @"There" @_ @_ @structure2) .
819 hunlabel unlabeler
820 toK1Columns =
821 hlabel labeler .
822 toColumns2
823 (toK1Columns @"Here" @_ @_ @structure1)
824 (toK1Columns @"There" @_ @_ @structure2)
825 {-# INLINABLE fromK1Columns #-}
826 {-# INLINABLE toK1Columns #-}
829instance
830 ( HTable (K1Columns "Here" structure1)
831 , HTable (K1Columns "There" structure2)
832 , K1Table "Here" Expr (IsStructure structure1) structure1 a
833 , K1Table "There" Expr (IsStructure structure2) structure2 b
834 , e ~ TheseTable a b
835 , KnownSymbol label
836 ) => K1Table label Expr 'True (Shape2 'These structure1 structure2) e
837 where
838 fromK1Columns =
839 fromColumns2
840 (fromK1Columns @"Here" @_ @_ @structure1)
841 (fromK1Columns @"There" @_ @_ @structure2) .
842 hunlabel unlabeler
843 toK1Columns =
844 hlabel labeler .
845 toColumns2
846 (toK1Columns @"Here" @_ @_ @structure1)
847 (toK1Columns @"There" @_ @_ @structure2)
848 {-# INLINABLE fromK1Columns #-}
849 {-# INLINABLE toK1Columns #-}
852instance
853 ( HTable (K1Columns "Here" structure1)
854 , HTable (K1Columns "There" structure2)
855 , K1Table "Here" Insertion (IsStructure structure1) structure1 a
856 , K1Table "There" Insertion (IsStructure structure2) structure2 b
857 , e ~ TheseTable a b
858 , KnownSymbol label
859 ) => K1Table label Insertion 'True (Shape2 'These structure1 structure2) e
860 where
861 fromK1Columns =
862 fromColumns2
863 (fromK1Columns @"Here" @_ @_ @structure1)
864 (fromK1Columns @"There" @_ @_ @structure2) .
865 hunlabel unlabeler
866 toK1Columns =
867 hlabel labeler .
868 toColumns2
869 (toK1Columns @"Here" @_ @_ @structure1)
870 (toK1Columns @"There" @_ @_ @structure2)
871 {-# INLINABLE fromK1Columns #-}
872 {-# INLINABLE toK1Columns #-}
875instance
876 ( HTable (K1Columns "Here" structure1)
877 , HTable (K1Columns "There" structure2)
878 , K1Table "Here" Identity (IsStructure structure1) structure1 a
879 , K1Table "There" Identity (IsStructure structure2) structure2 b
880 , e ~ These a b
881 , KnownSymbol label
882 ) => K1Table label Identity 'True (Shape2 'These structure1 structure2) e
883 where
884 fromK1Columns
885 = bimap
886 (fromK1Columns @"Here" @_ @_ @structure1)
887 (fromK1Columns @"There" @_ @_ @structure2)
888 . fromHTheseTable
889 . hunlabel unlabeler
890 toK1Columns
891 = hlabel labeler
892 . toHTheseTable
893 . bimap
894 (toK1Columns @"Here" @_ @_ @structure1)
895 (toK1Columns @"There" @_ @_ @structure2)
896 {-# INLINABLE fromK1Columns #-}
897 {-# INLINABLE toK1Columns #-}
900instance
901 ( HTable (K1Columns "Here" structure1)
902 , HTable (K1Columns "There" structure2)
903 , K1Table "Here" Name (IsStructure structure1) structure1 a
904 , K1Table "There" Name (IsStructure structure2) structure2 b
905 , e ~ TheseTable a b
906 , KnownSymbol label
907 ) => K1Table label Name 'True (Shape2 'These structure1 structure2) e
908 where
909 fromK1Columns =
910 fromColumns2
911 (fromK1Columns @"Here" @_ @_ @structure1)
912 (fromK1Columns @"There" @_ @_ @structure2) .
913 hunlabel unlabeler
914 toK1Columns =
915 hlabel labeler .
916 toColumns2
917 (toK1Columns @"Here" @_ @_ @structure1)
918 (toK1Columns @"There" @_ @_ @structure2)
919 {-# INLINABLE fromK1Columns #-}
920 {-# INLINABLE toK1Columns #-}
923instance
924 ( K1Table "fst" context (IsStructure structure1) structure1 a1
925 , K1Table "snd" context (IsStructure structure2) structure2 a2
926 , HTable (K1Columns "fst" structure1)
927 , HTable (K1Columns "snd" structure2)
928 , Labelable context
929 , a ~ (a1, a2)
930 , KnownSymbol label
931 ) => K1Table label context 'True (structure1, structure2) a
932 where
933 fromK1Columns (hunlabel unlabeler -> (HPair a b)) =
934 ( fromK1Columns @"fst" @_ @_ @structure1 a
935 , fromK1Columns @"snd" @_ @_ @structure2 b
936 )
937 toK1Columns (a, b) = hlabel labeler $ HPair
938 { hfst = toK1Columns @"fst" @_ @_ @structure1 a
939 , hsnd = toK1Columns @"snd" @_ @_ @structure2 b
940 }
941 {-# INLINABLE fromK1Columns #-}
942 {-# INLINABLE toK1Columns #-}
945instance
946 ( K1Table "fst" context (IsStructure structure1) structure1 a1
947 , K1Table "snd" context (IsStructure structure2) structure2 a2
948 , K1Table "trd" context (IsStructure structure3) structure3 a3
949 , HTable (K1Columns "fst" structure1)
950 , HTable (K1Columns "snd" structure2)
951 , HTable (K1Columns "trd" structure3)
952 , Labelable context
953 , a ~ (a1, a2, a3)
954 , KnownSymbol label
955 ) => K1Table label context 'True (structure1, structure2, structure3) a
956 where
957 fromK1Columns (hunlabel unlabeler -> (HTrio a b c)) =
958 ( fromK1Columns @"fst" @_ @_ @structure1 a
959 , fromK1Columns @"snd" @_ @_ @structure2 b
960 , fromK1Columns @"trd" @_ @_ @structure3 c
961 )
962 toK1Columns (a, b, c) = hlabel labeler $ HTrio
963 { hfst = toK1Columns @"fst" @_ @_ @structure1 a
964 , hsnd = toK1Columns @"snd" @_ @_ @structure2 b
965 , htrd = toK1Columns @"trd" @_ @_ @structure3 c
966 }
967 {-# INLINABLE fromK1Columns #-}
968 {-# INLINABLE toK1Columns #-}
971instance
972 ( K1Table "fst" context (IsStructure structure1) structure1 a1
973 , K1Table "snd" context (IsStructure structure2) structure2 a2
974 , K1Table "trd" context (IsStructure structure3) structure3 a3
975 , K1Table "frt" context (IsStructure structure3) structure4 a4
976 , HTable (K1Columns "fst" structure1)
977 , HTable (K1Columns "snd" structure2)
978 , HTable (K1Columns "trd" structure3)
979 , HTable (K1Columns "frt" structure4)
980 , Labelable context
981 , a ~ (a1, a2, a3, a4)
982 , KnownSymbol label
983 ) => K1Table label context 'True (structure1, structure2, structure3, structure4) a
984 where
985 fromK1Columns (hunlabel unlabeler -> (HQuartet a b c d)) =
986 ( fromK1Columns @"fst" @_ @_ @structure1 a
987 , fromK1Columns @"snd" @_ @_ @structure2 b
988 , fromK1Columns @"trd" @_ @_ @structure3 c
989 , fromK1Columns @"frt" @_ @_ @structure4 d
990 )
991 toK1Columns (a, b, c, d) = hlabel labeler $ HQuartet
992 { hfst = toK1Columns @"fst" @_ @_ @structure1 a
993 , hsnd = toK1Columns @"snd" @_ @_ @structure2 b
994 , htrd = toK1Columns @"trd" @_ @_ @structure3 c
995 , hfrt = toK1Columns @"frt" @_ @_ @structure4 d
996 }
997 {-# INLINABLE fromK1Columns #-}
998 {-# INLINABLE toK1Columns #-}
1001instance
1002 ( K1Table "fst" context (IsStructure structure1) structure1 a1
1003 , K1Table "snd" context (IsStructure structure2) structure2 a2
1004 , K1Table "trd" context (IsStructure structure3) structure3 a3
1005 , K1Table "frt" context (IsStructure structure3) structure4 a4
1006 , K1Table "fft" context (IsStructure structure3) structure5 a5
1007 , HTable (K1Columns "fst" structure1)
1008 , HTable (K1Columns "snd" structure2)
1009 , HTable (K1Columns "trd" structure3)
1010 , HTable (K1Columns "frt" structure4)
1011 , HTable (K1Columns "fft" structure5)
1012 , Labelable context
1013 , a ~ (a1, a2, a3, a4, a5)
1014 , KnownSymbol label
1015 ) => K1Table label context 'True (structure1, structure2, structure3, structure4, structure5) a
1016 where
1017 fromK1Columns (hunlabel unlabeler -> (HQuintet a b c d e)) =
1018 ( fromK1Columns @"fst" @_ @_ @structure1 a
1019 , fromK1Columns @"snd" @_ @_ @structure2 b
1020 , fromK1Columns @"trd" @_ @_ @structure3 c
1021 , fromK1Columns @"frt" @_ @_ @structure4 d
1022 , fromK1Columns @"fft" @_ @_ @structure5 e
1024 toK1Columns (a, b, c, d, e) = hlabel labeler $ HQuintet
1025 { hfst = toK1Columns @"fst" @_ @_ @structure1 a
1026 , hsnd = toK1Columns @"snd" @_ @_ @structure2 b
1027 , htrd = toK1Columns @"trd" @_ @_ @structure3 c
1028 , hfrt = toK1Columns @"frt" @_ @_ @structure4 d
1029 , hfft = toK1Columns @"fft" @_ @_ @structure5 e
1031 {-# INLINABLE fromK1Columns #-}
1032 {-# INLINABLE toK1Columns #-}
1035instance
1036 ( IsStructure structure ~ 'False
1037 , K1Columns label structure ~ HLabel label (Columns structure)
1038 , Columns structure ~ Columns a
1039 , Labelable context
1040 , Table context a
1041 , KnownSymbol label
1042 ) => K1Table label context 'False structure a
1043 where
1044 fromK1Columns = fromColumns . hunlabel unlabeler
1045 toK1Columns = hlabel labeler . toColumns
1046 {-# INLINABLE fromK1Columns #-}
1047 {-# INLINABLE toK1Columns #-}