d2347c1 · rel8 · git.iko.soy

git.iko.soy/rel8

Rewrite Nullify and Vectorize in terms of HMapTable

commitd2347c1cbccbae11d8770227793716d2570037c7 authorOllie Charles <ollie@ocharles.org.uk> dateWed 24 Mar 2021, 14:25 (6 years ago) parent289d7ca

8 files changed+229−235

compare with master

unifiedsplit

rel8.cabal+3 src/Rel8/FCF.hs+18 src/Rel8/Schema/Generic.hs+29−1 src/Rel8/Schema/HTable/Label.hs+26−72 src/Rel8/Schema/HTable/MapTable.hs+77 src/Rel8/Schema/HTable/Maybe.hs+5−1 src/Rel8/Schema/HTable/Nullify.hs+34−72 src/Rel8/Schema/HTable/Vectorize.hs+37−89

rel8.cabal+3

@@ -61,6 +61,8 @@ library

6161 Rel8.Expr.Text

6262 Rel8.Expr.Time

6363

64+ Rel8.FCF

65+

6466 Rel8.Kind.Labels

6567 Rel8.Kind.Necessity

6668

@@ -99,6 +101,7 @@ library

99101 Rel8.Schema.HTable.Identity

100102 Rel8.Schema.HTable.Label

101103 Rel8.Schema.HTable.List

104+ Rel8.Schema.HTable.MapTable

102105 Rel8.Schema.HTable.Maybe

103106 Rel8.Schema.HTable.NonEmpty

104107 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 #-}

6+module Rel8.FCF ( Exp, Eval ) where

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

3232 , D, C, S

3333 , Meta( MetaSel )

3434 )

35−import GHC.TypeLits ( Symbol )

35+import GHC.TypeLits ( Symbol, KnownSymbol )

3636import Prelude

3737

3838-- rel8

@@ -477,6 +477,7 @@ instance

477477 , K1Table "Left" Aggregate (IsStructure structure1) structure1 a

478478 , K1Table "Right" Aggregate (IsStructure structure2) structure2 b

479479 , e ~ EitherTable a b

480+ , KnownSymbol label

480481 ) => K1Table label Aggregate 'True (Shape2 'Either structure1 structure2) e

481482 where

482483 fromK1Columns =

@@ -499,6 +500,7 @@ instance

499500 , K1Table "Left" Expr (IsStructure structure1) structure1 a

500501 , K1Table "Right" Expr (IsStructure structure2) structure2 b

501502 , e ~ EitherTable a b

503+ , KnownSymbol label

502504 ) => K1Table label Expr 'True (Shape2 'Either structure1 structure2) e

503505 where

504506 fromK1Columns =

@@ -521,6 +523,7 @@ instance

521523 , K1Table "Left" Insertion (IsStructure structure1) structure1 a

522524 , K1Table "Right" Insertion (IsStructure structure2) structure2 b

523525 , e ~ EitherTable a b

526+ , KnownSymbol label

524527 ) => K1Table label Insertion 'True (Shape2 'Either structure1 structure2) e

525528 where

526529 fromK1Columns =

@@ -543,6 +546,7 @@ instance

543546 , K1Table "Left" Identity (IsStructure structure1) structure1 a

544547 , K1Table "Right" Identity (IsStructure structure2) structure2 b

545548 , e ~ Either a b

549+ , KnownSymbol label

546550 ) => K1Table label Identity 'True (Shape2 'Either structure1 structure2) e

547551 where

548552 fromK1Columns

@@ -567,6 +571,7 @@ instance

567571 , K1Table "Left" Name (IsStructure structure1) structure1 a

568572 , K1Table "Right" Name (IsStructure structure2) structure2 b

569573 , e ~ EitherTable a b

574+ , KnownSymbol label

570575 ) => K1Table label Name 'True (Shape2 'Either structure1 structure2) e

571576 where

572577 fromK1Columns =

@@ -587,6 +592,7 @@ instance

587592 ( Table Aggregate a

588593 , K1Columns label structure ~ HLabel label (Columns a)

589594 , as ~ ListTable a

595+ , KnownSymbol label

590596 ) => K1Table label Aggregate 'True (Shape1 'List structure) as

591597 where

592598 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)

@@ -599,6 +605,7 @@ instance

599605 ( Table Expr a

600606 , K1Columns label structure ~ HLabel label (Columns a)

601607 , as ~ ListTable a

608+ , KnownSymbol label

602609 ) => K1Table label Expr 'True (Shape1 'List structure) as

603610 where

604611 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)

@@ -611,6 +618,7 @@ instance

611618 ( Table Insertion a

612619 , K1Columns label structure ~ HLabel label (Columns a)

613620 , as ~ ListTable a

621+ , KnownSymbol label

614622 ) => K1Table label Insertion 'True (Shape1 'List structure) as

615623 where

616624 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)

@@ -635,6 +643,7 @@ instance

635643 ( Table Name a

636644 , K1Columns label structure ~ HLabel label (Columns a)

637645 , as ~ ListTable a

646+ , KnownSymbol label

638647 ) => K1Table label Name 'True (Shape1 'List structure) as

639648 where

640649 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)

@@ -647,6 +656,7 @@ instance

647656 ( HTable (K1Columns "Just" structure)

648657 , K1Table "Just" Aggregate (IsStructure structure) structure a

649658 , ma ~ MaybeTable a

659+ , KnownSymbol label

650660 ) => K1Table label Aggregate 'True (Shape1 'Maybe structure) ma

651661 where

652662 fromK1Columns =

@@ -663,6 +673,7 @@ instance

663673 ( HTable (K1Columns "Just" structure)

664674 , K1Table "Just" Expr (IsStructure structure) structure a

665675 , ma ~ MaybeTable a

676+ , KnownSymbol label

666677 ) => K1Table label Expr 'True (Shape1 'Maybe structure) ma

667678 where

668679 fromK1Columns =

@@ -679,6 +690,7 @@ instance

679690 ( HTable (K1Columns "Just" structure)

680691 , K1Table "Just" Insertion (IsStructure structure) structure a

681692 , ma ~ MaybeTable a

693+ , KnownSymbol label

682694 ) => K1Table label Insertion 'True (Shape1 'Maybe structure) ma

683695 where

684696 fromK1Columns =

@@ -695,6 +707,7 @@ instance

695707 ( HTable (K1Columns "Just" structure)

696708 , K1Table "Just" Identity (IsStructure structure) structure a

697709 , ma ~ Maybe a

710+ , KnownSymbol label

698711 ) => K1Table label Identity 'True (Shape1 'Maybe structure) ma

699712 where

700713 fromK1Columns

@@ -713,6 +726,7 @@ instance

713726 ( HTable (K1Columns "Just" structure)

714727 , K1Table "Just" Name (IsStructure structure) structure a

715728 , ma ~ MaybeTable a

729+ , KnownSymbol label

716730 ) => K1Table label Name 'True (Shape1 'Maybe structure) ma

717731 where

718732 fromK1Columns =

@@ -729,6 +743,7 @@ instance

729743 ( Table Aggregate a

730744 , K1Columns label structure ~ HLabel label (Columns a)

731745 , as ~ NonEmptyTable a

746+ , KnownSymbol label

732747 ) => K1Table label Aggregate 'True (Shape1 'NonEmpty structure) as

733748 where

734749 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)

@@ -741,6 +756,7 @@ instance

741756 ( Table Expr a

742757 , K1Columns label structure ~ HLabel label (Columns a)

743758 , as ~ NonEmptyTable a

759+ , KnownSymbol label

744760 ) => K1Table label Expr 'True (Shape1 'NonEmpty structure) as

745761 where

746762 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)

@@ -753,6 +769,7 @@ instance

753769 ( Table Insertion a

754770 , K1Columns label structure ~ HLabel label (Columns a)

755771 , as ~ NonEmptyTable a

772+ , KnownSymbol label

756773 ) => K1Table label Insertion 'True (Shape1 'NonEmpty structure) as

757774 where

758775 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)

@@ -777,6 +794,7 @@ instance

777794 ( Table Name a

778795 , K1Columns label structure ~ HLabel label (Columns a)

779796 , as ~ NonEmptyTable a

797+ , KnownSymbol label

780798 ) => K1Table label Name 'True (Shape1 'NonEmpty structure) as

781799 where

782800 fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)

@@ -791,6 +809,7 @@ instance

791809 , K1Table "Here" Aggregate (IsStructure structure1) structure1 a

792810 , K1Table "There" Aggregate (IsStructure structure2) structure2 b

793811 , e ~ TheseTable a b

812+ , KnownSymbol label

794813 ) => K1Table label Aggregate 'True (Shape2 'These structure1 structure2) e

795814 where

796815 fromK1Columns =

@@ -813,6 +832,7 @@ instance

813832 , K1Table "Here" Expr (IsStructure structure1) structure1 a

814833 , K1Table "There" Expr (IsStructure structure2) structure2 b

815834 , e ~ TheseTable a b

835+ , KnownSymbol label

816836 ) => K1Table label Expr 'True (Shape2 'These structure1 structure2) e

817837 where

818838 fromK1Columns =

@@ -835,6 +855,7 @@ instance

835855 , K1Table "Here" Insertion (IsStructure structure1) structure1 a

836856 , K1Table "There" Insertion (IsStructure structure2) structure2 b

837857 , e ~ TheseTable a b

858+ , KnownSymbol label

838859 ) => K1Table label Insertion 'True (Shape2 'These structure1 structure2) e

839860 where

840861 fromK1Columns =

@@ -857,6 +878,7 @@ instance

857878 , K1Table "Here" Identity (IsStructure structure1) structure1 a

858879 , K1Table "There" Identity (IsStructure structure2) structure2 b

859880 , e ~ These a b

881+ , KnownSymbol label

860882 ) => K1Table label Identity 'True (Shape2 'These structure1 structure2) e

861883 where

862884 fromK1Columns

@@ -881,6 +903,7 @@ instance

881903 , K1Table "Here" Name (IsStructure structure1) structure1 a

882904 , K1Table "There" Name (IsStructure structure2) structure2 b

883905 , e ~ TheseTable a b

906+ , KnownSymbol label

884907 ) => K1Table label Name 'True (Shape2 'These structure1 structure2) e

885908 where

886909 fromK1Columns =

@@ -904,6 +927,7 @@ instance

904927 , HTable (K1Columns "snd" structure2)

905928 , Labelable context

906929 , a ~ (a1, a2)

930+ , KnownSymbol label

907931 ) => K1Table label context 'True (structure1, structure2) a

908932 where

909933 fromK1Columns (hunlabel unlabeler -> (HPair a b)) =

@@ -927,6 +951,7 @@ instance

927951 , HTable (K1Columns "trd" structure3)

928952 , Labelable context

929953 , a ~ (a1, a2, a3)

954+ , KnownSymbol label

930955 ) => K1Table label context 'True (structure1, structure2, structure3) a

931956 where

932957 fromK1Columns (hunlabel unlabeler -> (HTrio a b c)) =

@@ -954,6 +979,7 @@ instance

954979 , HTable (K1Columns "frt" structure4)

955980 , Labelable context

956981 , a ~ (a1, a2, a3, a4)

982+ , KnownSymbol label

957983 ) => K1Table label context 'True (structure1, structure2, structure3, structure4) a

958984 where

959985 fromK1Columns (hunlabel unlabeler -> (HQuartet a b c d)) =

@@ -985,6 +1011,7 @@ instance

9851011 , HTable (K1Columns "fft" structure5)

9861012 , Labelable context

9871013 , a ~ (a1, a2, a3, a4, a5)

1014+ , KnownSymbol label

9881015 ) => K1Table label context 'True (structure1, structure2, structure3, structure4, structure5) a

9891016 where

9901017 fromK1Columns (hunlabel unlabeler -> (HQuintet a b c d e)) =

@@ -1011,6 +1038,7 @@ instance

10111038 , Columns structure ~ Columns a

10121039 , Labelable context

10131040 , Table context a

1041+ , KnownSymbol label

10141042 ) => K1Table label context 'False structure a

10151043 where

10161044 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 #-}

15{-# language ConstraintKinds #-}

26{-# language DataKinds #-}

37{-# language FlexibleInstances #-}

@@ -15,117 +19,67 @@

1519{-# language UndecidableInstances #-}

1620

1721module Rel8.Schema.HTable.Label

18− ( HLabel( HLabel )

22+ ( HLabel

1923 , hlabel, hunlabel

2024 )

2125where

2226

2327-- base

24−import Data.Kind ( Constraint, Type )

2528import Data.Proxy ( Proxy( Proxy ) )

2629import GHC.TypeLits ( KnownSymbol, Symbol )

2730import Prelude

2831

2932-- rel8

3033import Rel8.Kind.Labels ( SLabels( SLabels ) )

31−import Rel8.Schema.Dict ( Dict( Dict ) )

3234import Rel8.Schema.HTable

33− ( HTable, HConstrainTable, HField

34− , hfield, htabulate, htraverse, hdicts, hspecs

35+ ( HTable

36+ , hfield, htabulate, hspecs

3537 )

3638import qualified Rel8.Schema.Kind as K

3739import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )

40+import Rel8.FCF

41+import Rel8.Schema.HTable.MapTable

42+import GHC.Generics (Generic)

3843

3944

4045type HLabel :: Symbol -> K.HTable -> K.HTable

41−data HLabel label table context where

42− HLabel :: table (LabelSpec label context) -> HLabel label table context

46+newtype HLabel label table context = HLabel (HMapTable (Label label) table context)

47+ deriving stock Generic

48+ deriving anyclass HTable

4349

4450

45−type HLabelField :: Symbol -> K.HTable -> Spec -> Type

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)

51+data Label :: Symbol -> Spec -> Exp Spec

5052

5153

52−instance (HTable table, KnownSymbol label) => HTable (HLabel label table) where

53− type HField (HLabel label table) = HLabelField label table

54− type HConstrainTable (HLabel label table) c =

55− HConstrainTable table (LabelSpecC label c)

54+type instance Eval (Label label ('Spec labels necessity db a)) = 'Spec (label : labels) necessity db a

5655

57− hfield (HLabel table) (HLabelField field) =

58− getLabelSpec (hfield table field)

5956

60− htabulate f = HLabel $ htabulate $ \field -> case hfield hspecs field of

61− SSpec {} -> LabelSpec (f (HLabelField field))

62− htraverse f (HLabel t) = HLabel <$> htraverse (traverseLabelSpec f) t

57+instance KnownSymbol l => MapSpec (Label l) where

58+ mapInfo = \case

59+ SSpec {..} -> SSpec {labels = SLabels Proxy labels, ..}

6360

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

6961

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)

11163 => (forall labels necessity db a. ()

11264 => context ('Spec labels necessity db a)

11365 -> context ('Spec (label ': labels) necessity db a))

11466 -> t context

11567 -> HLabel label t context

116−hlabel labeler a = HLabel $ htabulate $ \field ->

68+hlabel labeler a = HLabel $ htabulate $ \(HMapTableField field) ->

11769 case hfield hspecs field of

118− SSpec {} -> LabelSpec (labeler (hfield a field))

70+ SSpec {} -> labeler (hfield a field)

11971{-# INLINABLE hlabel #-}

12072

12173

122−hunlabel :: HTable t

74+hunlabel :: (HTable t, KnownSymbol label)

12375 => (forall labels necessity db a. ()

12476 => context ('Spec (label ': labels) necessity db a)

12577 -> context ('Spec labels necessity db a))

12678 -> HLabel label t context

12779 -> t context

12880hunlabel unlabler (HLabel as) =

129− htabulate $ \field -> case hfield as field of

130− LabelSpec a -> unlabler a

81+ htabulate $ \field ->

82+ case hfield hspecs field of

83+ SSpec {} -> case hfield as (HMapTableField field) of

84+ a -> unlabler a

13185{-# 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 #-}

15{-# language DataKinds #-}

26{-# language DeriveAnyClass #-}

37{-# language DeriveGeneric #-}

@@ -17,10 +21,10 @@ import Prelude

1721import Rel8.Kind.Necessity ( Necessity( Required ) )

1822import Rel8.Schema.HTable ( HTable )

1923import Rel8.Schema.HTable.Identity ( HIdentity(..) )

20−import Rel8.Schema.HTable.Nullify ( HNullify )

2124import qualified Rel8.Schema.Kind as K

2225import Rel8.Schema.Spec ( Spec( Spec ) )

2326import Rel8.Type.Tag ( MaybeTag )

27+import Rel8.Schema.HTable.Nullify ( HNullify )

2428

2529

2630type 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 #-}

16{-# language ConstraintKinds #-}

27{-# language DataKinds #-}

38{-# language FlexibleInstances #-}

@@ -15,19 +20,18 @@

1520

1621module Rel8.Schema.HTable.Nullify

1722 ( HNullify( HNullify )

23+ , Nullify

1824 , hnulls, hnullify, hunnullify

1925 )

2026where

2127

2228-- base

23−import Data.Kind ( Constraint, Type )

2429import Prelude hiding ( null )

2530

2631-- rel8

27−import Rel8.Schema.Dict ( Dict( Dict ) )

2832import Rel8.Schema.HTable

29− ( HTable, HConstrainTable, HField

30− , hfield, htabulate, htabulateA, htraverse, hdicts, hspecs

33+ ( HTable

34+ , hfield, htabulate, htabulateA, hspecs

3135 )

3236import qualified Rel8.Schema.Kind as K

3337import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ) )

@@ -35,86 +39,44 @@ import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )

3539

3640-- semigroupoids

3741import Data.Functor.Apply ( Apply )

42+import Rel8.Schema.HTable.MapTable

43+import Rel8.FCF

44+import GHC.Generics (Generic)

3845

3946

4047type 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

4251

4352

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))

4953

54+-- | Transform a 'Spec' by allowing it to be @null@.

55+data Nullify :: Spec -> Exp Spec

5056

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)

5557

56− hfield (HNullify table) (HNullifyField field) =

57− getNullifySpec (hfield table field)

58+type instance Eval (Nullify ('Spec labels necessity dbType _)) =

59+ 'Spec labels necessity dbType (Maybe dbType)

5860

59− htabulate f = HNullify $ htabulate $ \field -> case hfield hspecs field of

60− SSpec {} -> NullifySpec (f (HNullifyField field))

6161

62− htraverse f (HNullify t) = HNullify <$> htraverse (traverseNullifySpec f) t

63−

64− hdicts :: forall c. HConstrainTable table (NullifySpecC c)

65− => HNullify table (Dict c)

66− hdicts = HNullify $ htabulate $ \field -> case hfield hspecs field of

67− SSpec {} -> case hfield (hdicts @_ @(NullifySpecC c)) field of

68− Dict -> NullifySpec Dict

69−

70− hspecs = HNullify $ htabulate $ \field -> case hfield hspecs field of

71− SSpec {..} -> case nullability of

72− Nullable -> NullifySpec SSpec {nullability = Nullable, ..}

73− NonNullable -> NullifySpec SSpec {nullability = Nullable, ..}

74−

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

62+instance MapSpec Nullify where

63+ mapInfo = \case

64+ SSpec{labels, necessity, info, nullability} -> SSpec

65+ { labels

66+ , necessity

67+ , info

68+ , nullability = case nullability of

69+ Nullable -> Nullable

70+ NonNullable -> Nullable

71+ }

11072

11173

11274hnulls :: HTable t

11375 => (forall labels necessity dbType. ()

11476 => context ('Spec labels necessity dbType (Maybe dbType)))

11577 -> HNullify t context

116−hnulls null = HNullify $ htabulate $ \field -> case hfield hspecs field of

117− SSpec {} -> NullifySpec null

78+hnulls null = HNullify $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of

79+ SSpec {} -> null

11880{-# INLINABLE hnulls #-}

11981

12082

@@ -125,9 +87,9 @@ hnullify :: HTable t

12587 -> context ('Spec labels necessity dbType (Maybe dbType)))

12688 -> t context

12789 -> HNullify t context

128−hnullify nullifier a = HNullify $ htabulate $ \field ->

90+hnullify nullifier a = HNullify $ htabulate $ \(HMapTableField field) ->

12991 case hfield hspecs field of

130− spec@SSpec {} -> NullifySpec (nullifier spec (hfield a field))

92+ spec@SSpec {} -> nullifier spec (hfield a field)

13193{-# INLINABLE hnullify #-}

13294

13395

@@ -140,6 +102,6 @@ hunnullify :: (HTable t, Apply m)

140102 -> m (t context)

141103hunnullify unnullifier (HNullify as) =

142104 htabulateA $ \field -> case hfield hspecs field of

143− spec@SSpec {} -> case hfield as field of

144− NullifySpec a -> unnullifier spec a

105+ spec@SSpec {} -> case hfield as (HMapTableField field) of

106+ a -> unnullifier spec a

145107{-# 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 #-}

15{-# language AllowAmbiguousTypes #-}

26{-# language ConstraintKinds #-}

37{-# language DataKinds #-}

@@ -18,7 +22,7 @@

1822{-# language UndecidableInstances #-}

1923

2024module Rel8.Schema.HTable.Vectorize

21− ( HVectorize( HVectorize )

25+ ( HVectorize

2226 , hvectorize, hunvectorize

2327 , happend, hempty

2428 , hrelabel

@@ -26,18 +30,17 @@ module Rel8.Schema.HTable.Vectorize

2630where

2731

2832-- base

29−import Data.Kind ( Constraint, Type )

33+import Data.Kind ( Type )

3034import Data.List.NonEmpty ( NonEmpty )

3135import Data.Type.Equality ( (:~:)( Refl ) )

3236import Prelude

3337

3438-- rel8

3539import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler )

36−import Rel8.Schema.Dict ( Dict( Dict ) )

3740import qualified Rel8.Schema.Kind as K

3841import Rel8.Schema.HTable

39− ( HTable, HConstrainTable, HField

40− , hfield, htabulate, htabulateA, htraverse, hdicts, hspecs

42+ ( HTable

43+ , hfield, htabulate, htabulateA, hspecs

4144 )

4245import Rel8.Schema.Nullability ( IsMaybe, Nullability( NonNullable ) )

4346import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )

@@ -46,6 +49,9 @@ import Rel8.Type.Information ( TypeInformation )

4649

4750-- semialign

4851import Data.Zip ( Unzip, Repeat, Zippy(..) )

52+import Rel8.FCF

53+import Rel8.Schema.HTable.MapTable

54+import GHC.Generics (Generic)

4955

5056

5157class Vector list where

@@ -67,104 +73,41 @@ instance Vector NonEmpty where

6773

6874

6975type HVectorize :: (Type -> Type) -> K.HTable -> K.HTable

70−newtype HVectorize list table context =

71− HVectorize (table (VectorizeSpec list context))

76+newtype HVectorize list table context = HVectorize (HMapTable (Vectorize list) table context)

77+ deriving stock Generic

78+ deriving anyclass HTable

7279

7380

74−type HVectorizeField :: (Type -> Type) -> K.HTable -> Spec -> Type

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+data Vectorize :: (Type -> Type) -> Spec -> Exp Spec

8182

8283

83−instance (HTable table, Vector list) => HTable (HVectorize list table) where

84− type HField (HVectorize list table) = HVectorizeField list table

85− type HConstrainTable (HVectorize list table) c =

86− HConstrainTable table (VectorizeSpecC list c)

84+type instance Eval (Vectorize list ('Spec labels necessity _ a)) = 'Spec labels necessity (list a) (list a)

8785

88− hfield (HVectorize table) (HVectorizeField field) =

89− getVectorizeSpec (hfield table field)

9086

91− htabulate f = HVectorize $ htabulate $ \field -> case hfield hspecs field of

92− SSpec {} -> VectorizeSpec (f (HVectorizeField field))

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

87+instance Vector list => MapSpec (Vectorize list) where

88+ mapInfo = \case

10289 SSpec {..} -> case listIsn'tMaybe @list nullability of

103− Refl -> VectorizeSpec SSpec

90+ Refl -> SSpec

10491 { nullability = NonNullable

10592 , info = vectorTypeInformation nullability info

10693 , ..

10794 }

10895

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−

13196

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)

15598 => (forall labels necessity db a. ()

15699 => SSpec ('Spec labels necessity db a)

157100 -> f (context ('Spec labels necessity db a))

158101 -> context' ('Spec labels necessity (list a) (list a)))

159102 -> f (t context)

160103 -> HVectorize list t context'

161−hvectorize vectorizer as = HVectorize $ htabulate $ \field ->

104+hvectorize vectorizer as = HVectorize $ htabulate $ \(HMapTableField field) ->

162105 case hfield hspecs field of

163− spec@SSpec {} -> VectorizeSpec (vectorizer spec (fmap (`hfield` field) as))

106+ spec@SSpec {} -> vectorizer spec (fmap (`hfield` field) as)

164107{-# INLINABLE hvectorize #-}

165108

166109

167−hunvectorize :: (HTable t, Repeat f)

110+hunvectorize :: (HTable t, Repeat f, Vector list)

168111 => (forall labels necessity db a. ()

169112 => SSpec ('Spec labels necessity db a)

170113 -> context ('Spec labels necessity (list a) (list a))

@@ -173,12 +116,12 @@ hunvectorize :: (HTable t, Repeat f)

173116 -> f (t context')

174117hunvectorize unvectorizer (HVectorize table) =

175118 getZippy $ htabulateA $ \field -> case hfield hspecs field of

176− spec -> case hfield table field of

177− VectorizeSpec a -> Zippy (unvectorizer spec a)

119+ spec@SSpec{} -> case hfield table (HMapTableField field) of

120+ a -> Zippy (unvectorizer spec a)

178121{-# INLINABLE hunvectorize #-}

179122

180123

181−happend :: HTable t =>

124+happend :: (HTable t, Vector list) =>

182125 ( forall labels necessity db a. ()

183126 => Nullability db a

184127 -> TypeInformation db

@@ -190,9 +133,9 @@ happend :: HTable t =>

190133 -> HVectorize list t context

191134 -> HVectorize list t context

192135happend append (HVectorize as) (HVectorize bs) = HVectorize $

193− htabulate $ \field -> case (hfield as field, hfield bs field) of

194− (VectorizeSpec a, VectorizeSpec b) -> case hfield hspecs field of

195− SSpec {nullability, info} -> VectorizeSpec $ append nullability info a b

136+ htabulate $ \field@(HMapTableField j) -> case (hfield as field, hfield bs field) of

137+ (a, b) -> case hfield hspecs j of

138+ SSpec {nullability, info} -> append nullability info a b

196139

197140

198141hempty :: HTable t =>

@@ -202,12 +145,17 @@ hempty :: HTable t =>

202145 -> context ('Spec labels necessity [a] [a])

203146 )

204147 -> HVectorize [] t context

205−hempty empty = HVectorize $ htabulate $ \field -> case hfield hspecs field of

206− SSpec {nullability, info} -> VectorizeSpec (empty nullability info)

148+hempty empty = HVectorize $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of

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

207155

208156

209157hrelabel :: HLabelable context

210158 => (forall ctx. HLabelable ctx => t ctx -> u ctx)

211159 -> HVectorize list t context

212160 -> HVectorize list u context

213−hrelabel f (HVectorize table) = HVectorize (f table)

161+hrelabel f (HVectorize (HMapTable table)) = HVectorize (HMapTable (f table))