032242f · rel8 · git.iko.soy

git.iko.soy/rel8

Add Projection and Field (#112)

A `Projection a b` is a special type of function `a -> b` whereby the resulting `b` is guaranteed to be composed only from columns contained in `a`. We can use this fact to give `ListTable` and `NonEmptyTable` a limit kind of functor. We call this functor `Projectable`, and its `fmap` is called `project`. There's also `Biprojectable` and `biproject` for `EitherTable` and `TheseTable`.

commit032242f246434132af2cb665462ba02f72cd9750 authorShane <shane.obrien@circuithub.com> dateWed 7 Jul 2021, 16:15 (5 years ago) parent119c825

22 files changed+285−62

compare with master

unifiedsplit

rel8.cabal+2

@@ -116,6 +116,7 @@ library

116116

117117 Rel8.Schema.Context.Nullify

118118 Rel8.Schema.Dict

119+ Rel8.Schema.Field

119120 Rel8.Schema.HTable

120121 Rel8.Schema.HTable.Either

121122 Rel8.Schema.HTable.Identity

@@ -159,6 +160,7 @@ library

159160 Rel8.Table.Opaleye

160161 Rel8.Table.Ord

161162 Rel8.Table.Order

163+ Rel8.Table.Projection

162164 Rel8.Table.Rel8able

163165 Rel8.Table.Serialize

164166 Rel8.Table.These

src/Rel8.hs+9

@@ -173,6 +173,13 @@ module Rel8

173173 , Query

174174 , showQuery

175175

176+ -- ** Projection

177+ , Projection

178+ , Projectable( project )

179+ , Biprojectable( biproject )

180+ , Projecting

181+ , Field

182+

176183 -- ** Selecting rows

177184 , Selects

178185 , each

@@ -317,6 +324,7 @@ import Rel8.Query.SQL (showQuery)

317324import Rel8.Query.Set

318325import Rel8.Query.These

319326import Rel8.Query.Values

327+import Rel8.Schema.Field

320328import Rel8.Schema.HTable

321329import Rel8.Schema.Name

322330import Rel8.Schema.Null hiding ( nullable )

@@ -342,6 +350,7 @@ import Rel8.Table.Name

342350import Rel8.Table.NonEmpty

343351import Rel8.Table.Ord

344352import Rel8.Table.Order

353+import Rel8.Table.Projection

345354import Rel8.Table.Rel8able ()

346355import Rel8.Table.Serialize

347356import Rel8.Table.These

src/Rel8/Column/Either.hs+1−6

@@ -12,10 +12,7 @@ import Data.Kind ( Type )

1212import Prelude

1313

1414-- rel8

15−import Rel8.Aggregate ( Aggregate )

16−import Rel8.Expr ( Expr )

1715import qualified Rel8.Schema.Kind as K

18−import Rel8.Schema.Name ( Name )

1916import Rel8.Schema.Result ( Result )

2017import Rel8.Table.Either ( EitherTable )

2118

@@ -25,7 +22,5 @@ import Rel8.Table.Either ( EitherTable )

2522-- 'Result' context.

2623type HEither :: K.Context -> Type -> Type -> Type

2724type family HEither context = either | either -> context where

28− HEither Aggregate = EitherTable Aggregate

29− HEither Expr = EitherTable Expr

30− HEither Name = EitherTable Name

3125 HEither Result = Either

26+ HEither context = EitherTable context

src/Rel8/Column/List.hs+1−6

@@ -12,10 +12,7 @@ import Data.Kind ( Type )

1212import Prelude ()

1313

1414-- rel8

15−import Rel8.Aggregate ( Aggregate )

16−import Rel8.Expr ( Expr )

1715import qualified Rel8.Schema.Kind as K

18−import Rel8.Schema.Name ( Name )

1916import Rel8.Schema.Result ( Result )

2017import Rel8.Table.List ( ListTable )

2118

@@ -24,7 +21,5 @@ import Rel8.Table.List ( ListTable )

2421-- @a@ in the 'Expr' context, and a @[a]@ in the 'Result' context.

2522type HList :: K.Context -> Type -> Type

2623type family HList context = list | list -> context where

27− HList Aggregate = ListTable Aggregate

28− HList Expr = ListTable Expr

29− HList Name = ListTable Name

3024 HList Result = []

25+ HList context = ListTable context

src/Rel8/Column/Maybe.hs+1−6

@@ -12,10 +12,7 @@ import Data.Kind ( Type )

1212import Prelude

1313

1414-- rel8

15−import Rel8.Aggregate ( Aggregate )

16−import Rel8.Expr ( Expr )

1715import qualified Rel8.Schema.Kind as K

18−import Rel8.Schema.Name ( Name )

1916import Rel8.Schema.Result ( Result )

2017import Rel8.Table.Maybe ( MaybeTable )

2118

@@ -25,7 +22,5 @@ import Rel8.Table.Maybe ( MaybeTable )

2522-- context.

2623type HMaybe :: K.Context -> Type -> Type

2724type family HMaybe context = maybe | maybe -> context where

28− HMaybe Aggregate = MaybeTable Aggregate

29− HMaybe Expr = MaybeTable Expr

30− HMaybe Name = MaybeTable Name

3125 HMaybe Result = Maybe

26+ HMaybe context = MaybeTable context

src/Rel8/Column/NonEmpty.hs+1−6

@@ -13,10 +13,7 @@ import Data.List.NonEmpty ( NonEmpty )

1313import Prelude ()

1414

1515-- rel8

16−import Rel8.Aggregate ( Aggregate )

17−import Rel8.Expr ( Expr )

1816import qualified Rel8.Schema.Kind as K

19−import Rel8.Schema.Name ( Name )

2017import Rel8.Schema.Result ( Result )

2118import Rel8.Table.NonEmpty ( NonEmptyTable )

2219

@@ -26,7 +23,5 @@ import Rel8.Table.NonEmpty ( NonEmptyTable )

2623-- 'Result' context.

2724type HNonEmpty :: K.Context -> Type -> Type

2825type family HNonEmpty context = nonEmpty | nonEmpty -> context where

29− HNonEmpty Aggregate = NonEmptyTable Aggregate

30− HNonEmpty Expr = NonEmptyTable Expr

31− HNonEmpty Name = NonEmptyTable Name

3226 HNonEmpty Result = NonEmpty

27+ HNonEmpty context = NonEmptyTable context

src/Rel8/Column/These.hs+1−6

@@ -12,10 +12,7 @@ import Data.Kind ( Type )

1212import Prelude ()

1313

1414-- rel8

15−import Rel8.Aggregate ( Aggregate )

16−import Rel8.Expr ( Expr )

1715import qualified Rel8.Schema.Kind as K

18−import Rel8.Schema.Name ( Name )

1916import Rel8.Schema.Result ( Result )

2017import Rel8.Table.These ( TheseTable )

2118

@@ -28,7 +25,5 @@ import Data.These ( These )

2825-- 'Result' context.

2926type HThese :: K.Context -> Type -> Type -> Type

3027type family HThese context = these | these -> context where

31− HThese Aggregate = TheseTable Aggregate

32− HThese Expr = TheseTable Expr

33− HThese Name = TheseTable Name

3428 HThese Result = These

29+ HThese context = TheseTable context

src/Rel8/Generic/Rel8able.hs+14−1

@@ -6,6 +6,7 @@

66{-# language FlexibleInstances #-}

77{-# language LambdaCase #-}

88{-# language MultiParamTypeClasses #-}

9+{-# language QuantifiedConstraints #-}

910{-# language ScopedTypeVariables #-}

1011{-# language StandaloneKindSignatures #-}

1112{-# language TypeApplications #-}

@@ -38,6 +39,7 @@ import Rel8.Generic.Table ( GAlgebra )

3839import qualified Rel8.Generic.Table.Record as G

3940import qualified Rel8.Kind.Algebra as K ( Algebra(..) )

4041import Rel8.Kind.Context ( SContext(..) )

42+import Rel8.Schema.Field ( Field )

4143import Rel8.Schema.HTable ( HTable )

4244import qualified Rel8.Schema.Kind as K

4345import Rel8.Schema.Name ( Name )

@@ -149,6 +151,7 @@ class HTable (GColumns t) => Rel8able t where

149151 default gfromColumns :: forall context.

150152 ( SRel8able t Aggregate

151153 , SRel8able t Expr

154+ , forall table. SRel8able t (Field table)

152155 , SRel8able t Name

153156 , SSerialize t

154157 )

@@ -156,12 +159,14 @@ class HTable (GColumns t) => Rel8able t where

156159 gfromColumns = \case

157160 SAggregate -> sfromColumns

158161 SExpr -> sfromColumns

162+ SField -> sfromColumns

159163 SName -> sfromColumns

160164 SResult -> sfromResult

161165

162166 default gtoColumns :: forall context.

163167 ( SRel8able t Aggregate

164168 , SRel8able t Expr

169+ , forall table. SRel8able t (Field table)

165170 , SRel8able t Name

166171 , SSerialize t

167172 )

@@ -169,6 +174,7 @@ class HTable (GColumns t) => Rel8able t where

169174 gtoColumns = \case

170175 SAggregate -> stoColumns

171176 SExpr -> stoColumns

177+ SField -> stoColumns

172178 SName -> stoColumns

173179 SResult -> stoResult

174180

@@ -190,11 +196,18 @@ type GRep t context = Rep (Record (t context))

190196

191197

192198type SRel8able :: K.Rel8able -> K.Context -> Constraint

193−type SRel8able t context =

199+class

194200 ( Generic (Record (t context))

195201 , G.GTable (TTable context) TColumns (GRep t context)

196202 , G.GColumns TColumns (GRep t context) ~ GColumns t

197203 )

204+ => SRel8able t context

205+instance

206+ ( Generic (Record (t context))

207+ , G.GTable (TTable context) TColumns (GRep t context)

208+ , G.GColumns TColumns (GRep t context) ~ GColumns t

209+ )

210+ => SRel8able t context

198211

199212

200213type SSerialize :: K.Rel8able -> Constraint

src/Rel8/Kind/Context.hs+6

@@ -16,6 +16,7 @@ import Prelude ()

1616-- rel8

1717import Rel8.Aggregate ( Aggregate )

1818import Rel8.Expr ( Expr )

19+import Rel8.Schema.Field ( Field )

1920import Rel8.Schema.Kind ( Context )

2021import Rel8.Schema.Name ( Name )

2122import Rel8.Schema.Result ( Result )

@@ -25,6 +26,7 @@ type SContext :: Context -> Type

2526data SContext context where

2627 SAggregate :: SContext Aggregate

2728 SExpr :: SContext Expr

29+ SField :: SContext (Field table)

2830 SName :: SContext Name

2931 SResult :: SContext Result

3032

@@ -42,6 +44,10 @@ instance Reifiable Expr where

4244 contextSing = SExpr

4345

4446

47+instance Reifiable (Field table) where

48+ contextSing = SField

49+

50+

4551instance Reifiable Result where

4652 contextSing = SResult

4753

src/Rel8/Schema/Context/Nullify.hs+29−25

@@ -31,6 +31,7 @@ import Rel8.Expr.Bool ( boolExpr )

3131import Rel8.Expr.Null ( nullify, unsafeUnnullify )

3232import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )

3333import Rel8.Kind.Context ( SContext(..) )

34+import Rel8.Schema.Field ( Field )

3435import qualified Rel8.Schema.Kind as K

3536import Rel8.Schema.Name ( Name( Name ) )

3637import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )

@@ -64,7 +65,8 @@ instance Nullifiable Name where

6465

6566type NonNullifiability :: K.Context -> Type

6667data NonNullifiability context where

67− NNResult :: NonNullifiability Result

68+ NField :: NonNullifiability (Field table)

69+ NResult :: NonNullifiability Result

6870

6971

7072nullifiableOrNot :: ()

@@ -73,8 +75,9 @@ nullifiableOrNot :: ()

7375nullifiableOrNot = \case

7476 SAggregate -> Right NAggregate

7577 SExpr -> Right NExpr

78+ SField -> Left NField

7679 SName -> Right NName

77− SResult -> Left NNResult

80+ SResult -> Left NResult

7881

7982

8083absurd :: Nullifiability context -> NonNullifiability context -> a

@@ -91,21 +94,20 @@ guarder :: ()

9194 -> (Expr tag -> Expr Bool)

9295 -> context (Maybe a)

9396 -> context (Maybe a)

94−guarder SAggregate tag _ isNonNull (Aggregate a) =

95− mapInputs (toPrimExpr . run . fromPrimExpr) $

96− Aggregate $

97− run <$> a

98− where

99− mtag = foldInputs (\_ -> pure . fromPrimExpr) tag

100− run = maybe id (sguard . isNonNull) (getFirst mtag)

101−guarder SExpr tag _ isNonNull a = sguard condition a

102− where

103− condition = isNonNull tag

104−guarder SName _ _ _ name = name

105−guarder SResult (Identity tag) isNonNull _ (Identity a) =

106− Identity (bool Nothing a condition)

107− where

108− condition = isNonNull tag

97+guarder = \case

98+ SAggregate -> \tag _ isNonNull (Aggregate a) ->

99+ let

100+ mtag = foldInputs (\_ -> pure . fromPrimExpr) tag

101+ run = maybe id (sguard . isNonNull) (getFirst mtag)

102+ in

103+ mapInputs (toPrimExpr . run . fromPrimExpr) $

104+ Aggregate $

105+ run <$> a

106+ SExpr -> \tag _ isNonNull a -> sguard (isNonNull tag) a

107+ SField -> \_ _ _ field -> field

108+ SName -> \_ _ _ name -> name

109+ SResult -> \(Identity tag) isNonNull _ (Identity a) ->

110+ Identity (bool Nothing a (isNonNull tag))

109111

110112

111113nullifier :: ()

@@ -113,10 +115,11 @@ nullifier :: ()

113115 -> Spec a

114116 -> context a

115117 -> context (Nullify a)

116−nullifier NAggregate Spec {nullity} (Aggregate a) =

117− Aggregate $ snullify nullity <$> a

118−nullifier NExpr Spec {nullity} a = snullify nullity a

119−nullifier NName _ (Name a) = Name a

118+nullifier = \case

119+ NAggregate -> \Spec {nullity} (Aggregate a) ->

120+ Aggregate $ snullify nullity <$> a

121+ NExpr -> \Spec {nullity} a -> snullify nullity a

122+ NName -> \_ (Name a) -> Name a

120123

121124

122125unnullifier :: ()

@@ -124,10 +127,11 @@ unnullifier :: ()

124127 -> Spec a

125128 -> context (Nullify a)

126129 -> context a

127−unnullifier NAggregate Spec {nullity} (Aggregate a) =

128− Aggregate $ sunnullify nullity <$> a

129−unnullifier NExpr Spec {nullity} a = sunnullify nullity a

130−unnullifier NName _ (Name a) = Name a

130+unnullifier = \case

131+ NAggregate -> \Spec {nullity} (Aggregate a) ->

132+ Aggregate $ sunnullify nullity <$> a

133+ NExpr -> \Spec {nullity} a -> sunnullify nullity a

134+ NName -> \_ (Name a) -> Name a

131135

132136

133137sguard :: Expr Bool -> Expr (Maybe a) -> Expr (Maybe a)

src/Rel8/Schema/Field.hsnew file+50

@@ -0,0 +1,50 @@

1+{-# language DataKinds #-}

2+{-# language FlexibleContexts #-}

3+{-# language MultiParamTypeClasses #-}

4+{-# language StandaloneKindSignatures #-}

5+{-# language TypeFamilies #-}

7+module Rel8.Schema.Field

8+ ( Field(..)

9+ , fields

10+ )

11+where

12+

13+-- base

14+import Data.Functor.Identity ( Identity( Identity ) )

15+import Data.Kind ( Type )

16+import Prelude

17+

18+-- rel8

19+import Rel8.Schema.HTable ( HField, htabulate )

20+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )

21+import Rel8.Schema.Kind as K

22+import Rel8.Schema.Null ( Sql )

23+import Rel8.Table

24+ ( Table, Columns, Context, fromColumns, toColumns

25+ , FromExprs, fromResult, toResult

26+ , Transpose

27+ )

28+import Rel8.Table.Transpose ( Transposes )

29+import Rel8.Type ( DBType )

30+

31+

32+-- | A special context used in the construction of 'Rel8.Projection's.

33+type Field :: Type -> K.Context

34+newtype Field table a = Field (HField (Columns table) a)

35+

36+

37+instance Sql DBType a => Table (Field table) (Field table a) where

38+ type Columns (Field table a) = HIdentity a

39+ type Context (Field table a) = Field table

40+ type FromExprs (Field table a) = a

41+ type Transpose to (Field table a) = to a

42+

43+ toColumns = HIdentity

44+ fromColumns (HIdentity a) = a

45+ toResult a = HIdentity (Identity a)

46+ fromResult (HIdentity (Identity a)) = a

47+

48+

49+fields :: Transposes context (Field table) table fields => fields

50+fields = fromColumns $ htabulate Field

src/Rel8/Schema/HTable/Label.hs+11

@@ -1,4 +1,5 @@

11{-# language DataKinds #-}

2+{-# language RankNTypes #-}

23{-# language RecordWildCards #-}

34{-# language ScopedTypeVariables #-}

45{-# language StandaloneKindSignatures #-}

@@ -7,6 +8,7 @@

89module Rel8.Schema.HTable.Label

910 ( HLabel, hlabel, hrelabel, hunlabel

11+ , hproject

1012 )

1113where

1214

@@ -18,6 +20,9 @@ import Prelude

1820

1921-- rel8

2022import Rel8.Schema.HTable

23+ ( HTable, HConstrainTable, HField

24+ , htabulate, hfield, htraverse, hdicts, hspecs

25+ )

2126import qualified Rel8.Schema.Kind as K

2227import Rel8.Schema.Spec ( Spec(..) )

2328

@@ -57,3 +62,9 @@ hrelabel = hlabel . hunlabel

5762hunlabel :: forall label t context. HLabel label t context -> t context

5863hunlabel (HLabel a) = a

5964{-# INLINABLE hunlabel #-}

65+

66+

67+hproject :: ()

68+ => (forall ctx. t ctx -> t' ctx)

69+ -> HLabel label t context -> HLabel label t' context

70+hproject f (HLabel a) = HLabel (f a)

src/Rel8/Schema/HTable/MapTable.hs+8

@@ -6,6 +6,7 @@

66{-# language GADTs #-}

77{-# language InstanceSigs #-}

88{-# language MultiParamTypeClasses #-}

9+{-# language RankNTypes #-}

910{-# language ScopedTypeVariables #-}

1011{-# language StandaloneKindSignatures #-}

1112{-# language TypeApplications #-}

@@ -18,6 +19,7 @@ module Rel8.Schema.HTable.MapTable

1819 , MapSpec(..)

1920 , Precompose(..)

2021 , HMapTableField(..)

22+ , hproject

2123 )

2224where

2325

@@ -89,3 +91,9 @@ class MapSpec f where

8991type ComposeConstraint :: (Type -> Exp Type) -> (Type -> Constraint) -> Type -> Constraint

9092class c (Eval (f a)) => ComposeConstraint f c a

9193instance c (Eval (f a)) => ComposeConstraint f c a

94+

95+

96+hproject :: ()

97+ => (forall ctx. t ctx -> t' ctx)

98+ -> HMapTable f t context -> HMapTable f t' context

99+hproject f (HMapTable a) = HMapTable (f a)

src/Rel8/Schema/HTable/Nullify.hs+8

@@ -23,6 +23,7 @@ module Rel8.Schema.HTable.Nullify

2323 , hnulls

2424 , hnullify

2525 , hunnullify

26+ , hproject

2627 )

2728where

2829

@@ -38,6 +39,7 @@ import Rel8.Schema.HTable.MapTable

3839 ( HMapTable, HMapTableField( HMapTableField )

3940 , MapSpec, mapInfo

4041 )

42+import qualified Rel8.Schema.HTable.MapTable as HMapTable ( hproject )

4143import qualified Rel8.Schema.Kind as K

4244import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

4345import qualified Rel8.Schema.Null as Type ( Nullify )

@@ -107,3 +109,9 @@ hunnullify unnullifier (HNullify as) =

107109 spec@Spec {} -> case hfield as (HMapTableField field) of

108110 a -> unnullifier spec a

109111{-# INLINABLE hunnullify #-}

112+

113+

114+hproject :: ()

115+ => (forall ctx. t ctx -> t' ctx)

116+ -> HNullify t context -> HNullify t' context

117+hproject f (HNullify a) = HNullify (HMapTable.hproject f a)

src/Rel8/Schema/HTable/Vectorize.hs+14−3

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

2121 ( HVectorize

2222 , hvectorize, hunvectorize

2323 , happend, hempty

24+ , hproject

2425 )

2526where

2627

2728-- base

2829import Data.Kind ( Type )

2930import Data.List.NonEmpty ( NonEmpty )

31+import GHC.Generics (Generic)

3032import Prelude

3133

3234-- rel8

35+import Rel8.FCF ( Eval, Exp )

3336import Rel8.Schema.Dict ( Dict( Dict ) )

3437import qualified Rel8.Schema.Kind as K

3538import Rel8.Schema.HTable ( HTable, hfield, htabulate, htabulateA, hspecs )

39+import Rel8.Schema.HTable.MapTable

40+ ( HMapTable, HMapTableField( HMapTableField )

41+ , MapSpec, mapInfo

42+ )

43+import qualified Rel8.Schema.HTable.MapTable as HMapTable ( hproject )

3644import Rel8.Schema.Null ( Unnullify, NotNull, Nullity( NotNull ) )

3745import Rel8.Schema.Spec ( Spec(..) )

3846import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )

@@ -40,9 +48,6 @@ import Rel8.Type.Information ( TypeInformation )

4048

4149-- semialign

4250import Data.Zip ( Unzip, Zip, Zippy(..) )

43−import Rel8.FCF

44−import Rel8.Schema.HTable.MapTable

45−import GHC.Generics (Generic)

4651

4752

4853class Vector list where

@@ -122,3 +127,9 @@ hempty :: HTable t

122127 -> HVectorize [] t context

123128hempty empty = HVectorize $ htabulate $ \(HMapTableField field) ->

124129 empty (hfield hspecs field)

130+

131+

132+hproject :: ()

133+ => (forall ctx. t ctx -> t' ctx)

134+ -> HVectorize list t context -> HVectorize list t' context

135+hproject f (HVectorize a) = HVectorize (HMapTable.hproject f a)

src/Rel8/Table/Either.hs+10

@@ -54,6 +54,7 @@ import Rel8.Table.Bool ( bool )

5454import Rel8.Table.Eq ( EqTable, eqTable )

5555import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )

5656import Rel8.Table.Ord ( OrdTable, ordTable )

57+import Rel8.Table.Projection ( Biprojectable, Projectable, biproject, project )

5758import Rel8.Table.Serialize ( ToExprs )

5859import Rel8.Table.Undefined ( undefined )

5960import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )

@@ -78,10 +79,19 @@ data EitherTable context a b = EitherTable

7879 deriving stock Functor

7980

8081

82+instance Biprojectable (EitherTable context) where

83+ biproject f g (EitherTable tag a b) =

84+ EitherTable tag (project f a) (project g b)

85+

86+

8187instance Nullifiable context => Bifunctor (EitherTable context) where

8288 bimap f g (EitherTable tag a b) = EitherTable tag (fmap f a) (fmap g b)

8389

8490

91+instance Projectable (EitherTable context a) where

92+ project f (EitherTable tag a b) = EitherTable tag a (project f b)

93+

94+

8595instance (context ~ Expr, Table Expr a) => Apply (EitherTable context a) where

8696 EitherTable tag l1 f <.> EitherTable tag' l2 a =

8797 EitherTable (tag <> tag') (bool l1 l2 (isLeft tag)) (f <.> a)

src/Rel8/Table/List.hs+10−1

@@ -25,7 +25,11 @@ import Rel8.Expr ( Expr )

2525import Rel8.Expr.Array ( sappend, sempty, slistOf )

2626import Rel8.Schema.Dict ( Dict( Dict ) )

2727import Rel8.Schema.HTable.List ( HListTable )

28−import Rel8.Schema.HTable.Vectorize ( happend, hempty, hvectorize, hunvectorize )

28+import Rel8.Schema.HTable.Vectorize

29+ ( hvectorize, hunvectorize

30+ , happend, hempty

31+ , hproject

32+ )

2933import qualified Rel8.Schema.Kind as K

3034import Rel8.Schema.Name ( Name( Name ) )

3135import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

@@ -42,6 +46,7 @@ import Rel8.Table.Alternative

4246 )

4347import Rel8.Table.Eq ( EqTable, eqTable )

4448import Rel8.Table.Ord ( OrdTable, ordTable )

49+import Rel8.Table.Projection ( Projectable, project, apply )

4550import Rel8.Table.Serialize ( ToExprs )

4651

4752

@@ -52,6 +57,10 @@ newtype ListTable context a =

5257 ListTable (HListTable (Columns a) (Context a))

5358

5459

60+instance Projectable (ListTable context) where

61+ project f (ListTable a) = ListTable (hproject (apply f) a)

62+

63+

5564instance (Table context a, context ~ context') =>

5665 Table context' (ListTable context a)

5766 where

src/Rel8/Table/Maybe.hs+5

@@ -58,6 +58,7 @@ import Rel8.Table.Alternative

5858import Rel8.Table.Bool ( bool )

5959import Rel8.Table.Eq ( EqTable, eqTable )

6060import Rel8.Table.Ord ( OrdTable, ordTable )

61+import Rel8.Table.Projection ( Projectable, project )

6162import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )

6263import Rel8.Table.Serialize ( ToExprs )

6364import Rel8.Table.Undefined ( undefined )

@@ -85,6 +86,10 @@ data MaybeTable context a = MaybeTable

8586 deriving stock Functor

8687

8788

89+instance Projectable (MaybeTable context) where

90+ project f (MaybeTable tag a) = MaybeTable tag (project f a)

91+

92+

8893instance context ~ Expr => Apply (MaybeTable context) where

8994 MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f <.> a)

9095

src/Rel8/Table/NonEmpty.hs+10−1

@@ -26,7 +26,11 @@ import Rel8.Expr ( Expr )

2626import Rel8.Expr.Array ( sappend1, snonEmptyOf )

2727import Rel8.Schema.Dict ( Dict( Dict ) )

2828import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )

29−import Rel8.Schema.HTable.Vectorize ( happend, hvectorize, hunvectorize )

29+import Rel8.Schema.HTable.Vectorize

30+ ( hvectorize, hunvectorize

31+ , happend

32+ , hproject

33+ )

3034import qualified Rel8.Schema.Kind as K

3135import Rel8.Schema.Name ( Name( Name ) )

3236import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

@@ -40,6 +44,7 @@ import Rel8.Table

4044import Rel8.Table.Alternative ( AltTable, (<|>:) )

4145import Rel8.Table.Eq ( EqTable, eqTable )

4246import Rel8.Table.Ord ( OrdTable, ordTable )

47+import Rel8.Table.Projection ( Projectable, project, apply )

4348import Rel8.Table.Serialize ( ToExprs )

4449

4550

@@ -50,6 +55,10 @@ newtype NonEmptyTable context a =

5055 NonEmptyTable (HNonEmptyTable (Columns a) (Context a))

5156

5257

58+instance Projectable (NonEmptyTable context) where

59+ project f (NonEmptyTable a) = NonEmptyTable (hproject (apply f) a)

60+

61+

5362instance (Table context a, context ~ context') =>

5463 Table context' (NonEmptyTable context a)

5564 where

src/Rel8/Table/Nullify.hs+12−1

@@ -39,7 +39,11 @@ import Rel8.Schema.Context.Nullify

3939 )

4040import Rel8.Schema.Dict ( Dict( Dict ) )

4141import Rel8.Schema.HTable ( HTable )

42−import Rel8.Schema.HTable.Nullify ( HNullify, hnulls, hnullify, hunnullify, hguard )

42+import Rel8.Schema.HTable.Nullify

43+ ( HNullify, hnulls, hnullify, hunnullify

44+ , hguard

45+ , hproject

46+ )

4347import qualified Rel8.Schema.Kind as K

4448import qualified Rel8.Schema.Result as R

4549import Rel8.Table

@@ -49,6 +53,7 @@ import Rel8.Table

4953 )

5054import Rel8.Table.Eq ( EqTable, eqTable )

5155import Rel8.Table.Ord ( OrdTable, ordTable )

56+import Rel8.Table.Projection ( Projectable, apply, project )

5257

5358-- semigroupoids

5459import Data.Functor.Apply ( Apply, (<.>), liftF2 )

@@ -62,6 +67,12 @@ data Nullify context a

6267 | Fields (NonNullifiability context) (HNullify (Columns a) (Context a))

6368

6469

70+instance Projectable (Nullify context) where

71+ project f = \case

72+ Table nullifiable a -> Table nullifiable (fromColumns (apply f (toColumns a)))

73+ Fields nonNullifiable a -> Fields nonNullifiable (hproject (apply f) a)

74+

75+

6576instance Nullifiable context => Functor (Nullify context) where

6677 fmap f = \case

6778 Table nullifiable a -> Table nullifiable (f a)

src/Rel8/Table/Projection.hsnew file+73

@@ -0,0 +1,73 @@

1+{-# language FlexibleContexts #-}

2+{-# language FlexibleInstances #-}

3+{-# language MonoLocalBinds #-}

4+{-# language MultiParamTypeClasses #-}

5+{-# language StandaloneKindSignatures #-}

6+{-# language UndecidableInstances #-}

8+module Rel8.Table.Projection

9+ ( Projection

10+ , Projectable( project )

11+ , Biprojectable( biproject )

12+ , Projecting

13+ , apply

14+ )

15+where

16+

17+-- base

18+import Data.Kind ( Constraint, Type )

19+import Prelude

20+

21+-- rel8

22+import Rel8.Schema.Field ( Field( Field ), fields )

23+import Rel8.Schema.HTable ( hfield, htabulate )

24+import Rel8.Table ( Columns, Context, Transpose, toColumns )

25+import Rel8.Table.Transpose ( Transposes )

26+

27+

28+-- | The constraint @'Projecting' a b@ ensures that @'Projection' a b@ is a

29+-- usable 'Projection'.

30+type Projecting :: Type -> Type -> Constraint

31+class

32+ ( Transposes (Field a) (Context a) a (Transpose (Field a) a)

33+ , Transposes (Field a) (Context a) b (Transpose (Field a) b)

34+ )

35+ => Projecting a b

36+instance

37+ ( Transposes (Field a) (Context a) a (Transpose (Field a) a)

38+ , Transposes (Field a) (Context a) b (Transpose (Field b) b)

39+ )

40+ => Projecting a b

41+

42+

43+-- | A @'Projection' a b@s is a special type of function @a -> b@ whereby the

44+-- resulting @b@ is guaranteed to be composed only from columns contained in

45+-- @a@.

46+type Projection :: Type -> Type -> Type

47+type Projection a b = Transpose (Field a) a -> Transpose (Field a) b

48+

49+

50+-- | @'Projectable' f@ means that @f@ is a kind of functor on 'Rel8.Table's

51+-- that allows the mapping of a 'Projection' over its underlying columns.

52+type Projectable :: (Type -> Type) -> Constraint

53+class Projectable f where

54+ -- | Map a 'Projection' over @f@.

55+ project :: Projecting a b

56+ => Projection a b -> f a -> f b

57+

58+

59+-- | @'Biprojectable' p@ means that @p@ is a kind of bifunctor on

60+-- 'Rel8.Table's that allows the mapping of a pair of 'Projection's over its

61+-- underlying columns.

62+type Biprojectable :: (Type -> Type -> Type) -> Constraint

63+class Biprojectable p where

64+ -- | Map a pair of 'Projection's over @p@.

65+ biproject :: (Projecting a b, Projecting c d)

66+ => Projection a b -> Projection c d -> p a c -> p b d

67+

68+

69+apply :: Projecting a b

70+ => Projection a b -> Columns a context -> Columns b context

71+apply f a = case toColumns (f fields) of

72+ bs -> htabulate $ \field -> case hfield bs field of

73+ Field field' -> hfield a field'

src/Rel8/Table/These.hs+9

@@ -60,6 +60,7 @@ import Rel8.Table.Maybe

6060 )

6161import Rel8.Table.Nullify ( Nullify, guard )

6262import Rel8.Table.Ord ( OrdTable, ordTable )

63+import Rel8.Table.Projection ( Biprojectable, Projectable, biproject, project )

6364import Rel8.Table.Serialize ( ToExprs )

6465import Rel8.Table.Undefined ( undefined )

6566import Rel8.Type.Tag ( MaybeTag )

@@ -88,10 +89,18 @@ data TheseTable context a b = TheseTable

8889 deriving stock Functor

8990

9091

92+instance Biprojectable (TheseTable context) where

93+ biproject f g (TheseTable a b) = TheseTable (project f a) (project g b)

94+

95+

9196instance Nullifiable context => Bifunctor (TheseTable context) where

9297 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)

9398

9499

100+instance Projectable (TheseTable context a) where

101+ project f (TheseTable a b) = TheseTable a (project f b)

102+

103+

95104instance (context ~ Expr, Table Expr a, Semigroup a) =>

96105 Apply (TheseTable context a)

97106 where