git.iko.soy/rel8
on ca7aaef help sign in
rel8/src/Rel8/Schema/Generic.hs
1049 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, Col(..) )
40import Rel8.Expr ( Expr, Col(..) )
41import Rel8.Kind.Necessity
42 ( SNecessity( SRequired, SOptional )
43 , KnownNecessity, necessitySing
44 )
45import Rel8.Schema.Context ( Col(..) )
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 Rel8.Schema.Insert ( Insert, Col(..) )
72import qualified Rel8.Schema.Kind as K
73import Rel8.Schema.Name ( Name( Name ), Col(..) )
74import Rel8.Schema.Spec ( Spec( Spec ), KTable )
75import Rel8.Schema.Structure
76 ( IsStructure, Shape(..), Shape1, Shape2
77 , Structure
78 )
79import Rel8.Table
80 ( Table, Columns, Context, fromColumns, toColumns
81 )
82import Rel8.Table.Either ( EitherTable )
83import Rel8.Table.Lifted
84 ( fromColumns1, toColumns1
85 , fromColumns2, toColumns2
86 )
87import Rel8.Table.List ( ListTable )
88import Rel8.Table.Maybe ( MaybeTable(..) )
89import Rel8.Table.NonEmpty ( NonEmptyTable )
90import Rel8.Table.These ( TheseTable )
92-- these
93import Data.These ( These )
96instance (Rel8able t, TableHelper context) => Table context (t context) where
97 type Columns (t context) = GRep t
98 type Context (t context) = context
99 fromColumns = gfromColumns
100 toColumns = gtoColumns
103type TableHelper :: K.Context -> Constraint
104class TableHelper context where
105 gfromColumns :: Rel8able t => GRep t (Col context) -> t context
106 gtoColumns :: Rel8able t => t context -> GRep t (Col context)
109instance TableHelper Aggregate where
110 gfromColumns = fromAggregateColumns
111 gtoColumns = toAggregateColumns
114instance TableHelper Expr where
115 gfromColumns = fromExprColumns
116 gtoColumns = toExprColumns
119instance TableHelper Insert where
120 gfromColumns = fromInsertColumns
121 gtoColumns = toInsertColumns
124instance TableHelper Identity where
125 gfromColumns = fromIdentityColumns
126 gtoColumns = toIdentityColumns
129instance TableHelper Name where
130 gfromColumns = fromNameColumns
131 gtoColumns = toNameColumns
134-- | This type class allows you to define custom 'Table's using higher-kinded
135-- data types. Higher-kinded data types are data types of the pattern:
136--
137-- @
138-- data MyType f =
139-- MyType { field1 :: Column f T1 OR HK1 f
140-- , field2 :: Column f T2 OR HK2 f
141-- , ...
142-- , fieldN :: Column f Tn OR HKn f
143-- }
144-- @
145--
146-- where @Tn@ is any Haskell type, and @HKn@ is any higher-kinded type.
147--
148-- That is, higher-kinded data are records where all fields in the record are
149-- all either of the type @Column f T@ (for any @T@), or are themselves
150-- higher-kinded data:
151--
152-- [Nested]
153--
154-- @
155-- data Nested f =
156-- Nested { nested1 :: MyType f
157-- , nested2 :: MyType f
158-- }
159-- @
160--
161-- The @Rel8able@ type class is used to give us a special mapping operation
162-- that lets us change the type parameter @f@.
163--
164-- [Supplying @Rel8able@ instances]
165--
166-- This type class should be derived generically for all table types in your
167-- project. To do this, enable the @DeriveAnyType@ and @DeriveGeneric@ language
168-- extensions:
169--
170-- @
171-- \{\-\# LANGUAGE DeriveAnyClass, DeriveGeneric #-\}
172--
173-- data MyType f = MyType { fieldA :: Column f T }
174-- deriving ( GHC.Generics.Generic, Rel8able )
175-- @
176type Rel8able :: KTable -> Constraint
177class HTable (GRep t) => Rel8able t where
178 type GRep t :: K.HTable
180 fromAggregateColumns :: GRep t (Col Aggregate) -> t Aggregate
181 toAggregateColumns :: t Aggregate -> GRep t (Col Aggregate)
183 fromExprColumns :: GRep t (Col Expr) -> t Expr
184 toExprColumns :: t Expr -> GRep t (Col Expr)
186 fromInsertColumns :: GRep t (Col Insert) -> t Insert
187 toInsertColumns :: t Insert -> GRep t (Col Insert)
189 fromIdentityColumns :: GRep t (Col Identity) -> t Identity
190 toIdentityColumns :: t Identity -> GRep t (Col Identity)
192 fromNameColumns :: GRep t (Col Name) -> t Name
193 toNameColumns :: t Name -> GRep t (Col Name)
195 type GRep t = GColumns (Rep (t Structure))
197 default fromAggregateColumns ::
198 ( Generic (t Aggregate)
199 , GColumns (Rep (t Structure)) ~ GRep t
200 , GRel8able Aggregate (Rep (t Structure)) (Rep (t Aggregate))
201 ) => GRep t (Col Aggregate) -> t Aggregate
202 fromAggregateColumns = to . fromGColumns @_ @(Rep (t Structure))
204 default toAggregateColumns ::
205 ( Generic (t Aggregate)
206 , GColumns (Rep (t Structure)) ~ GRep t
207 , GRel8able Aggregate (Rep (t Structure)) (Rep (t Aggregate))
208 ) => t Aggregate -> GRep t (Col Aggregate)
209 toAggregateColumns = toGColumns @_ @(Rep (t Structure)) . from
211 default fromExprColumns ::
212 ( Generic (t Expr)
213 , GColumns (Rep (t Structure)) ~ GRep t
214 , GRel8able Expr (Rep (t Structure)) (Rep (t Expr))
215 ) => GRep t (Col Expr) -> t Expr
216 fromExprColumns = to . fromGColumns @_ @(Rep (t Structure))
218 default toExprColumns ::
219 ( Generic (t Expr)
220 , GColumns (Rep (t Structure)) ~ GRep t
221 , GRel8able Expr (Rep (t Structure)) (Rep (t Expr))
222 ) => t Expr -> GRep t (Col Expr)
223 toExprColumns = toGColumns @_ @(Rep (t Structure)) . from
225 default fromInsertColumns ::
226 ( Generic (t Insert)
227 , GColumns (Rep (t Structure)) ~ GRep t
228 , GRel8able Insert (Rep (t Structure)) (Rep (t Insert))
229 ) => GRep t (Col Insert) -> t Insert
230 fromInsertColumns = to . fromGColumns @_ @(Rep (t Structure))
232 default toInsertColumns ::
233 ( Generic (t Insert)
234 , GColumns (Rep (t Structure)) ~ GRep t
235 , GRel8able Insert (Rep (t Structure)) (Rep (t Insert))
236 ) => t Insert -> GRep t (Col Insert)
237 toInsertColumns = toGColumns @_ @(Rep (t Structure)) . from
239 default fromIdentityColumns ::
240 ( Generic (t Identity)
241 , GColumns (Rep (t Structure)) ~ GRep t
242 , GRel8able Identity (Rep (t Structure)) (Rep (t Identity))
243 ) => GRep t (Col Identity) -> t Identity
244 fromIdentityColumns = to . fromGColumns @_ @(Rep (t Structure))
246 default toIdentityColumns ::
247 ( Generic (t Identity)
248 , GColumns (Rep (t Structure)) ~ GRep t
249 , GRel8able Identity (Rep (t Structure)) (Rep (t Identity))
250 ) => t Identity -> GRep t (Col Identity)
251 toIdentityColumns = toGColumns @_ @(Rep (t Structure)) . from
253 default fromNameColumns ::
254 ( Generic (t Name)
255 , GColumns (Rep (t Structure)) ~ GRep t
256 , GRel8able Name (Rep (t Structure)) (Rep (t Name))
257 ) => GRep t (Col Name) -> t Name
258 fromNameColumns = to . fromGColumns @_ @(Rep (t Structure))
260 default toNameColumns ::
261 ( Generic (t Name)
262 , GColumns (Rep (t Structure)) ~ GRep t
263 , GRel8able Name (Rep (t Structure)) (Rep (t Name))
264 ) => t Name -> GRep t (Col Name)
265 toNameColumns = toGColumns @_ @(Rep (t Structure)) . from
268type GColumns :: (Type -> Type) -> K.HTable
269type family GColumns structure where
270 GColumns (M1 D _ structure) = GColumns structure
271 GColumns (M1 C _ structure) = GColumns structure
272 GColumns (a :*: b) = HPair (GColumns a) (GColumns b)
273 GColumns (M1 S ('MetaSel ('Just label) _ _ _) (K1 _ structure)) =
274 K1Columns label structure
277type GRel8able :: K.Context -> (Type -> Type) -> (Type -> Type) -> Constraint
278class GRel8able context structure rep where
279 fromGColumns :: GColumns structure (Col context) -> rep x
280 toGColumns :: rep x -> GColumns structure (Col context)
283instance GRel8able context structure rep => GRel8able context (M1 D c structure) (M1 D c rep) where
284 fromGColumns = M1 . fromGColumns @context @structure @rep
285 toGColumns (M1 a) = toGColumns @context @structure @rep a
288instance GRel8able context structure rep => GRel8able context (M1 C c structure) (M1 C c rep) where
289 fromGColumns = M1 . fromGColumns @context @structure @rep
290 toGColumns (M1 a) = toGColumns @context @structure @rep a
293instance (GRel8able context structure1 rep1, GRel8able context structure2 rep2) =>
294 GRel8able context (structure1 :*: structure2) (rep1 :*: rep2)
295 where
296 fromGColumns (HPair a b) =
297 fromGColumns @context @structure1 @rep1 a :*:
298 fromGColumns @context @structure2 @rep2 b
299 toGColumns (a :*: b) =
300 HPair
301 (toGColumns @context @structure1 @rep1 a)
302 (toGColumns @context @structure2 @rep2 b)
305instance
306 ( K1Table label context isStructure structure a
307 , meta ~ 'MetaSel ('Just label) _su _ss _ds
308 , structureK1 ~ K1 i structure
309 , k1 ~ K1 i a
310 ) => GRel8able context (M1 S meta structureK1) (M1 S meta k1)
311 where
312 fromGColumns = M1 . K1 . fromK1Columns @label @_ @_ @structure
313 toGColumns (M1 (K1 a)) = toK1Columns @label @_ @_ @structure a
316type K1Columns :: Symbol -> Type -> K.HTable
317type family K1Columns label structure where
318 K1Columns label (Shape1 'Column ('Spec '[] necessity a)) =
319 HIdentity ('Spec '[label] necessity a)
320 K1Columns _label (Shape1 'Column ('Spec (label ': labels) necessity a)) =
321 HIdentity ('Spec (label ': labels) necessity a)
322 K1Columns label (Shape2 'Either a b) =
323 HLabel label (HEitherTable (K1Columns "Left" a) (K1Columns "Right" b))
324 K1Columns label (Shape1 'List a) = HListTable (K1Columns label a)
325 K1Columns label (Shape1 'Maybe a) = HLabel label (HMaybeTable (K1Columns "Just" a))
326 K1Columns label (Shape1 'NonEmpty a) = HNonEmptyTable (K1Columns label a)
327 K1Columns label (Shape2 'These a b) =
328 HLabel label (HTheseTable (K1Columns "Here" a) (K1Columns "There" b))
329 K1Columns label (a, b) =
330 HLabel label
331 (HPair
332 (K1Columns "fst" a)
333 (K1Columns "snd" b))
334 K1Columns label (a, b, c) =
335 HLabel label
336 (HTrio
337 (K1Columns "fst" a)
338 (K1Columns "snd" b)
339 (K1Columns "trd" c))
340 K1Columns label (a, b, c, d) =
341 HLabel label
342 (HQuartet
343 (K1Columns "fst" a)
344 (K1Columns "snd" b)
345 (K1Columns "trd" c)
346 (K1Columns "frt" d))
347 K1Columns label (a, b, c, d, e) =
348 HLabel label
349 (HQuintet
350 (K1Columns "fst" a)
351 (K1Columns "snd" b)
352 (K1Columns "trd" c)
353 (K1Columns "frt" d)
354 (K1Columns "fft" e))
355 K1Columns label a = HLabel label (Columns a)
358type K1Table :: Symbol -> K.Context -> Bool -> Type -> Type -> Constraint
359class isStructure ~ IsStructure structure =>
360 K1Table label context isStructure structure a
361 where
362 fromK1Columns :: K1Columns label structure (Col context) -> a
363 toK1Columns :: a -> K1Columns label structure (Col context)
366instance
367 ( x ~ Field Aggregate '[] necessity a
368 ) => K1Table label Aggregate 'True (Shape1 'Column ('Spec '[] necessity a)) x
369 where
370 fromK1Columns (HIdentity (Aggregation a)) = a
371 toK1Columns = HIdentity . Aggregation
372 {-# INLINABLE fromK1Columns #-}
373 {-# INLINABLE toK1Columns #-}
376instance
377 ( x ~ Field Aggregate (label ': labels) necessity a
378 ) => K1Table _label Aggregate 'True (Shape1 'Column ('Spec (label ': labels) necessity a)) x
379 where
380 fromK1Columns (HIdentity (Aggregation a)) = a
381 toK1Columns = HIdentity . Aggregation
382 {-# INLINABLE fromK1Columns #-}
383 {-# INLINABLE toK1Columns #-}
386instance
387 ( x ~ Field Expr '[] necessity a
388 ) => K1Table label Expr 'True (Shape1 'Column ('Spec '[] necessity a)) x
389 where
390 fromK1Columns (HIdentity (DB a)) = a
391 toK1Columns = HIdentity . DB
392 {-# INLINABLE fromK1Columns #-}
393 {-# INLINABLE toK1Columns #-}
396instance
397 ( x ~ Field Expr (label ': labels) necessity a
398 ) => K1Table _label Expr 'True (Shape1 'Column ('Spec (label ': labels) necessity a)) x
399 where
400 fromK1Columns (HIdentity (DB a)) = a
401 toK1Columns = HIdentity . DB
402 {-# INLINABLE fromK1Columns #-}
403 {-# INLINABLE toK1Columns #-}
406instance
407 ( x ~ Field Insert '[] necessity a
408 , KnownNecessity necessity
409 ) => K1Table label Insert 'True (Shape1 'Column ('Spec '[] necessity a)) x
410 where
411 fromK1Columns (HIdentity insert) = case insert of
412 RequiredInsert a -> a
413 OptionalInsert ma -> ma
414 toK1Columns a = HIdentity $ case necessitySing @necessity of
415 SRequired -> RequiredInsert a
416 SOptional -> OptionalInsert a
417 {-# INLINABLE fromK1Columns #-}
418 {-# INLINABLE toK1Columns #-}
421instance
422 ( x ~ Field Insert (label ': labels) necessity a
423 , KnownNecessity necessity
424 ) => K1Table _label Insert 'True (Shape1 'Column ('Spec (label ': labels) necessity 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 Identity '[] necessity a
438 ) => K1Table label Identity 'True (Shape1 'Column ('Spec '[] necessity a)) x
439 where
440 fromK1Columns (HIdentity (Result a)) = a
441 toK1Columns = HIdentity . Result
442 {-# INLINABLE fromK1Columns #-}
443 {-# INLINABLE toK1Columns #-}
446instance
447 ( x ~ Field Identity (label ': labels) necessity a
448 ) => K1Table _label Identity 'True (Shape1 'Column ('Spec (label ': labels) necessity a)) x
449 where
450 fromK1Columns (HIdentity (Result a)) = a
451 toK1Columns = HIdentity . Result
452 {-# INLINABLE fromK1Columns #-}
453 {-# INLINABLE toK1Columns #-}
456instance
457 ( x ~ Field Name '[] necessity a
458 ) => K1Table _label Name 'True (Shape1 'Column ('Spec (label ': labels) necessity a)) x
459 where
460 fromK1Columns (HIdentity (NameCol a)) = Name a
461 toK1Columns (Name a) = HIdentity (NameCol a)
462 {-# INLINABLE fromK1Columns #-}
463 {-# INLINABLE toK1Columns #-}
466instance
467 ( x ~ Field Name (label ': labels) necessity a
468 ) => K1Table label Name 'True (Shape1 'Column ('Spec '[] necessity a)) x
469 where
470 fromK1Columns = Name . (\(NameCol a) -> a) . unlabeler . unHIdentity
471 toK1Columns = HIdentity . labeler . NameCol . (\(Name a) -> a)
472 {-# INLINABLE fromK1Columns #-}
473 {-# INLINABLE toK1Columns #-}
476instance
477 ( HTable (K1Columns "Left" structure1)
478 , HTable (K1Columns "Right" structure2)
479 , K1Table "Left" Aggregate (IsStructure structure1) structure1 a
480 , K1Table "Right" Aggregate (IsStructure structure2) structure2 b
481 , e ~ EitherTable a b
482 , KnownSymbol label
483 ) => K1Table label Aggregate 'True (Shape2 'Either structure1 structure2) e
484 where
485 fromK1Columns =
486 fromColumns2
487 (fromK1Columns @"Left" @_ @_ @structure1)
488 (fromK1Columns @"Right" @_ @_ @structure2) .
489 hunlabel unlabeler
490 toK1Columns =
491 hlabel labeler .
492 toColumns2
493 (toK1Columns @"Left" @_ @_ @structure1)
494 (toK1Columns @"Right" @_ @_ @structure2)
495 {-# INLINABLE fromK1Columns #-}
496 {-# INLINABLE toK1Columns #-}
499instance
500 ( HTable (K1Columns "Left" structure1)
501 , HTable (K1Columns "Right" structure2)
502 , K1Table "Left" Expr (IsStructure structure1) structure1 a
503 , K1Table "Right" Expr (IsStructure structure2) structure2 b
504 , e ~ EitherTable a b
505 , KnownSymbol label
506 ) => K1Table label Expr 'True (Shape2 'Either structure1 structure2) e
507 where
508 fromK1Columns =
509 fromColumns2
510 (fromK1Columns @"Left" @_ @_ @structure1)
511 (fromK1Columns @"Right" @_ @_ @structure2) .
512 hunlabel unlabeler
513 toK1Columns =
514 hlabel labeler .
515 toColumns2
516 (toK1Columns @"Left" @_ @_ @structure1)
517 (toK1Columns @"Right" @_ @_ @structure2)
518 {-# INLINABLE fromK1Columns #-}
519 {-# INLINABLE toK1Columns #-}
522instance
523 ( HTable (K1Columns "Left" structure1)
524 , HTable (K1Columns "Right" structure2)
525 , K1Table "Left" Insert (IsStructure structure1) structure1 a
526 , K1Table "Right" Insert (IsStructure structure2) structure2 b
527 , e ~ EitherTable a b
528 , KnownSymbol label
529 ) => K1Table label Insert 'True (Shape2 'Either structure1 structure2) e
530 where
531 fromK1Columns =
532 fromColumns2
533 (fromK1Columns @"Left" @_ @_ @structure1)
534 (fromK1Columns @"Right" @_ @_ @structure2) .
535 hunlabel unlabeler
536 toK1Columns =
537 hlabel labeler .
538 toColumns2
539 (toK1Columns @"Left" @_ @_ @structure1)
540 (toK1Columns @"Right" @_ @_ @structure2)
541 {-# INLINABLE fromK1Columns #-}
542 {-# INLINABLE toK1Columns #-}
545instance
546 ( HTable (K1Columns "Left" structure1)
547 , HTable (K1Columns "Right" structure2)
548 , K1Table "Left" Identity (IsStructure structure1) structure1 a
549 , K1Table "Right" Identity (IsStructure structure2) structure2 b
550 , e ~ Either a b
551 , KnownSymbol label
552 ) => K1Table label Identity 'True (Shape2 'Either structure1 structure2) e
553 where
554 fromK1Columns
555 = bimap
556 (fromK1Columns @"Left" @_ @_ @structure1)
557 (fromK1Columns @"Right" @_ @_ @structure2)
558 . fromHEitherTable
559 . hunlabel unlabeler
560 toK1Columns
561 = hlabel labeler
562 . toHEitherTable
563 . bimap
564 (toK1Columns @"Left" @_ @_ @structure1)
565 (toK1Columns @"Right" @_ @_ @structure2)
566 {-# INLINABLE fromK1Columns #-}
567 {-# INLINABLE toK1Columns #-}
570instance
571 ( HTable (K1Columns "Left" structure1)
572 , HTable (K1Columns "Right" structure2)
573 , K1Table "Left" Name (IsStructure structure1) structure1 a
574 , K1Table "Right" Name (IsStructure structure2) structure2 b
575 , e ~ EitherTable a b
576 , KnownSymbol label
577 ) => K1Table label Name 'True (Shape2 'Either structure1 structure2) e
578 where
579 fromK1Columns =
580 fromColumns2
581 (fromK1Columns @"Left" @_ @_ @structure1)
582 (fromK1Columns @"Right" @_ @_ @structure2) .
583 hunlabel unlabeler
584 toK1Columns =
585 hlabel labeler .
586 toColumns2
587 (toK1Columns @"Left" @_ @_ @structure1)
588 (toK1Columns @"Right" @_ @_ @structure2)
589 {-# INLINABLE fromK1Columns #-}
590 {-# INLINABLE toK1Columns #-}
593instance
594 ( Table Aggregate a
595 , K1Columns label structure ~ HLabel label (Columns a)
596 , as ~ ListTable a
597 , KnownSymbol label
598 ) => K1Table label Aggregate 'True (Shape1 'List structure) as
599 where
600 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
601 toK1Columns = hrelabel (hlabel hlabeler) . toColumns
602 {-# INLINABLE fromK1Columns #-}
603 {-# INLINABLE toK1Columns #-}
606instance
607 ( Table Expr a
608 , K1Columns label structure ~ HLabel label (Columns a)
609 , as ~ ListTable a
610 , KnownSymbol label
611 ) => K1Table label Expr 'True (Shape1 'List structure) as
612 where
613 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
614 toK1Columns = hrelabel (hlabel hlabeler) . toColumns
615 {-# INLINABLE fromK1Columns #-}
616 {-# INLINABLE toK1Columns #-}
619instance
620 ( Table Insert a
621 , K1Columns label structure ~ HLabel label (Columns a)
622 , as ~ ListTable a
623 , KnownSymbol label
624 ) => K1Table label Insert 'True (Shape1 'List structure) as
625 where
626 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
627 toK1Columns = hrelabel (hlabel hlabeler) . toColumns
628 {-# INLINABLE fromK1Columns #-}
629 {-# INLINABLE toK1Columns #-}
632instance
633 ( K1Table label Identity (IsStructure structure) structure a
634 , HTable (K1Columns label structure)
635 , as ~ [a]
636 ) => K1Table label Identity 'True (Shape1 'List structure) as
637 where
638 fromK1Columns = fmap (fromK1Columns @label @_ @_ @structure) . fromHListTable
639 toK1Columns = toHListTable . fmap (toK1Columns @label @_ @_ @structure)
640 {-# INLINABLE fromK1Columns #-}
641 {-# INLINABLE toK1Columns #-}
644instance
645 ( Table Name a
646 , K1Columns label structure ~ HLabel label (Columns a)
647 , as ~ ListTable a
648 , KnownSymbol label
649 ) => K1Table label Name 'True (Shape1 'List structure) as
650 where
651 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
652 toK1Columns = hrelabel (hlabel hlabeler) . toColumns
653 {-# INLINABLE fromK1Columns #-}
654 {-# INLINABLE toK1Columns #-}
657instance
658 ( HTable (K1Columns "Just" structure)
659 , K1Table "Just" Aggregate (IsStructure structure) structure a
660 , ma ~ MaybeTable a
661 , KnownSymbol label
662 ) => K1Table label Aggregate 'True (Shape1 'Maybe structure) ma
663 where
664 fromK1Columns =
665 fromColumns1 (fromK1Columns @"Just" @_ @_ @structure) .
666 hunlabel unlabeler
667 toK1Columns =
668 hlabel labeler .
669 toColumns1 (toK1Columns @"Just" @_ @_ @structure)
670 {-# INLINABLE fromK1Columns #-}
671 {-# INLINABLE toK1Columns #-}
674instance
675 ( HTable (K1Columns "Just" structure)
676 , K1Table "Just" Expr (IsStructure structure) structure a
677 , ma ~ MaybeTable a
678 , KnownSymbol label
679 ) => K1Table label Expr '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" Insert (IsStructure structure) structure a
694 , ma ~ MaybeTable a
695 , KnownSymbol label
696 ) => K1Table label Insert 'True (Shape1 'Maybe structure) ma
697 where
698 fromK1Columns =
699 fromColumns1 (fromK1Columns @"Just" @_ @_ @structure) .
700 hunlabel unlabeler
701 toK1Columns =
702 hlabel labeler .
703 toColumns1 (toK1Columns @"Just" @_ @_ @structure)
704 {-# INLINABLE fromK1Columns #-}
705 {-# INLINABLE toK1Columns #-}
708instance
709 ( HTable (K1Columns "Just" structure)
710 , K1Table "Just" Identity (IsStructure structure) structure a
711 , ma ~ Maybe a
712 , KnownSymbol label
713 ) => K1Table label Identity 'True (Shape1 'Maybe structure) ma
714 where
715 fromK1Columns
716 = fmap (fromK1Columns @"Just" @_ @_ @structure)
717 . fromHMaybeTable
718 . hunlabel unlabeler
719 toK1Columns
720 = hlabel labeler
721 . toHMaybeTable
722 . fmap (toK1Columns @"Just" @_ @_ @structure)
723 {-# INLINABLE fromK1Columns #-}
724 {-# INLINABLE toK1Columns #-}
727instance
728 ( HTable (K1Columns "Just" structure)
729 , K1Table "Just" Name (IsStructure structure) structure a
730 , ma ~ MaybeTable a
731 , KnownSymbol label
732 ) => K1Table label Name 'True (Shape1 'Maybe structure) ma
733 where
734 fromK1Columns =
735 fromColumns1 (fromK1Columns @"Just" @_ @_ @structure) .
736 hunlabel unlabeler
737 toK1Columns =
738 hlabel labeler .
739 toColumns1 (toK1Columns @"Just" @_ @_ @structure)
740 {-# INLINABLE fromK1Columns #-}
741 {-# INLINABLE toK1Columns #-}
744instance
745 ( Table Aggregate a
746 , K1Columns label structure ~ HLabel label (Columns a)
747 , as ~ NonEmptyTable a
748 , KnownSymbol label
749 ) => K1Table label Aggregate 'True (Shape1 'NonEmpty structure) as
750 where
751 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
752 toK1Columns = hrelabel (hlabel hlabeler) . toColumns
753 {-# INLINABLE fromK1Columns #-}
754 {-# INLINABLE toK1Columns #-}
757instance
758 ( Table Expr a
759 , K1Columns label structure ~ HLabel label (Columns a)
760 , as ~ NonEmptyTable a
761 , KnownSymbol label
762 ) => K1Table label Expr 'True (Shape1 'NonEmpty structure) as
763 where
764 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
765 toK1Columns = hrelabel (hlabel hlabeler) . toColumns
766 {-# INLINABLE fromK1Columns #-}
767 {-# INLINABLE toK1Columns #-}
770instance
771 ( Table Insert a
772 , K1Columns label structure ~ HLabel label (Columns a)
773 , as ~ NonEmptyTable a
774 , KnownSymbol label
775 ) => K1Table label Insert 'True (Shape1 'NonEmpty structure) as
776 where
777 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
778 toK1Columns = hrelabel (hlabel hlabeler) . toColumns
779 {-# INLINABLE fromK1Columns #-}
780 {-# INLINABLE toK1Columns #-}
783instance
784 ( K1Table label Identity (IsStructure structure) structure a
785 , HTable (K1Columns label structure)
786 , as ~ NonEmpty a
787 ) => K1Table label Identity 'True (Shape1 'NonEmpty structure) as
788 where
789 fromK1Columns = fmap (fromK1Columns @label @_ @_ @structure) . fromHNonEmptyTable
790 toK1Columns = toHNonEmptyTable . fmap (toK1Columns @label @_ @_ @structure)
791 {-# INLINABLE fromK1Columns #-}
792 {-# INLINABLE toK1Columns #-}
795instance
796 ( Table Name a
797 , K1Columns label structure ~ HLabel label (Columns a)
798 , as ~ NonEmptyTable a
799 , KnownSymbol label
800 ) => K1Table label Name 'True (Shape1 'NonEmpty structure) as
801 where
802 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
803 toK1Columns = hrelabel (hlabel hlabeler) . toColumns
804 {-# INLINABLE fromK1Columns #-}
805 {-# INLINABLE toK1Columns #-}
808instance
809 ( HTable (K1Columns "Here" structure1)
810 , HTable (K1Columns "There" structure2)
811 , K1Table "Here" Aggregate (IsStructure structure1) structure1 a
812 , K1Table "There" Aggregate (IsStructure structure2) structure2 b
813 , e ~ TheseTable a b
814 , KnownSymbol label
815 ) => K1Table label Aggregate 'True (Shape2 'These structure1 structure2) e
816 where
817 fromK1Columns =
818 fromColumns2
819 (fromK1Columns @"Here" @_ @_ @structure1)
820 (fromK1Columns @"There" @_ @_ @structure2) .
821 hunlabel unlabeler
822 toK1Columns =
823 hlabel labeler .
824 toColumns2
825 (toK1Columns @"Here" @_ @_ @structure1)
826 (toK1Columns @"There" @_ @_ @structure2)
827 {-# INLINABLE fromK1Columns #-}
828 {-# INLINABLE toK1Columns #-}
831instance
832 ( HTable (K1Columns "Here" structure1)
833 , HTable (K1Columns "There" structure2)
834 , K1Table "Here" Expr (IsStructure structure1) structure1 a
835 , K1Table "There" Expr (IsStructure structure2) structure2 b
836 , e ~ TheseTable a b
837 , KnownSymbol label
838 ) => K1Table label Expr '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" Insert (IsStructure structure1) structure1 a
858 , K1Table "There" Insert (IsStructure structure2) structure2 b
859 , e ~ TheseTable a b
860 , KnownSymbol label
861 ) => K1Table label Insert 'True (Shape2 'These structure1 structure2) e
862 where
863 fromK1Columns =
864 fromColumns2
865 (fromK1Columns @"Here" @_ @_ @structure1)
866 (fromK1Columns @"There" @_ @_ @structure2) .
867 hunlabel unlabeler
868 toK1Columns =
869 hlabel labeler .
870 toColumns2
871 (toK1Columns @"Here" @_ @_ @structure1)
872 (toK1Columns @"There" @_ @_ @structure2)
873 {-# INLINABLE fromK1Columns #-}
874 {-# INLINABLE toK1Columns #-}
877instance
878 ( HTable (K1Columns "Here" structure1)
879 , HTable (K1Columns "There" structure2)
880 , K1Table "Here" Identity (IsStructure structure1) structure1 a
881 , K1Table "There" Identity (IsStructure structure2) structure2 b
882 , e ~ These a b
883 , KnownSymbol label
884 ) => K1Table label Identity 'True (Shape2 'These structure1 structure2) e
885 where
886 fromK1Columns
887 = bimap
888 (fromK1Columns @"Here" @_ @_ @structure1)
889 (fromK1Columns @"There" @_ @_ @structure2)
890 . fromHTheseTable
891 . hunlabel unlabeler
892 toK1Columns
893 = hlabel labeler
894 . toHTheseTable
895 . bimap
896 (toK1Columns @"Here" @_ @_ @structure1)
897 (toK1Columns @"There" @_ @_ @structure2)
898 {-# INLINABLE fromK1Columns #-}
899 {-# INLINABLE toK1Columns #-}
902instance
903 ( HTable (K1Columns "Here" structure1)
904 , HTable (K1Columns "There" structure2)
905 , K1Table "Here" Name (IsStructure structure1) structure1 a
906 , K1Table "There" Name (IsStructure structure2) structure2 b
907 , e ~ TheseTable a b
908 , KnownSymbol label
909 ) => K1Table label Name 'True (Shape2 'These structure1 structure2) e
910 where
911 fromK1Columns =
912 fromColumns2
913 (fromK1Columns @"Here" @_ @_ @structure1)
914 (fromK1Columns @"There" @_ @_ @structure2) .
915 hunlabel unlabeler
916 toK1Columns =
917 hlabel labeler .
918 toColumns2
919 (toK1Columns @"Here" @_ @_ @structure1)
920 (toK1Columns @"There" @_ @_ @structure2)
921 {-# INLINABLE fromK1Columns #-}
922 {-# INLINABLE toK1Columns #-}
925instance
926 ( K1Table "fst" context (IsStructure structure1) structure1 a1
927 , K1Table "snd" context (IsStructure structure2) structure2 a2
928 , HTable (K1Columns "fst" structure1)
929 , HTable (K1Columns "snd" structure2)
930 , Labelable context
931 , a ~ (a1, a2)
932 , KnownSymbol label
933 ) => K1Table label context 'True (structure1, structure2) a
934 where
935 fromK1Columns (hunlabel unlabeler -> (HPair a b)) =
936 ( fromK1Columns @"fst" @_ @_ @structure1 a
937 , fromK1Columns @"snd" @_ @_ @structure2 b
938 )
939 toK1Columns (a, b) = hlabel labeler $ HPair
940 { hfst = toK1Columns @"fst" @_ @_ @structure1 a
941 , hsnd = toK1Columns @"snd" @_ @_ @structure2 b
942 }
943 {-# INLINABLE fromK1Columns #-}
944 {-# INLINABLE toK1Columns #-}
947instance
948 ( K1Table "fst" context (IsStructure structure1) structure1 a1
949 , K1Table "snd" context (IsStructure structure2) structure2 a2
950 , K1Table "trd" context (IsStructure structure3) structure3 a3
951 , HTable (K1Columns "fst" structure1)
952 , HTable (K1Columns "snd" structure2)
953 , HTable (K1Columns "trd" structure3)
954 , Labelable context
955 , a ~ (a1, a2, a3)
956 , KnownSymbol label
957 ) => K1Table label context 'True (structure1, structure2, structure3) a
958 where
959 fromK1Columns (hunlabel unlabeler -> (HTrio a b c)) =
960 ( fromK1Columns @"fst" @_ @_ @structure1 a
961 , fromK1Columns @"snd" @_ @_ @structure2 b
962 , fromK1Columns @"trd" @_ @_ @structure3 c
963 )
964 toK1Columns (a, b, c) = hlabel labeler $ HTrio
965 { hfst = toK1Columns @"fst" @_ @_ @structure1 a
966 , hsnd = toK1Columns @"snd" @_ @_ @structure2 b
967 , htrd = toK1Columns @"trd" @_ @_ @structure3 c
968 }
969 {-# INLINABLE fromK1Columns #-}
970 {-# INLINABLE toK1Columns #-}
973instance
974 ( K1Table "fst" context (IsStructure structure1) structure1 a1
975 , K1Table "snd" context (IsStructure structure2) structure2 a2
976 , K1Table "trd" context (IsStructure structure3) structure3 a3
977 , K1Table "frt" context (IsStructure structure3) structure4 a4
978 , HTable (K1Columns "fst" structure1)
979 , HTable (K1Columns "snd" structure2)
980 , HTable (K1Columns "trd" structure3)
981 , HTable (K1Columns "frt" structure4)
982 , Labelable context
983 , a ~ (a1, a2, a3, a4)
984 , KnownSymbol label
985 ) => K1Table label context 'True (structure1, structure2, structure3, structure4) a
986 where
987 fromK1Columns (hunlabel unlabeler -> (HQuartet a b c d)) =
988 ( fromK1Columns @"fst" @_ @_ @structure1 a
989 , fromK1Columns @"snd" @_ @_ @structure2 b
990 , fromK1Columns @"trd" @_ @_ @structure3 c
991 , fromK1Columns @"frt" @_ @_ @structure4 d
992 )
993 toK1Columns (a, b, c, d) = hlabel labeler $ HQuartet
994 { hfst = toK1Columns @"fst" @_ @_ @structure1 a
995 , hsnd = toK1Columns @"snd" @_ @_ @structure2 b
996 , htrd = toK1Columns @"trd" @_ @_ @structure3 c
997 , hfrt = toK1Columns @"frt" @_ @_ @structure4 d
998 }
999 {-# INLINABLE fromK1Columns #-}
1000 {-# INLINABLE toK1Columns #-}
1003instance
1004 ( K1Table "fst" context (IsStructure structure1) structure1 a1
1005 , K1Table "snd" context (IsStructure structure2) structure2 a2
1006 , K1Table "trd" context (IsStructure structure3) structure3 a3
1007 , K1Table "frt" context (IsStructure structure3) structure4 a4
1008 , K1Table "fft" context (IsStructure structure3) structure5 a5
1009 , HTable (K1Columns "fst" structure1)
1010 , HTable (K1Columns "snd" structure2)
1011 , HTable (K1Columns "trd" structure3)
1012 , HTable (K1Columns "frt" structure4)
1013 , HTable (K1Columns "fft" structure5)
1014 , Labelable context
1015 , a ~ (a1, a2, a3, a4, a5)
1016 , KnownSymbol label
1017 ) => K1Table label context 'True (structure1, structure2, structure3, structure4, structure5) a
1018 where
1019 fromK1Columns (hunlabel unlabeler -> (HQuintet a b c d e)) =
1020 ( fromK1Columns @"fst" @_ @_ @structure1 a
1021 , fromK1Columns @"snd" @_ @_ @structure2 b
1022 , fromK1Columns @"trd" @_ @_ @structure3 c
1023 , fromK1Columns @"frt" @_ @_ @structure4 d
1024 , fromK1Columns @"fft" @_ @_ @structure5 e
1026 toK1Columns (a, b, c, d, e) = hlabel labeler $ HQuintet
1027 { hfst = toK1Columns @"fst" @_ @_ @structure1 a
1028 , hsnd = toK1Columns @"snd" @_ @_ @structure2 b
1029 , htrd = toK1Columns @"trd" @_ @_ @structure3 c
1030 , hfrt = toK1Columns @"frt" @_ @_ @structure4 d
1031 , hfft = toK1Columns @"fft" @_ @_ @structure5 e
1033 {-# INLINABLE fromK1Columns #-}
1034 {-# INLINABLE toK1Columns #-}
1037instance
1038 ( IsStructure structure ~ 'False
1039 , K1Columns label structure ~ HLabel label (Columns structure)
1040 , Columns structure ~ Columns a
1041 , Labelable context
1042 , Table context a
1043 , KnownSymbol label
1044 ) => K1Table label context 'False structure a
1045 where
1046 fromK1Columns = fromColumns . hunlabel unlabeler
1047 toK1Columns = hlabel labeler . toColumns
1048 {-# INLINABLE fromK1Columns #-}
1049 {-# INLINABLE toK1Columns #-}