git.iko.soy/rel8
on master help sign in
Rewrite Nullify and Vectorize in terms of HMapTable
d2347c1Ollie Charles
rel8.cabal+3
compare with master
unifiedsplit
@@ -61,6 +61,8 @@ library
61 Rel8.Expr.Text
61 Rel8.Expr.Text
62 Rel8.Expr.Time
62 Rel8.Expr.Time
63
63
64+ Rel8.FCF
65+
64 Rel8.Kind.Labels
66 Rel8.Kind.Labels
65 Rel8.Kind.Necessity
67 Rel8.Kind.Necessity
66
68
@@ -99,6 +101,7 @@ library
99 Rel8.Schema.HTable.Identity
101 Rel8.Schema.HTable.Identity
100 Rel8.Schema.HTable.Label
102 Rel8.Schema.HTable.Label
101 Rel8.Schema.HTable.List
103 Rel8.Schema.HTable.List
104+ Rel8.Schema.HTable.MapTable
102 Rel8.Schema.HTable.Maybe
105 Rel8.Schema.HTable.Maybe
103 Rel8.Schema.HTable.NonEmpty
106 Rel8.Schema.HTable.NonEmpty
104 Rel8.Schema.HTable.Nullify
107 Rel8.Schema.HTable.Nullify
src/Rel8/FCF.hsnew file+18
@@ -0,0 +1,18 @@
1+{-# language DataKinds #-}
2+{-# language PolyKinds #-}
3+{-# language StandaloneKindSignatures #-}
4+{-# language TypeFamilies #-}
5+
6+module Rel8.FCF ( Exp, Eval ) where
7+
8+-- base
9+import Data.Kind ( Type )
10+import Prelude ()
11+
12+
13+type Exp :: Type -> Type
14+type Exp e = e -> Type
15+
16+
17+type Eval :: Exp e -> e
18+type family Eval a
src/Rel8/Schema/Generic.hs+29−1
@@ -32,7 +32,7 @@ import GHC.Generics
32 , D, C, S
32 , D, C, S
33 , Meta( MetaSel )
33 , Meta( MetaSel )
34 )
34 )
35−import GHC.TypeLits ( Symbol )
35+import GHC.TypeLits ( Symbol, KnownSymbol )
36import Prelude
36import Prelude
37
37
38-- rel8
38-- rel8
@@ -477,6 +477,7 @@ instance
477 , K1Table "Left" Aggregate (IsStructure structure1) structure1 a
477 , K1Table "Left" Aggregate (IsStructure structure1) structure1 a
478 , K1Table "Right" Aggregate (IsStructure structure2) structure2 b
478 , K1Table "Right" Aggregate (IsStructure structure2) structure2 b
479 , e ~ EitherTable a b
479 , e ~ EitherTable a b
480+ , KnownSymbol label
480 ) => K1Table label Aggregate 'True (Shape2 'Either structure1 structure2) e
481 ) => K1Table label Aggregate 'True (Shape2 'Either structure1 structure2) e
481 where
482 where
482 fromK1Columns =
483 fromK1Columns =
@@ -499,6 +500,7 @@ instance
499 , K1Table "Left" Expr (IsStructure structure1) structure1 a
500 , K1Table "Left" Expr (IsStructure structure1) structure1 a
500 , K1Table "Right" Expr (IsStructure structure2) structure2 b
501 , K1Table "Right" Expr (IsStructure structure2) structure2 b
501 , e ~ EitherTable a b
502 , e ~ EitherTable a b
503+ , KnownSymbol label
502 ) => K1Table label Expr 'True (Shape2 'Either structure1 structure2) e
504 ) => K1Table label Expr 'True (Shape2 'Either structure1 structure2) e
503 where
505 where
504 fromK1Columns =
506 fromK1Columns =
@@ -521,6 +523,7 @@ instance
521 , K1Table "Left" Insertion (IsStructure structure1) structure1 a
523 , K1Table "Left" Insertion (IsStructure structure1) structure1 a
522 , K1Table "Right" Insertion (IsStructure structure2) structure2 b
524 , K1Table "Right" Insertion (IsStructure structure2) structure2 b
523 , e ~ EitherTable a b
525 , e ~ EitherTable a b
526+ , KnownSymbol label
524 ) => K1Table label Insertion 'True (Shape2 'Either structure1 structure2) e
527 ) => K1Table label Insertion 'True (Shape2 'Either structure1 structure2) e
525 where
528 where
526 fromK1Columns =
529 fromK1Columns =
@@ -543,6 +546,7 @@ instance
543 , K1Table "Left" Identity (IsStructure structure1) structure1 a
546 , K1Table "Left" Identity (IsStructure structure1) structure1 a
544 , K1Table "Right" Identity (IsStructure structure2) structure2 b
547 , K1Table "Right" Identity (IsStructure structure2) structure2 b
545 , e ~ Either a b
548 , e ~ Either a b
549+ , KnownSymbol label
546 ) => K1Table label Identity 'True (Shape2 'Either structure1 structure2) e
550 ) => K1Table label Identity 'True (Shape2 'Either structure1 structure2) e
547 where
551 where
548 fromK1Columns
552 fromK1Columns
@@ -567,6 +571,7 @@ instance
567 , K1Table "Left" Name (IsStructure structure1) structure1 a
571 , K1Table "Left" Name (IsStructure structure1) structure1 a
568 , K1Table "Right" Name (IsStructure structure2) structure2 b
572 , K1Table "Right" Name (IsStructure structure2) structure2 b
569 , e ~ EitherTable a b
573 , e ~ EitherTable a b
574+ , KnownSymbol label
570 ) => K1Table label Name 'True (Shape2 'Either structure1 structure2) e
575 ) => K1Table label Name 'True (Shape2 'Either structure1 structure2) e
571 where
576 where
572 fromK1Columns =
577 fromK1Columns =
@@ -587,6 +592,7 @@ instance
587 ( Table Aggregate a
592 ( Table Aggregate a
588 , K1Columns label structure ~ HLabel label (Columns a)
593 , K1Columns label structure ~ HLabel label (Columns a)
589 , as ~ ListTable a
594 , as ~ ListTable a
595+ , KnownSymbol label
590 ) => K1Table label Aggregate 'True (Shape1 'List structure) as
596 ) => K1Table label Aggregate 'True (Shape1 'List structure) as
591 where
597 where
592 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
598 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
@@ -599,6 +605,7 @@ instance
599 ( Table Expr a
605 ( Table Expr a
600 , K1Columns label structure ~ HLabel label (Columns a)
606 , K1Columns label structure ~ HLabel label (Columns a)
601 , as ~ ListTable a
607 , as ~ ListTable a
608+ , KnownSymbol label
602 ) => K1Table label Expr 'True (Shape1 'List structure) as
609 ) => K1Table label Expr 'True (Shape1 'List structure) as
603 where
610 where
604 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
611 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
@@ -611,6 +618,7 @@ instance
611 ( Table Insertion a
618 ( Table Insertion a
612 , K1Columns label structure ~ HLabel label (Columns a)
619 , K1Columns label structure ~ HLabel label (Columns a)
613 , as ~ ListTable a
620 , as ~ ListTable a
621+ , KnownSymbol label
614 ) => K1Table label Insertion 'True (Shape1 'List structure) as
622 ) => K1Table label Insertion 'True (Shape1 'List structure) as
615 where
623 where
616 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
624 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
@@ -635,6 +643,7 @@ instance
635 ( Table Name a
643 ( Table Name a
636 , K1Columns label structure ~ HLabel label (Columns a)
644 , K1Columns label structure ~ HLabel label (Columns a)
637 , as ~ ListTable a
645 , as ~ ListTable a
646+ , KnownSymbol label
638 ) => K1Table label Name 'True (Shape1 'List structure) as
647 ) => K1Table label Name 'True (Shape1 'List structure) as
639 where
648 where
640 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
649 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
@@ -647,6 +656,7 @@ instance
647 ( HTable (K1Columns "Just" structure)
656 ( HTable (K1Columns "Just" structure)
648 , K1Table "Just" Aggregate (IsStructure structure) structure a
657 , K1Table "Just" Aggregate (IsStructure structure) structure a
649 , ma ~ MaybeTable a
658 , ma ~ MaybeTable a
659+ , KnownSymbol label
650 ) => K1Table label Aggregate 'True (Shape1 'Maybe structure) ma
660 ) => K1Table label Aggregate 'True (Shape1 'Maybe structure) ma
651 where
661 where
652 fromK1Columns =
662 fromK1Columns =
@@ -663,6 +673,7 @@ instance
663 ( HTable (K1Columns "Just" structure)
673 ( HTable (K1Columns "Just" structure)
664 , K1Table "Just" Expr (IsStructure structure) structure a
674 , K1Table "Just" Expr (IsStructure structure) structure a
665 , ma ~ MaybeTable a
675 , ma ~ MaybeTable a
676+ , KnownSymbol label
666 ) => K1Table label Expr 'True (Shape1 'Maybe structure) ma
677 ) => K1Table label Expr 'True (Shape1 'Maybe structure) ma
667 where
678 where
668 fromK1Columns =
679 fromK1Columns =
@@ -679,6 +690,7 @@ instance
679 ( HTable (K1Columns "Just" structure)
690 ( HTable (K1Columns "Just" structure)
680 , K1Table "Just" Insertion (IsStructure structure) structure a
691 , K1Table "Just" Insertion (IsStructure structure) structure a
681 , ma ~ MaybeTable a
692 , ma ~ MaybeTable a
693+ , KnownSymbol label
682 ) => K1Table label Insertion 'True (Shape1 'Maybe structure) ma
694 ) => K1Table label Insertion 'True (Shape1 'Maybe structure) ma
683 where
695 where
684 fromK1Columns =
696 fromK1Columns =
@@ -695,6 +707,7 @@ instance
695 ( HTable (K1Columns "Just" structure)
707 ( HTable (K1Columns "Just" structure)
696 , K1Table "Just" Identity (IsStructure structure) structure a
708 , K1Table "Just" Identity (IsStructure structure) structure a
697 , ma ~ Maybe a
709 , ma ~ Maybe a
710+ , KnownSymbol label
698 ) => K1Table label Identity 'True (Shape1 'Maybe structure) ma
711 ) => K1Table label Identity 'True (Shape1 'Maybe structure) ma
699 where
712 where
700 fromK1Columns
713 fromK1Columns
@@ -713,6 +726,7 @@ instance
713 ( HTable (K1Columns "Just" structure)
726 ( HTable (K1Columns "Just" structure)
714 , K1Table "Just" Name (IsStructure structure) structure a
727 , K1Table "Just" Name (IsStructure structure) structure a
715 , ma ~ MaybeTable a
728 , ma ~ MaybeTable a
729+ , KnownSymbol label
716 ) => K1Table label Name 'True (Shape1 'Maybe structure) ma
730 ) => K1Table label Name 'True (Shape1 'Maybe structure) ma
717 where
731 where
718 fromK1Columns =
732 fromK1Columns =
@@ -729,6 +743,7 @@ instance
729 ( Table Aggregate a
743 ( Table Aggregate a
730 , K1Columns label structure ~ HLabel label (Columns a)
744 , K1Columns label structure ~ HLabel label (Columns a)
731 , as ~ NonEmptyTable a
745 , as ~ NonEmptyTable a
746+ , KnownSymbol label
732 ) => K1Table label Aggregate 'True (Shape1 'NonEmpty structure) as
747 ) => K1Table label Aggregate 'True (Shape1 'NonEmpty structure) as
733 where
748 where
734 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
749 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
@@ -741,6 +756,7 @@ instance
741 ( Table Expr a
756 ( Table Expr a
742 , K1Columns label structure ~ HLabel label (Columns a)
757 , K1Columns label structure ~ HLabel label (Columns a)
743 , as ~ NonEmptyTable a
758 , as ~ NonEmptyTable a
759+ , KnownSymbol label
744 ) => K1Table label Expr 'True (Shape1 'NonEmpty structure) as
760 ) => K1Table label Expr 'True (Shape1 'NonEmpty structure) as
745 where
761 where
746 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
762 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
@@ -753,6 +769,7 @@ instance
753 ( Table Insertion a
769 ( Table Insertion a
754 , K1Columns label structure ~ HLabel label (Columns a)
770 , K1Columns label structure ~ HLabel label (Columns a)
755 , as ~ NonEmptyTable a
771 , as ~ NonEmptyTable a
772+ , KnownSymbol label
756 ) => K1Table label Insertion 'True (Shape1 'NonEmpty structure) as
773 ) => K1Table label Insertion 'True (Shape1 'NonEmpty structure) as
757 where
774 where
758 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
775 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
@@ -777,6 +794,7 @@ instance
777 ( Table Name a
794 ( Table Name a
778 , K1Columns label structure ~ HLabel label (Columns a)
795 , K1Columns label structure ~ HLabel label (Columns a)
779 , as ~ NonEmptyTable a
796 , as ~ NonEmptyTable a
797+ , KnownSymbol label
780 ) => K1Table label Name 'True (Shape1 'NonEmpty structure) as
798 ) => K1Table label Name 'True (Shape1 'NonEmpty structure) as
781 where
799 where
782 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
800 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
@@ -791,6 +809,7 @@ instance
791 , K1Table "Here" Aggregate (IsStructure structure1) structure1 a
809 , K1Table "Here" Aggregate (IsStructure structure1) structure1 a
792 , K1Table "There" Aggregate (IsStructure structure2) structure2 b
810 , K1Table "There" Aggregate (IsStructure structure2) structure2 b
793 , e ~ TheseTable a b
811 , e ~ TheseTable a b
812+ , KnownSymbol label
794 ) => K1Table label Aggregate 'True (Shape2 'These structure1 structure2) e
813 ) => K1Table label Aggregate 'True (Shape2 'These structure1 structure2) e
795 where
814 where
796 fromK1Columns =
815 fromK1Columns =
@@ -813,6 +832,7 @@ instance
813 , K1Table "Here" Expr (IsStructure structure1) structure1 a
832 , K1Table "Here" Expr (IsStructure structure1) structure1 a
814 , K1Table "There" Expr (IsStructure structure2) structure2 b
833 , K1Table "There" Expr (IsStructure structure2) structure2 b
815 , e ~ TheseTable a b
834 , e ~ TheseTable a b
835+ , KnownSymbol label
816 ) => K1Table label Expr 'True (Shape2 'These structure1 structure2) e
836 ) => K1Table label Expr 'True (Shape2 'These structure1 structure2) e
817 where
837 where
818 fromK1Columns =
838 fromK1Columns =
@@ -835,6 +855,7 @@ instance
835 , K1Table "Here" Insertion (IsStructure structure1) structure1 a
855 , K1Table "Here" Insertion (IsStructure structure1) structure1 a
836 , K1Table "There" Insertion (IsStructure structure2) structure2 b
856 , K1Table "There" Insertion (IsStructure structure2) structure2 b
837 , e ~ TheseTable a b
857 , e ~ TheseTable a b
858+ , KnownSymbol label
838 ) => K1Table label Insertion 'True (Shape2 'These structure1 structure2) e
859 ) => K1Table label Insertion 'True (Shape2 'These structure1 structure2) e
839 where
860 where
840 fromK1Columns =
861 fromK1Columns =
@@ -857,6 +878,7 @@ instance
857 , K1Table "Here" Identity (IsStructure structure1) structure1 a
878 , K1Table "Here" Identity (IsStructure structure1) structure1 a
858 , K1Table "There" Identity (IsStructure structure2) structure2 b
879 , K1Table "There" Identity (IsStructure structure2) structure2 b
859 , e ~ These a b
880 , e ~ These a b
881+ , KnownSymbol label
860 ) => K1Table label Identity 'True (Shape2 'These structure1 structure2) e
882 ) => K1Table label Identity 'True (Shape2 'These structure1 structure2) e
861 where
883 where
862 fromK1Columns
884 fromK1Columns
@@ -881,6 +903,7 @@ instance
881 , K1Table "Here" Name (IsStructure structure1) structure1 a
903 , K1Table "Here" Name (IsStructure structure1) structure1 a
882 , K1Table "There" Name (IsStructure structure2) structure2 b
904 , K1Table "There" Name (IsStructure structure2) structure2 b
883 , e ~ TheseTable a b
905 , e ~ TheseTable a b
906+ , KnownSymbol label
884 ) => K1Table label Name 'True (Shape2 'These structure1 structure2) e
907 ) => K1Table label Name 'True (Shape2 'These structure1 structure2) e
885 where
908 where
886 fromK1Columns =
909 fromK1Columns =
@@ -904,6 +927,7 @@ instance
904 , HTable (K1Columns "snd" structure2)
927 , HTable (K1Columns "snd" structure2)
905 , Labelable context
928 , Labelable context
906 , a ~ (a1, a2)
929 , a ~ (a1, a2)
930+ , KnownSymbol label
907 ) => K1Table label context 'True (structure1, structure2) a
931 ) => K1Table label context 'True (structure1, structure2) a
908 where
932 where
909 fromK1Columns (hunlabel unlabeler -> (HPair a b)) =
933 fromK1Columns (hunlabel unlabeler -> (HPair a b)) =
@@ -927,6 +951,7 @@ instance
927 , HTable (K1Columns "trd" structure3)
951 , HTable (K1Columns "trd" structure3)
928 , Labelable context
952 , Labelable context
929 , a ~ (a1, a2, a3)
953 , a ~ (a1, a2, a3)
954+ , KnownSymbol label
930 ) => K1Table label context 'True (structure1, structure2, structure3) a
955 ) => K1Table label context 'True (structure1, structure2, structure3) a
931 where
956 where
932 fromK1Columns (hunlabel unlabeler -> (HTrio a b c)) =
957 fromK1Columns (hunlabel unlabeler -> (HTrio a b c)) =
@@ -954,6 +979,7 @@ instance
954 , HTable (K1Columns "frt" structure4)
979 , HTable (K1Columns "frt" structure4)
955 , Labelable context
980 , Labelable context
956 , a ~ (a1, a2, a3, a4)
981 , a ~ (a1, a2, a3, a4)
982+ , KnownSymbol label
957 ) => K1Table label context 'True (structure1, structure2, structure3, structure4) a
983 ) => K1Table label context 'True (structure1, structure2, structure3, structure4) a
958 where
984 where
959 fromK1Columns (hunlabel unlabeler -> (HQuartet a b c d)) =
985 fromK1Columns (hunlabel unlabeler -> (HQuartet a b c d)) =
@@ -985,6 +1011,7 @@ instance
985 , HTable (K1Columns "fft" structure5)
1011 , HTable (K1Columns "fft" structure5)
986 , Labelable context
1012 , Labelable context
987 , a ~ (a1, a2, a3, a4, a5)
1013 , a ~ (a1, a2, a3, a4, a5)
1014+ , KnownSymbol label
988 ) => K1Table label context 'True (structure1, structure2, structure3, structure4, structure5) a
1015 ) => K1Table label context 'True (structure1, structure2, structure3, structure4, structure5) a
989 where
1016 where
990 fromK1Columns (hunlabel unlabeler -> (HQuintet a b c d e)) =
1017 fromK1Columns (hunlabel unlabeler -> (HQuintet a b c d e)) =
@@ -1011,6 +1038,7 @@ instance
1011 , Columns structure ~ Columns a
1038 , Columns structure ~ Columns a
1012 , Labelable context
1039 , Labelable context
1013 , Table context a
1040 , Table context a
1041+ , KnownSymbol label
1014 ) => K1Table label context 'False structure a
1042 ) => K1Table label context 'False structure a
1015 where
1043 where
1016 fromK1Columns = fromColumns . hunlabel unlabeler
1044 fromK1Columns = fromColumns . hunlabel unlabeler
src/Rel8/Schema/HTable/Label.hs+26−72
@@ -1,3 +1,7 @@
1+{-# LANGUAGE DeriveAnyClass #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE DerivingStrategies #-}
4+{-# LANGUAGE LambdaCase #-}
1{-# language ConstraintKinds #-}
5{-# language ConstraintKinds #-}
2{-# language DataKinds #-}
6{-# language DataKinds #-}
3{-# language FlexibleInstances #-}
7{-# language FlexibleInstances #-}
@@ -15,117 +19,67 @@
15{-# language UndecidableInstances #-}
19{-# language UndecidableInstances #-}
16
20
17module Rel8.Schema.HTable.Label
21module Rel8.Schema.HTable.Label
18− ( HLabel( HLabel )
22+ ( HLabel
19 , hlabel, hunlabel
23 , hlabel, hunlabel
20 )
24 )
21where
25where
22
26
23-- base
27-- base
24−import Data.Kind ( Constraint, Type )
25import Data.Proxy ( Proxy( Proxy ) )
28import Data.Proxy ( Proxy( Proxy ) )
26import GHC.TypeLits ( KnownSymbol, Symbol )
29import GHC.TypeLits ( KnownSymbol, Symbol )
27import Prelude
30import Prelude
28
31
29-- rel8
32-- rel8
30import Rel8.Kind.Labels ( SLabels( SLabels ) )
33import Rel8.Kind.Labels ( SLabels( SLabels ) )
31−import Rel8.Schema.Dict ( Dict( Dict ) )
32import Rel8.Schema.HTable
34import Rel8.Schema.HTable
33− ( HTable, HConstrainTable, HField
35+ ( HTable
34− , hfield, htabulate, htraverse, hdicts, hspecs
36+ , hfield, htabulate, hspecs
35 )
37 )
36import qualified Rel8.Schema.Kind as K
38import qualified Rel8.Schema.Kind as K
37import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
39import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
40+import Rel8.FCF
41+import Rel8.Schema.HTable.MapTable
42+import GHC.Generics (Generic)
38
43
39
44
40type HLabel :: Symbol -> K.HTable -> K.HTable
45type HLabel :: Symbol -> K.HTable -> K.HTable
41−data HLabel label table context where
46+newtype HLabel label table context = HLabel (HMapTable (Label label) table context)
42− HLabel :: table (LabelSpec label context) -> HLabel label table context
47+ deriving stock Generic
48+ deriving anyclass HTable
43
49
44
50
45−type HLabelField :: Symbol -> K.HTable -> Spec -> Type
51+data Label :: Symbol -> Spec -> Exp Spec
46−data HLabelField label table spec where
47− HLabelField
48− :: HField table ('Spec labels necessity db a)
49− -> HLabelField label table ('Spec (label ': labels) necessity db a)
50
52
51
53
52−instance (HTable table, KnownSymbol label) => HTable (HLabel label table) where
54+type instance Eval (Label label ('Spec labels necessity db a)) = 'Spec (label : labels) necessity db a
53− type HField (HLabel label table) = HLabelField label table
54− type HConstrainTable (HLabel label table) c =
55− HConstrainTable table (LabelSpecC label c)
56
55
57− hfield (HLabel table) (HLabelField field) =
58− getLabelSpec (hfield table field)
59
56
60− htabulate f = HLabel $ htabulate $ \field -> case hfield hspecs field of
57+instance KnownSymbol l => MapSpec (Label l) where
61− SSpec {} -> LabelSpec (f (HLabelField field))
58+ mapInfo = \case
62− htraverse f (HLabel t) = HLabel <$> htraverse (traverseLabelSpec f) t
59+ SSpec {..} -> SSpec {labels = SLabels Proxy labels, ..}
63
60
64− hdicts :: forall c. HConstrainTable table (LabelSpecC label c)
65− => HLabel label table (Dict c)
66− hdicts = HLabel $ htabulate $ \field -> case hfield hspecs field of
67− SSpec {} -> case hfield (hdicts @_ @(LabelSpecC label c)) field of
68− Dict -> LabelSpec Dict
69
61
70− hspecs = HLabel $ htabulate $ \field -> case hfield hspecs field of
71− SSpec {..} -> LabelSpec SSpec {labels = SLabels Proxy labels, ..}
72−
73− {-# INLINABLE hfield #-}
74− {-# INLINABLE htabulate #-}
75− {-# INLINABLE htraverse #-}
76− {-# INLINABLE hdicts #-}
77− {-# INLINABLE hspecs #-}
78−
79−
80−type LabelingSpec :: Type -> Type
81−type LabelingSpec r = Symbol -> (Spec -> r) -> Spec -> r
82−
83−
84−type LabelSpec :: LabelingSpec Type
85−data LabelSpec label context spec where
86− LabelSpec
87− :: { getLabelSpec :: context ('Spec (label ': labels) necessity db a) }
88− -> LabelSpec label context ('Spec labels necessity db a)
89−
90−
91−type LabelSpecC :: LabelingSpec Constraint
92−class
93− ( forall labels necessity db a.
94− ( spec ~ 'Spec labels necessity db a =>
95− constraint ('Spec (label ': labels) necessity db a)
96− )
97− ) => LabelSpecC label constraint spec
98−instance
99− ( spec ~ 'Spec labels necessity db a
100− , constraint ('Spec (label ': labels) necessity db a)
101− ) => LabelSpecC label constraint spec
102−
103−
104−traverseLabelSpec :: forall context context' label spec m. Functor m
105− => (forall x. context x -> m (context' x))
106− -> LabelSpec label context spec -> m (LabelSpec label context' spec)
107−traverseLabelSpec f (LabelSpec a) = LabelSpec <$> f a
108−
109−
110−hlabel :: HTable t
62+hlabel :: (HTable t, KnownSymbol label)
111 => (forall labels necessity db a. ()
63 => (forall labels necessity db a. ()
112 => context ('Spec labels necessity db a)
64 => context ('Spec labels necessity db a)
113 -> context ('Spec (label ': labels) necessity db a))
65 -> context ('Spec (label ': labels) necessity db a))
114 -> t context
66 -> t context
115 -> HLabel label t context
67 -> HLabel label t context
116−hlabel labeler a = HLabel $ htabulate $ \field ->
68+hlabel labeler a = HLabel $ htabulate $ \(HMapTableField field) ->
117 case hfield hspecs field of
69 case hfield hspecs field of
118− SSpec {} -> LabelSpec (labeler (hfield a field))
70+ SSpec {} -> labeler (hfield a field)
119{-# INLINABLE hlabel #-}
71{-# INLINABLE hlabel #-}
120
72
121
73
122−hunlabel :: HTable t
74+hunlabel :: (HTable t, KnownSymbol label)
123 => (forall labels necessity db a. ()
75 => (forall labels necessity db a. ()
124 => context ('Spec (label ': labels) necessity db a)
76 => context ('Spec (label ': labels) necessity db a)
125 -> context ('Spec labels necessity db a))
77 -> context ('Spec labels necessity db a))
126 -> HLabel label t context
78 -> HLabel label t context
127 -> t context
79 -> t context
128hunlabel unlabler (HLabel as) =
80hunlabel unlabler (HLabel as) =
129− htabulate $ \field -> case hfield as field of
81+ htabulate $ \field ->
82+ case hfield hspecs field of
83+ SSpec {} -> case hfield as (HMapTableField field) of
130− LabelSpec a -> unlabler a
84+ a -> unlabler a
131{-# INLINABLE hunlabel #-}
85{-# INLINABLE hunlabel #-}
src/Rel8/Schema/HTable/MapTable.hsnew file+77
@@ -0,0 +1,77 @@
1+{-# language AllowAmbiguousTypes #-}
2+{-# language BlockArguments #-}
3+{-# language ConstraintKinds #-}
4+{-# language DataKinds #-}
5+{-# language GADTs #-}
6+{-# language InstanceSigs #-}
7+{-# language MultiParamTypeClasses #-}
8+{-# language PolyKinds #-}
9+{-# language ScopedTypeVariables #-}
10+{-# language StandaloneKindSignatures #-}
11+{-# language TypeApplications #-}
12+{-# language TypeFamilies #-}
13+{-# language UndecidableInstances #-}
14+{-# language UndecidableSuperClasses #-}
15+
16+module Rel8.Schema.HTable.MapTable ( HMapTable(..), MapSpec(..), Precompose(..), HMapTableField(..) ) where
17+
18+-- base
19+import Data.Kind ( Constraint, Type )
20+import Prelude ( ($), (.), (<$>), fmap )
21+
22+-- rel8
23+import Rel8.FCF
24+import Rel8.Schema.HTable
25+import Rel8.Schema.Spec ( Spec, SSpec )
26+import qualified Rel8.Schema.Kind as K
27+import Rel8.Schema.Dict ( Dict( Dict ) )
28+
29+
30+type HMapTable :: (a -> Exp b) -> ((a -> Type) -> Type) -> (b -> Type) -> Type
31+data HMapTable f t g where
32+ HMapTable :: { unHMapTable :: t (Precompose f g) } -> HMapTable f t g
33+
34+
35+type Precompose :: (a -> Exp b) -> (b -> Type) -> a -> Type
36+newtype Precompose f g x where
37+ Precompose :: { precomposed :: g (Eval (f x)) } -> Precompose f g x
38+
39+
40+type HMapTableField :: (Spec -> Exp a) -> K.HTable -> a -> Type
41+data HMapTableField f t x where
42+ HMapTableField :: HField t a -> HMapTableField f t (Eval (f a))
43+
44+
45+instance (HTable t, MapSpec f) => HTable (HMapTable f t) where
46+ type HField (HMapTable f t) =
47+ HMapTableField f t
48+
49+ type HConstrainTable (HMapTable f t) c =
50+ HConstrainTable t (ComposeConstraint f c)
51+
52+ hfield (HMapTable x) (HMapTableField i) =
53+ precomposed (hfield x i)
54+
55+ htabulate f =
56+ HMapTable $ htabulate (Precompose . f . HMapTableField)
57+
58+ htraverse f (HMapTable x) =
59+ HMapTable <$> htraverse (fmap Precompose . f . precomposed) x
60+
61+ hdicts :: forall c. HConstrainTable (HMapTable f t) c => HMapTable f t (Dict c)
62+ hdicts =
63+ htabulate \(HMapTableField j) ->
64+ case hfield (hdicts @_ @(ComposeConstraint f c)) j of
65+ Dict -> Dict
66+
67+ hspecs =
68+ HMapTable $ htabulate $ Precompose . mapInfo @f . hfield hspecs
69+
70+
71+type MapSpec :: (Spec -> Exp Spec) -> Constraint
72+class MapSpec f where
73+ mapInfo :: SSpec x -> SSpec (Eval (f x))
74+
75+
76+type ComposeConstraint :: (a -> Exp b) -> (b -> Constraint) -> a -> Constraint
77+class c (Eval (f a)) => ComposeConstraint f c a
src/Rel8/Schema/HTable/Maybe.hs+5−1
@@ -1,3 +1,7 @@
1+{-# LANGUAGE NamedFieldPuns #-}
2+{-# LANGUAGE LambdaCase #-}
3+{-# LANGUAGE TypeFamilies #-}
4+{-# LANGUAGE KindSignatures #-}
1{-# language DataKinds #-}
5{-# language DataKinds #-}
2{-# language DeriveAnyClass #-}
6{-# language DeriveAnyClass #-}
3{-# language DeriveGeneric #-}
7{-# language DeriveGeneric #-}
@@ -17,10 +21,10 @@ import Prelude
17import Rel8.Kind.Necessity ( Necessity( Required ) )
21import Rel8.Kind.Necessity ( Necessity( Required ) )
18import Rel8.Schema.HTable ( HTable )
22import Rel8.Schema.HTable ( HTable )
19import Rel8.Schema.HTable.Identity ( HIdentity(..) )
23import Rel8.Schema.HTable.Identity ( HIdentity(..) )
20−import Rel8.Schema.HTable.Nullify ( HNullify )
21import qualified Rel8.Schema.Kind as K
24import qualified Rel8.Schema.Kind as K
22import Rel8.Schema.Spec ( Spec( Spec ) )
25import Rel8.Schema.Spec ( Spec( Spec ) )
23import Rel8.Type.Tag ( MaybeTag )
26import Rel8.Type.Tag ( MaybeTag )
27+import Rel8.Schema.HTable.Nullify ( HNullify )
24
28
25
29
26type HMaybeTable :: K.HTable -> K.HTable
30type HMaybeTable :: K.HTable -> K.HTable
src/Rel8/Schema/HTable/Nullify.hs+34−72
@@ -1,3 +1,8 @@
1+{-# LANGUAGE DeriveAnyClass #-}
2+{-# LANGUAGE DerivingStrategies #-}
3+{-# LANGUAGE DeriveGeneric #-}
4+{-# LANGUAGE NamedFieldPuns #-}
5+{-# LANGUAGE LambdaCase #-}
1{-# language ConstraintKinds #-}
6{-# language ConstraintKinds #-}
2{-# language DataKinds #-}
7{-# language DataKinds #-}
3{-# language FlexibleInstances #-}
8{-# language FlexibleInstances #-}
@@ -15,19 +20,18 @@
15
20
16module Rel8.Schema.HTable.Nullify
21module Rel8.Schema.HTable.Nullify
17 ( HNullify( HNullify )
22 ( HNullify( HNullify )
23+ , Nullify
18 , hnulls, hnullify, hunnullify
24 , hnulls, hnullify, hunnullify
19 )
25 )
20where
26where
21
27
22-- base
28-- base
23−import Data.Kind ( Constraint, Type )
24import Prelude hiding ( null )
29import Prelude hiding ( null )
25
30
26-- rel8
31-- rel8
27−import Rel8.Schema.Dict ( Dict( Dict ) )
28import Rel8.Schema.HTable
32import Rel8.Schema.HTable
29− ( HTable, HConstrainTable, HField
33+ ( HTable
30− , hfield, htabulate, htabulateA, htraverse, hdicts, hspecs
34+ , hfield, htabulate, htabulateA, hspecs
31 )
35 )
32import qualified Rel8.Schema.Kind as K
36import qualified Rel8.Schema.Kind as K
33import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ) )
37import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ) )
@@ -35,86 +39,44 @@ import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
35
39
36-- semigroupoids
40-- semigroupoids
37import Data.Functor.Apply ( Apply )
41import Data.Functor.Apply ( Apply )
42+import Rel8.Schema.HTable.MapTable
43+import Rel8.FCF
44+import GHC.Generics (Generic)
38
45
39
46
40type HNullify :: K.HTable -> K.HTable
47type HNullify :: K.HTable -> K.HTable
41−newtype HNullify table context = HNullify (table (NullifySpec context))
48+newtype HNullify table context = HNullify (HMapTable Nullify table context)
49+ deriving stock Generic
50+ deriving anyclass HTable
42
51
43
52
44−type HNullifyField :: K.HTable -> Spec -> Type
45−data HNullifyField table spec where
46− HNullifyField
47− :: HField table ('Spec labels necessity dbType a)
48− -> HNullifyField table ('Spec labels necessity dbType (Maybe dbType))
49
53
54+-- | Transform a 'Spec' by allowing it to be @null@.
55+data Nullify :: Spec -> Exp Spec
50
56
51−instance HTable table => HTable (HNullify table) where
52− type HField (HNullify table) = HNullifyField table
53− type HConstrainTable (HNullify table) c =
54− HConstrainTable table (NullifySpecC c)
55
57
56− hfield (HNullify table) (HNullifyField field) =
58+type instance Eval (Nullify ('Spec labels necessity dbType _)) =
57− getNullifySpec (hfield table field)
59+ 'Spec labels necessity dbType (Maybe dbType)
58
60
59− htabulate f = HNullify $ htabulate $ \field -> case hfield hspecs field of
60− SSpec {} -> NullifySpec (f (HNullifyField field))
61
61
62− htraverse f (HNullify t) = HNullify <$> htraverse (traverseNullifySpec f) t
62+instance MapSpec Nullify where
63−
63+ mapInfo = \case
64− hdicts :: forall c. HConstrainTable table (NullifySpecC c)
64+ SSpec{labels, necessity, info, nullability} -> SSpec
65− => HNullify table (Dict c)
65+ { labels
66− hdicts = HNullify $ htabulate $ \field -> case hfield hspecs field of
66+ , necessity
67− SSpec {} -> case hfield (hdicts @_ @(NullifySpecC c)) field of
67+ , info
68− Dict -> NullifySpec Dict
69−
70− hspecs = HNullify $ htabulate $ \field -> case hfield hspecs field of
71− SSpec {..} -> case nullability of
68+ , nullability = case nullability of
72− Nullable -> NullifySpec SSpec {nullability = Nullable, ..}
69+ Nullable -> Nullable
73− NonNullable -> NullifySpec SSpec {nullability = Nullable, ..}
70+ NonNullable -> Nullable
74−
71+ }
75− {-# INLINABLE hfield #-}
76− {-# INLINABLE htabulate #-}
77− {-# INLINABLE htraverse #-}
78− {-# INLINABLE hdicts #-}
79− {-# INLINABLE hspecs #-}
80−
81−
82−type NullifyingSpec :: Type -> Type
83−type NullifyingSpec r = (Spec -> r) -> Spec -> r
84−
85−
86−type NullifySpec :: NullifyingSpec Type
87−data NullifySpec context spec where
88− NullifySpec
89− :: { getNullifySpec :: context ('Spec labels necessity dbType (Maybe dbType)) }
90− -> NullifySpec context ('Spec labels necessity dbType a)
91−
92−
93−type NullifySpecC :: NullifyingSpec Constraint
94−class
95− ( forall labels necessity dbType a.
96− ( spec ~ 'Spec labels necessity dbType a =>
97− constraint ('Spec labels necessity dbType (Maybe dbType))
98− )
99− ) => NullifySpecC constraint spec
100−instance
101− ( spec ~ 'Spec labels necessity dbType a
102− , constraint ('Spec labels necessity dbType (Maybe dbType))
103− ) => NullifySpecC constraint spec
104−
105−
106−traverseNullifySpec :: forall context context' spec m. Functor m
107− => (forall x. context x -> m (context' x))
108− -> NullifySpec context spec -> m (NullifySpec context' spec)
109−traverseNullifySpec f (NullifySpec a) = NullifySpec <$> f a
110
72
111
73
112hnulls :: HTable t
74hnulls :: HTable t
113 => (forall labels necessity dbType. ()
75 => (forall labels necessity dbType. ()
114 => context ('Spec labels necessity dbType (Maybe dbType)))
76 => context ('Spec labels necessity dbType (Maybe dbType)))
115 -> HNullify t context
77 -> HNullify t context
116−hnulls null = HNullify $ htabulate $ \field -> case hfield hspecs field of
78+hnulls null = HNullify $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of
117− SSpec {} -> NullifySpec null
79+ SSpec {} -> null
118{-# INLINABLE hnulls #-}
80{-# INLINABLE hnulls #-}
119
81
120
82
@@ -125,9 +87,9 @@ hnullify :: HTable t
125 -> context ('Spec labels necessity dbType (Maybe dbType)))
87 -> context ('Spec labels necessity dbType (Maybe dbType)))
126 -> t context
88 -> t context
127 -> HNullify t context
89 -> HNullify t context
128−hnullify nullifier a = HNullify $ htabulate $ \field ->
90+hnullify nullifier a = HNullify $ htabulate $ \(HMapTableField field) ->
129 case hfield hspecs field of
91 case hfield hspecs field of
130− spec@SSpec {} -> NullifySpec (nullifier spec (hfield a field))
92+ spec@SSpec {} -> nullifier spec (hfield a field)
131{-# INLINABLE hnullify #-}
93{-# INLINABLE hnullify #-}
132
94
133
95
@@ -140,6 +102,6 @@ hunnullify :: (HTable t, Apply m)
140 -> m (t context)
102 -> m (t context)
141hunnullify unnullifier (HNullify as) =
103hunnullify unnullifier (HNullify as) =
142 htabulateA $ \field -> case hfield hspecs field of
104 htabulateA $ \field -> case hfield hspecs field of
143− spec@SSpec {} -> case hfield as field of
105+ spec@SSpec {} -> case hfield as (HMapTableField field) of
144− NullifySpec a -> unnullifier spec a
106+ a -> unnullifier spec a
145{-# INLINABLE hunnullify #-}
107{-# INLINABLE hunnullify #-}
src/Rel8/Schema/HTable/Vectorize.hs+37−89
@@ -1,3 +1,7 @@
1+{-# LANGUAGE DeriveAnyClass #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE DerivingStrategies #-}
4+{-# LANGUAGE LambdaCase #-}
1{-# language AllowAmbiguousTypes #-}
5{-# language AllowAmbiguousTypes #-}
2{-# language ConstraintKinds #-}
6{-# language ConstraintKinds #-}
3{-# language DataKinds #-}
7{-# language DataKinds #-}
@@ -18,7 +22,7 @@
18{-# language UndecidableInstances #-}
22{-# language UndecidableInstances #-}
19
23
20module Rel8.Schema.HTable.Vectorize
24module Rel8.Schema.HTable.Vectorize
21− ( HVectorize( HVectorize )
25+ ( HVectorize
22 , hvectorize, hunvectorize
26 , hvectorize, hunvectorize
23 , happend, hempty
27 , happend, hempty
24 , hrelabel
28 , hrelabel
@@ -26,18 +30,17 @@ module Rel8.Schema.HTable.Vectorize
26where
30where
27
31
28-- base
32-- base
29−import Data.Kind ( Constraint, Type )
33+import Data.Kind ( Type )
30import Data.List.NonEmpty ( NonEmpty )
34import Data.List.NonEmpty ( NonEmpty )
31import Data.Type.Equality ( (:~:)( Refl ) )
35import Data.Type.Equality ( (:~:)( Refl ) )
32import Prelude
36import Prelude
33
37
34-- rel8
38-- rel8
35import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler )
39import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler )
36−import Rel8.Schema.Dict ( Dict( Dict ) )
37import qualified Rel8.Schema.Kind as K
40import qualified Rel8.Schema.Kind as K
38import Rel8.Schema.HTable
41import Rel8.Schema.HTable
39− ( HTable, HConstrainTable, HField
42+ ( HTable
40− , hfield, htabulate, htabulateA, htraverse, hdicts, hspecs
43+ , hfield, htabulate, htabulateA, hspecs
41 )
44 )
42import Rel8.Schema.Nullability ( IsMaybe, Nullability( NonNullable ) )
45import Rel8.Schema.Nullability ( IsMaybe, Nullability( NonNullable ) )
43import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
46import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
@@ -46,6 +49,9 @@ import Rel8.Type.Information ( TypeInformation )
46
49
47-- semialign
50-- semialign
48import Data.Zip ( Unzip, Repeat, Zippy(..) )
51import Data.Zip ( Unzip, Repeat, Zippy(..) )
52+import Rel8.FCF
53+import Rel8.Schema.HTable.MapTable
54+import GHC.Generics (Generic)
49
55
50
56
51class Vector list where
57class Vector list where
@@ -67,104 +73,41 @@ instance Vector NonEmpty where
67
73
68
74
69type HVectorize :: (Type -> Type) -> K.HTable -> K.HTable
75type HVectorize :: (Type -> Type) -> K.HTable -> K.HTable
70−newtype HVectorize list table context =
76+newtype HVectorize list table context = HVectorize (HMapTable (Vectorize list) table context)
71− HVectorize (table (VectorizeSpec list context))
77+ deriving stock Generic
78+ deriving anyclass HTable
72
79
73
80
74−type HVectorizeField :: (Type -> Type) -> K.HTable -> Spec -> Type
81+data Vectorize :: (Type -> Type) -> Spec -> Exp Spec
75−data HVectorizeField list table spec where
76− HVectorizeField
77− :: HField table ('Spec labels necessity db a)
78− -> HVectorizeField list table
79− ('Spec labels necessity (list a) (list a)
80− )
81
82
82
83
83−instance (HTable table, Vector list) => HTable (HVectorize list table) where
84+type instance Eval (Vectorize list ('Spec labels necessity _ a)) = 'Spec labels necessity (list a) (list a)
84− type HField (HVectorize list table) = HVectorizeField list table
85− type HConstrainTable (HVectorize list table) c =
86− HConstrainTable table (VectorizeSpecC list c)
87
85
88− hfield (HVectorize table) (HVectorizeField field) =
89− getVectorizeSpec (hfield table field)
90
86
91− htabulate f = HVectorize $ htabulate $ \field -> case hfield hspecs field of
87+instance Vector list => MapSpec (Vectorize list) where
92− SSpec {} -> VectorizeSpec (f (HVectorizeField field))
88+ mapInfo = \case
93− htraverse f (HVectorize t) = HVectorize <$> htraverse (traverseVectorizeSpec f) t
94−
95− hdicts :: forall c. HConstrainTable table (VectorizeSpecC list c) =>
96− HVectorize list table (Dict c)
97− hdicts = HVectorize $ htabulate $ \field -> case hfield hspecs field of
98− SSpec {} -> case hfield (hdicts @_ @(VectorizeSpecC list c)) field of
99− Dict -> VectorizeSpec Dict
100−
101− hspecs = HVectorize $ htabulate $ \field -> case hfield hspecs field of
102 SSpec {..} -> case listIsn'tMaybe @list nullability of
89 SSpec {..} -> case listIsn'tMaybe @list nullability of
103− Refl -> VectorizeSpec SSpec
90+ Refl -> SSpec
104 { nullability = NonNullable
91 { nullability = NonNullable
105 , info = vectorTypeInformation nullability info
92 , info = vectorTypeInformation nullability info
106 , ..
93 , ..
107 }
94 }
108
95
109− {-# INLINABLE hfield #-}
110− {-# INLINABLE htabulate #-}
111− {-# INLINABLE htraverse #-}
112− {-# INLINABLE hdicts #-}
113− {-# INLINABLE hspecs #-}
114−
115−
116−type VectorizingSpec :: Type -> Type
117−type VectorizingSpec r = (Type -> Type) -> (Spec -> r) -> Spec -> r
118−
119−
120−type VectorizeSpec :: VectorizingSpec Type
121−data VectorizeSpec list context spec where
122− VectorizeSpec ::
123− { getVectorizeSpec :: context ('Spec labels necessity (list a) (list a))
124− } -> VectorizeSpec list context ('Spec labels necessity db a)
125−
126−
127−instance HLabelable context => HLabelable (VectorizeSpec list context) where
128− hlabeler (VectorizeSpec a) = VectorizeSpec (hlabeler a)
129− hunlabeler (VectorizeSpec a) = VectorizeSpec (hunlabeler a)
130−
131
96
132−type VectorizeSpecC :: VectorizingSpec Constraint
133−class
134− ( forall labels necessity db a.
135− ( spec ~ 'Spec labels necessity db a
136− => constraint ('Spec labels necessity (list a) (list a))
137− )
138− )
139− => VectorizeSpecC list constraint spec
140−instance
141− ( spec ~ 'Spec labels necessity db a
142− , constraint ('Spec labels necessity (list a) (list a))
143− )
144− => VectorizeSpecC list constraint spec
145−
146−
147−traverseVectorizeSpec :: forall context context' list spec m. Functor m
148− => (forall x. context x -> m (context' x))
149− -> VectorizeSpec list context spec
150− -> m (VectorizeSpec list context' spec)
151−traverseVectorizeSpec f (VectorizeSpec a) = VectorizeSpec <$> f a
152−
153−
154−hvectorize :: (HTable t, Unzip f)
97+hvectorize :: (HTable t, Unzip f, Vector list)
155 => (forall labels necessity db a. ()
98 => (forall labels necessity db a. ()
156 => SSpec ('Spec labels necessity db a)
99 => SSpec ('Spec labels necessity db a)
157 -> f (context ('Spec labels necessity db a))
100 -> f (context ('Spec labels necessity db a))
158 -> context' ('Spec labels necessity (list a) (list a)))
101 -> context' ('Spec labels necessity (list a) (list a)))
159 -> f (t context)
102 -> f (t context)
160 -> HVectorize list t context'
103 -> HVectorize list t context'
161−hvectorize vectorizer as = HVectorize $ htabulate $ \field ->
104+hvectorize vectorizer as = HVectorize $ htabulate $ \(HMapTableField field) ->
162 case hfield hspecs field of
105 case hfield hspecs field of
163− spec@SSpec {} -> VectorizeSpec (vectorizer spec (fmap (`hfield` field) as))
106+ spec@SSpec {} -> vectorizer spec (fmap (`hfield` field) as)
164{-# INLINABLE hvectorize #-}
107{-# INLINABLE hvectorize #-}
165
108
166
109
167−hunvectorize :: (HTable t, Repeat f)
110+hunvectorize :: (HTable t, Repeat f, Vector list)
168 => (forall labels necessity db a. ()
111 => (forall labels necessity db a. ()
169 => SSpec ('Spec labels necessity db a)
112 => SSpec ('Spec labels necessity db a)
170 -> context ('Spec labels necessity (list a) (list a))
113 -> context ('Spec labels necessity (list a) (list a))
@@ -173,12 +116,12 @@ hunvectorize :: (HTable t, Repeat f)
173 -> f (t context')
116 -> f (t context')
174hunvectorize unvectorizer (HVectorize table) =
117hunvectorize unvectorizer (HVectorize table) =
175 getZippy $ htabulateA $ \field -> case hfield hspecs field of
118 getZippy $ htabulateA $ \field -> case hfield hspecs field of
176− spec -> case hfield table field of
119+ spec@SSpec{} -> case hfield table (HMapTableField field) of
177− VectorizeSpec a -> Zippy (unvectorizer spec a)
120+ a -> Zippy (unvectorizer spec a)
178{-# INLINABLE hunvectorize #-}
121{-# INLINABLE hunvectorize #-}
179
122
180
123
181−happend :: HTable t =>
124+happend :: (HTable t, Vector list) =>
182 ( forall labels necessity db a. ()
125 ( forall labels necessity db a. ()
183 => Nullability db a
126 => Nullability db a
184 -> TypeInformation db
127 -> TypeInformation db
@@ -190,9 +133,9 @@ happend :: HTable t =>
190 -> HVectorize list t context
133 -> HVectorize list t context
191 -> HVectorize list t context
134 -> HVectorize list t context
192happend append (HVectorize as) (HVectorize bs) = HVectorize $
135happend append (HVectorize as) (HVectorize bs) = HVectorize $
193− htabulate $ \field -> case (hfield as field, hfield bs field) of
136+ htabulate $ \field@(HMapTableField j) -> case (hfield as field, hfield bs field) of
194− (VectorizeSpec a, VectorizeSpec b) -> case hfield hspecs field of
137+ (a, b) -> case hfield hspecs j of
195− SSpec {nullability, info} -> VectorizeSpec $ append nullability info a b
138+ SSpec {nullability, info} -> append nullability info a b
196
139
197
140
198hempty :: HTable t =>
141hempty :: HTable t =>
@@ -202,12 +145,17 @@ hempty :: HTable t =>
202 -> context ('Spec labels necessity [a] [a])
145 -> context ('Spec labels necessity [a] [a])
203 )
146 )
204 -> HVectorize [] t context
147 -> HVectorize [] t context
205−hempty empty = HVectorize $ htabulate $ \field -> case hfield hspecs field of
148+hempty empty = HVectorize $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of
206− SSpec {nullability, info} -> VectorizeSpec (empty nullability info)
149+ SSpec {nullability, info} -> empty nullability info
150+
151+
152+instance HLabelable g => HLabelable (Precompose (Vectorize list) g) where
153+ hlabeler = Precompose . hlabeler . precomposed
154+ hunlabeler = Precompose . hunlabeler . precomposed
207
155
208
156
209hrelabel :: HLabelable context
157hrelabel :: HLabelable context
210 => (forall ctx. HLabelable ctx => t ctx -> u ctx)
158 => (forall ctx. HLabelable ctx => t ctx -> u ctx)
211 -> HVectorize list t context
159 -> HVectorize list t context
212 -> HVectorize list u context
160 -> HVectorize list u context
213−hrelabel f (HVectorize table) = HVectorize (f table)
161+hrelabel f (HVectorize (HMapTable table)) = HVectorize (HMapTable (f table))