git.iko.soy/rel8
on master help sign in
Add Projection and Field (#112)
032242fShane
rel8.cabal+2
compare with master
unifiedsplit
@@ -116,6 +116,7 @@ library
116
116
117 Rel8.Schema.Context.Nullify
117 Rel8.Schema.Context.Nullify
118 Rel8.Schema.Dict
118 Rel8.Schema.Dict
119+ Rel8.Schema.Field
119 Rel8.Schema.HTable
120 Rel8.Schema.HTable
120 Rel8.Schema.HTable.Either
121 Rel8.Schema.HTable.Either
121 Rel8.Schema.HTable.Identity
122 Rel8.Schema.HTable.Identity
@@ -159,6 +160,7 @@ library
159 Rel8.Table.Opaleye
160 Rel8.Table.Opaleye
160 Rel8.Table.Ord
161 Rel8.Table.Ord
161 Rel8.Table.Order
162 Rel8.Table.Order
163+ Rel8.Table.Projection
162 Rel8.Table.Rel8able
164 Rel8.Table.Rel8able
163 Rel8.Table.Serialize
165 Rel8.Table.Serialize
164 Rel8.Table.These
166 Rel8.Table.These
src/Rel8.hs+9
@@ -173,6 +173,13 @@ module Rel8
173 , Query
173 , Query
174 , showQuery
174 , showQuery
175
175
176+ -- ** Projection
177+ , Projection
178+ , Projectable( project )
179+ , Biprojectable( biproject )
180+ , Projecting
181+ , Field
182+
176 -- ** Selecting rows
183 -- ** Selecting rows
177 , Selects
184 , Selects
178 , each
185 , each
@@ -317,6 +324,7 @@ import Rel8.Query.SQL (showQuery)
317import Rel8.Query.Set
324import Rel8.Query.Set
318import Rel8.Query.These
325import Rel8.Query.These
319import Rel8.Query.Values
326import Rel8.Query.Values
327+import Rel8.Schema.Field
320import Rel8.Schema.HTable
328import Rel8.Schema.HTable
321import Rel8.Schema.Name
329import Rel8.Schema.Name
322import Rel8.Schema.Null hiding ( nullable )
330import Rel8.Schema.Null hiding ( nullable )
@@ -342,6 +350,7 @@ import Rel8.Table.Name
342import Rel8.Table.NonEmpty
350import Rel8.Table.NonEmpty
343import Rel8.Table.Ord
351import Rel8.Table.Ord
344import Rel8.Table.Order
352import Rel8.Table.Order
353+import Rel8.Table.Projection
345import Rel8.Table.Rel8able ()
354import Rel8.Table.Rel8able ()
346import Rel8.Table.Serialize
355import Rel8.Table.Serialize
347import Rel8.Table.These
356import Rel8.Table.These
src/Rel8/Column/Either.hs+1−6
@@ -12,10 +12,7 @@ import Data.Kind ( Type )
12import Prelude
12import Prelude
13
13
14-- rel8
14-- rel8
15−import Rel8.Aggregate ( Aggregate )
16−import Rel8.Expr ( Expr )
17import qualified Rel8.Schema.Kind as K
15import qualified Rel8.Schema.Kind as K
18−import Rel8.Schema.Name ( Name )
19import Rel8.Schema.Result ( Result )
16import Rel8.Schema.Result ( Result )
20import Rel8.Table.Either ( EitherTable )
17import Rel8.Table.Either ( EitherTable )
21
18
@@ -25,7 +22,5 @@ import Rel8.Table.Either ( EitherTable )
25-- 'Result' context.
22-- 'Result' context.
26type HEither :: K.Context -> Type -> Type -> Type
23type HEither :: K.Context -> Type -> Type -> Type
27type family HEither context = either | either -> context where
24type family HEither context = either | either -> context where
28− HEither Aggregate = EitherTable Aggregate
29− HEither Expr = EitherTable Expr
30− HEither Name = EitherTable Name
31 HEither Result = Either
25 HEither Result = Either
26+ HEither context = EitherTable context
src/Rel8/Column/List.hs+1−6
@@ -12,10 +12,7 @@ import Data.Kind ( Type )
12import Prelude ()
12import Prelude ()
13
13
14-- rel8
14-- rel8
15−import Rel8.Aggregate ( Aggregate )
16−import Rel8.Expr ( Expr )
17import qualified Rel8.Schema.Kind as K
15import qualified Rel8.Schema.Kind as K
18−import Rel8.Schema.Name ( Name )
19import Rel8.Schema.Result ( Result )
16import Rel8.Schema.Result ( Result )
20import Rel8.Table.List ( ListTable )
17import Rel8.Table.List ( ListTable )
21
18
@@ -24,7 +21,5 @@ import Rel8.Table.List ( ListTable )
24-- @a@ in the 'Expr' context, and a @[a]@ in the 'Result' context.
21-- @a@ in the 'Expr' context, and a @[a]@ in the 'Result' context.
25type HList :: K.Context -> Type -> Type
22type HList :: K.Context -> Type -> Type
26type family HList context = list | list -> context where
23type family HList context = list | list -> context where
27− HList Aggregate = ListTable Aggregate
28− HList Expr = ListTable Expr
29− HList Name = ListTable Name
30 HList Result = []
24 HList Result = []
25+ HList context = ListTable context
src/Rel8/Column/Maybe.hs+1−6
@@ -12,10 +12,7 @@ import Data.Kind ( Type )
12import Prelude
12import Prelude
13
13
14-- rel8
14-- rel8
15−import Rel8.Aggregate ( Aggregate )
16−import Rel8.Expr ( Expr )
17import qualified Rel8.Schema.Kind as K
15import qualified Rel8.Schema.Kind as K
18−import Rel8.Schema.Name ( Name )
19import Rel8.Schema.Result ( Result )
16import Rel8.Schema.Result ( Result )
20import Rel8.Table.Maybe ( MaybeTable )
17import Rel8.Table.Maybe ( MaybeTable )
21
18
@@ -25,7 +22,5 @@ import Rel8.Table.Maybe ( MaybeTable )
25-- context.
22-- context.
26type HMaybe :: K.Context -> Type -> Type
23type HMaybe :: K.Context -> Type -> Type
27type family HMaybe context = maybe | maybe -> context where
24type family HMaybe context = maybe | maybe -> context where
28− HMaybe Aggregate = MaybeTable Aggregate
29− HMaybe Expr = MaybeTable Expr
30− HMaybe Name = MaybeTable Name
31 HMaybe Result = Maybe
25 HMaybe Result = Maybe
26+ HMaybe context = MaybeTable context
src/Rel8/Column/NonEmpty.hs+1−6
@@ -13,10 +13,7 @@ import Data.List.NonEmpty ( NonEmpty )
13import Prelude ()
13import Prelude ()
14
14
15-- rel8
15-- rel8
16−import Rel8.Aggregate ( Aggregate )
17−import Rel8.Expr ( Expr )
18import qualified Rel8.Schema.Kind as K
16import qualified Rel8.Schema.Kind as K
19−import Rel8.Schema.Name ( Name )
20import Rel8.Schema.Result ( Result )
17import Rel8.Schema.Result ( Result )
21import Rel8.Table.NonEmpty ( NonEmptyTable )
18import Rel8.Table.NonEmpty ( NonEmptyTable )
22
19
@@ -26,7 +23,5 @@ import Rel8.Table.NonEmpty ( NonEmptyTable )
26-- 'Result' context.
23-- 'Result' context.
27type HNonEmpty :: K.Context -> Type -> Type
24type HNonEmpty :: K.Context -> Type -> Type
28type family HNonEmpty context = nonEmpty | nonEmpty -> context where
25type family HNonEmpty context = nonEmpty | nonEmpty -> context where
29− HNonEmpty Aggregate = NonEmptyTable Aggregate
30− HNonEmpty Expr = NonEmptyTable Expr
31− HNonEmpty Name = NonEmptyTable Name
32 HNonEmpty Result = NonEmpty
26 HNonEmpty Result = NonEmpty
27+ HNonEmpty context = NonEmptyTable context
src/Rel8/Column/These.hs+1−6
@@ -12,10 +12,7 @@ import Data.Kind ( Type )
12import Prelude ()
12import Prelude ()
13
13
14-- rel8
14-- rel8
15−import Rel8.Aggregate ( Aggregate )
16−import Rel8.Expr ( Expr )
17import qualified Rel8.Schema.Kind as K
15import qualified Rel8.Schema.Kind as K
18−import Rel8.Schema.Name ( Name )
19import Rel8.Schema.Result ( Result )
16import Rel8.Schema.Result ( Result )
20import Rel8.Table.These ( TheseTable )
17import Rel8.Table.These ( TheseTable )
21
18
@@ -28,7 +25,5 @@ import Data.These ( These )
28-- 'Result' context.
25-- 'Result' context.
29type HThese :: K.Context -> Type -> Type -> Type
26type HThese :: K.Context -> Type -> Type -> Type
30type family HThese context = these | these -> context where
27type family HThese context = these | these -> context where
31− HThese Aggregate = TheseTable Aggregate
32− HThese Expr = TheseTable Expr
33− HThese Name = TheseTable Name
34 HThese Result = These
28 HThese Result = These
29+ HThese context = TheseTable context
src/Rel8/Generic/Rel8able.hs+14−1
@@ -6,6 +6,7 @@
6{-# language FlexibleInstances #-}
6{-# language FlexibleInstances #-}
7{-# language LambdaCase #-}
7{-# language LambdaCase #-}
8{-# language MultiParamTypeClasses #-}
8{-# language MultiParamTypeClasses #-}
9+{-# language QuantifiedConstraints #-}
9{-# language ScopedTypeVariables #-}
10{-# language ScopedTypeVariables #-}
10{-# language StandaloneKindSignatures #-}
11{-# language StandaloneKindSignatures #-}
11{-# language TypeApplications #-}
12{-# language TypeApplications #-}
@@ -38,6 +39,7 @@ import Rel8.Generic.Table ( GAlgebra )
38import qualified Rel8.Generic.Table.Record as G
39import qualified Rel8.Generic.Table.Record as G
39import qualified Rel8.Kind.Algebra as K ( Algebra(..) )
40import qualified Rel8.Kind.Algebra as K ( Algebra(..) )
40import Rel8.Kind.Context ( SContext(..) )
41import Rel8.Kind.Context ( SContext(..) )
42+import Rel8.Schema.Field ( Field )
41import Rel8.Schema.HTable ( HTable )
43import Rel8.Schema.HTable ( HTable )
42import qualified Rel8.Schema.Kind as K
44import qualified Rel8.Schema.Kind as K
43import Rel8.Schema.Name ( Name )
45import Rel8.Schema.Name ( Name )
@@ -149,6 +151,7 @@ class HTable (GColumns t) => Rel8able t where
149 default gfromColumns :: forall context.
151 default gfromColumns :: forall context.
150 ( SRel8able t Aggregate
152 ( SRel8able t Aggregate
151 , SRel8able t Expr
153 , SRel8able t Expr
154+ , forall table. SRel8able t (Field table)
152 , SRel8able t Name
155 , SRel8able t Name
153 , SSerialize t
156 , SSerialize t
154 )
157 )
@@ -156,12 +159,14 @@ class HTable (GColumns t) => Rel8able t where
156 gfromColumns = \case
159 gfromColumns = \case
157 SAggregate -> sfromColumns
160 SAggregate -> sfromColumns
158 SExpr -> sfromColumns
161 SExpr -> sfromColumns
162+ SField -> sfromColumns
159 SName -> sfromColumns
163 SName -> sfromColumns
160 SResult -> sfromResult
164 SResult -> sfromResult
161
165
162 default gtoColumns :: forall context.
166 default gtoColumns :: forall context.
163 ( SRel8able t Aggregate
167 ( SRel8able t Aggregate
164 , SRel8able t Expr
168 , SRel8able t Expr
169+ , forall table. SRel8able t (Field table)
165 , SRel8able t Name
170 , SRel8able t Name
166 , SSerialize t
171 , SSerialize t
167 )
172 )
@@ -169,6 +174,7 @@ class HTable (GColumns t) => Rel8able t where
169 gtoColumns = \case
174 gtoColumns = \case
170 SAggregate -> stoColumns
175 SAggregate -> stoColumns
171 SExpr -> stoColumns
176 SExpr -> stoColumns
177+ SField -> stoColumns
172 SName -> stoColumns
178 SName -> stoColumns
173 SResult -> stoResult
179 SResult -> stoResult
174
180
@@ -190,11 +196,18 @@ type GRep t context = Rep (Record (t context))
190
196
191
197
192type SRel8able :: K.Rel8able -> K.Context -> Constraint
198type SRel8able :: K.Rel8able -> K.Context -> Constraint
193−type SRel8able t context =
199+class
194 ( Generic (Record (t context))
200 ( Generic (Record (t context))
195 , G.GTable (TTable context) TColumns (GRep t context)
201 , G.GTable (TTable context) TColumns (GRep t context)
196 , G.GColumns TColumns (GRep t context) ~ GColumns t
202 , G.GColumns TColumns (GRep t context) ~ GColumns t
197 )
203 )
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
198
211
199
212
200type SSerialize :: K.Rel8able -> Constraint
213type SSerialize :: K.Rel8able -> Constraint
src/Rel8/Kind/Context.hs+6
@@ -16,6 +16,7 @@ import Prelude ()
16-- rel8
16-- rel8
17import Rel8.Aggregate ( Aggregate )
17import Rel8.Aggregate ( Aggregate )
18import Rel8.Expr ( Expr )
18import Rel8.Expr ( Expr )
19+import Rel8.Schema.Field ( Field )
19import Rel8.Schema.Kind ( Context )
20import Rel8.Schema.Kind ( Context )
20import Rel8.Schema.Name ( Name )
21import Rel8.Schema.Name ( Name )
21import Rel8.Schema.Result ( Result )
22import Rel8.Schema.Result ( Result )
@@ -25,6 +26,7 @@ type SContext :: Context -> Type
25data SContext context where
26data SContext context where
26 SAggregate :: SContext Aggregate
27 SAggregate :: SContext Aggregate
27 SExpr :: SContext Expr
28 SExpr :: SContext Expr
29+ SField :: SContext (Field table)
28 SName :: SContext Name
30 SName :: SContext Name
29 SResult :: SContext Result
31 SResult :: SContext Result
30
32
@@ -42,6 +44,10 @@ instance Reifiable Expr where
42 contextSing = SExpr
44 contextSing = SExpr
43
45
44
46
47+instance Reifiable (Field table) where
48+ contextSing = SField
49+
50+
45instance Reifiable Result where
51instance Reifiable Result where
46 contextSing = SResult
52 contextSing = SResult
47
53
src/Rel8/Schema/Context/Nullify.hs+29−25
@@ -31,6 +31,7 @@ import Rel8.Expr.Bool ( boolExpr )
31import Rel8.Expr.Null ( nullify, unsafeUnnullify )
31import Rel8.Expr.Null ( nullify, unsafeUnnullify )
32import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
32import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
33import Rel8.Kind.Context ( SContext(..) )
33import Rel8.Kind.Context ( SContext(..) )
34+import Rel8.Schema.Field ( Field )
34import qualified Rel8.Schema.Kind as K
35import qualified Rel8.Schema.Kind as K
35import Rel8.Schema.Name ( Name( Name ) )
36import Rel8.Schema.Name ( Name( Name ) )
36import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )
37import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )
@@ -64,7 +65,8 @@ instance Nullifiable Name where
64
65
65type NonNullifiability :: K.Context -> Type
66type NonNullifiability :: K.Context -> Type
66data NonNullifiability context where
67data NonNullifiability context where
68+ NField :: NonNullifiability (Field table)
67− NNResult :: NonNullifiability Result
69+ NResult :: NonNullifiability Result
68
70
69
71
70nullifiableOrNot :: ()
72nullifiableOrNot :: ()
@@ -73,8 +75,9 @@ nullifiableOrNot :: ()
73nullifiableOrNot = \case
75nullifiableOrNot = \case
74 SAggregate -> Right NAggregate
76 SAggregate -> Right NAggregate
75 SExpr -> Right NExpr
77 SExpr -> Right NExpr
78+ SField -> Left NField
76 SName -> Right NName
79 SName -> Right NName
77− SResult -> Left NNResult
80+ SResult -> Left NResult
78
81
79
82
80absurd :: Nullifiability context -> NonNullifiability context -> a
83absurd :: Nullifiability context -> NonNullifiability context -> a
@@ -91,21 +94,20 @@ guarder :: ()
91 -> (Expr tag -> Expr Bool)
94 -> (Expr tag -> Expr Bool)
92 -> context (Maybe a)
95 -> context (Maybe a)
93 -> context (Maybe a)
96 -> context (Maybe a)
97+guarder = \case
94−guarder SAggregate tag _ isNonNull (Aggregate a) =
98+ SAggregate -> \tag _ isNonNull (Aggregate a) ->
95− mapInputs (toPrimExpr . run . fromPrimExpr) $
99+ let
96− Aggregate $
97− run <$> a
98− where
99− mtag = foldInputs (\_ -> pure . fromPrimExpr) tag
100+ mtag = foldInputs (\_ -> pure . fromPrimExpr) tag
100− run = maybe id (sguard . isNonNull) (getFirst mtag)
101+ run = maybe id (sguard . isNonNull) (getFirst mtag)
102+ in
103+ mapInputs (toPrimExpr . run . fromPrimExpr) $
104+ Aggregate $
105+ run <$> a
101−guarder SExpr tag _ isNonNull a = sguard condition a
106+ SExpr -> \tag _ isNonNull a -> sguard (isNonNull tag) a
102− where
107+ SField -> \_ _ _ field -> field
103− condition = isNonNull tag
104−guarder SName _ _ _ name = name
108+ SName -> \_ _ _ name -> name
105−guarder SResult (Identity tag) isNonNull _ (Identity a) =
109+ SResult -> \(Identity tag) isNonNull _ (Identity a) ->
106− Identity (bool Nothing a condition)
110+ Identity (bool Nothing a (isNonNull tag))
107− where
108− condition = isNonNull tag
109
111
110
112
111nullifier :: ()
113nullifier :: ()
@@ -113,10 +115,11 @@ nullifier :: ()
113 -> Spec a
115 -> Spec a
114 -> context a
116 -> context a
115 -> context (Nullify a)
117 -> context (Nullify a)
118+nullifier = \case
116−nullifier NAggregate Spec {nullity} (Aggregate a) =
119+ NAggregate -> \Spec {nullity} (Aggregate a) ->
117− Aggregate $ snullify nullity <$> a
120+ Aggregate $ snullify nullity <$> a
118−nullifier NExpr Spec {nullity} a = snullify nullity a
121+ NExpr -> \Spec {nullity} a -> snullify nullity a
119−nullifier NName _ (Name a) = Name a
122+ NName -> \_ (Name a) -> Name a
120
123
121
124
122unnullifier :: ()
125unnullifier :: ()
@@ -124,10 +127,11 @@ unnullifier :: ()
124 -> Spec a
127 -> Spec a
125 -> context (Nullify a)
128 -> context (Nullify a)
126 -> context a
129 -> context a
130+unnullifier = \case
127−unnullifier NAggregate Spec {nullity} (Aggregate a) =
131+ NAggregate -> \Spec {nullity} (Aggregate a) ->
128− Aggregate $ sunnullify nullity <$> a
132+ Aggregate $ sunnullify nullity <$> a
129−unnullifier NExpr Spec {nullity} a = sunnullify nullity a
133+ NExpr -> \Spec {nullity} a -> sunnullify nullity a
130−unnullifier NName _ (Name a) = Name a
134+ NName -> \_ (Name a) -> Name a
131
135
132
136
133sguard :: Expr Bool -> Expr (Maybe a) -> Expr (Maybe a)
137sguard :: 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 #-}
6+
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 @@
1{-# language DataKinds #-}
1{-# language DataKinds #-}
2+{-# language RankNTypes #-}
2{-# language RecordWildCards #-}
3{-# language RecordWildCards #-}
3{-# language ScopedTypeVariables #-}
4{-# language ScopedTypeVariables #-}
4{-# language StandaloneKindSignatures #-}
5{-# language StandaloneKindSignatures #-}
@@ -7,6 +8,7 @@
7
8
8module Rel8.Schema.HTable.Label
9module Rel8.Schema.HTable.Label
9 ( HLabel, hlabel, hrelabel, hunlabel
10 ( HLabel, hlabel, hrelabel, hunlabel
11+ , hproject
10 )
12 )
11where
13where
12
14
@@ -18,6 +20,9 @@ import Prelude
18
20
19-- rel8
21-- rel8
20import Rel8.Schema.HTable
22import Rel8.Schema.HTable
23+ ( HTable, HConstrainTable, HField
24+ , htabulate, hfield, htraverse, hdicts, hspecs
25+ )
21import qualified Rel8.Schema.Kind as K
26import qualified Rel8.Schema.Kind as K
22import Rel8.Schema.Spec ( Spec(..) )
27import Rel8.Schema.Spec ( Spec(..) )
23
28
@@ -57,3 +62,9 @@ hrelabel = hlabel . hunlabel
57hunlabel :: forall label t context. HLabel label t context -> t context
62hunlabel :: forall label t context. HLabel label t context -> t context
58hunlabel (HLabel a) = a
63hunlabel (HLabel a) = a
59{-# INLINABLE hunlabel #-}
64{-# 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 @@
6{-# language GADTs #-}
6{-# language GADTs #-}
7{-# language InstanceSigs #-}
7{-# language InstanceSigs #-}
8{-# language MultiParamTypeClasses #-}
8{-# language MultiParamTypeClasses #-}
9+{-# language RankNTypes #-}
9{-# language ScopedTypeVariables #-}
10{-# language ScopedTypeVariables #-}
10{-# language StandaloneKindSignatures #-}
11{-# language StandaloneKindSignatures #-}
11{-# language TypeApplications #-}
12{-# language TypeApplications #-}
@@ -18,6 +19,7 @@ module Rel8.Schema.HTable.MapTable
18 , MapSpec(..)
19 , MapSpec(..)
19 , Precompose(..)
20 , Precompose(..)
20 , HMapTableField(..)
21 , HMapTableField(..)
22+ , hproject
21 )
23 )
22where
24where
23
25
@@ -89,3 +91,9 @@ class MapSpec f where
89type ComposeConstraint :: (Type -> Exp Type) -> (Type -> Constraint) -> Type -> Constraint
91type ComposeConstraint :: (Type -> Exp Type) -> (Type -> Constraint) -> Type -> Constraint
90class c (Eval (f a)) => ComposeConstraint f c a
92class c (Eval (f a)) => ComposeConstraint f c a
91instance c (Eval (f a)) => ComposeConstraint f c a
93instance 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
23 , hnulls
23 , hnulls
24 , hnullify
24 , hnullify
25 , hunnullify
25 , hunnullify
26+ , hproject
26 )
27 )
27where
28where
28
29
@@ -38,6 +39,7 @@ import Rel8.Schema.HTable.MapTable
38 ( HMapTable, HMapTableField( HMapTableField )
39 ( HMapTable, HMapTableField( HMapTableField )
39 , MapSpec, mapInfo
40 , MapSpec, mapInfo
40 )
41 )
42+import qualified Rel8.Schema.HTable.MapTable as HMapTable ( hproject )
41import qualified Rel8.Schema.Kind as K
43import qualified Rel8.Schema.Kind as K
42import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
44import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
43import qualified Rel8.Schema.Null as Type ( Nullify )
45import qualified Rel8.Schema.Null as Type ( Nullify )
@@ -107,3 +109,9 @@ hunnullify unnullifier (HNullify as) =
107 spec@Spec {} -> case hfield as (HMapTableField field) of
109 spec@Spec {} -> case hfield as (HMapTableField field) of
108 a -> unnullifier spec a
110 a -> unnullifier spec a
109{-# INLINABLE hunnullify #-}
111{-# 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
21 ( HVectorize
21 ( HVectorize
22 , hvectorize, hunvectorize
22 , hvectorize, hunvectorize
23 , happend, hempty
23 , happend, hempty
24+ , hproject
24 )
25 )
25where
26where
26
27
27-- base
28-- base
28import Data.Kind ( Type )
29import Data.Kind ( Type )
29import Data.List.NonEmpty ( NonEmpty )
30import Data.List.NonEmpty ( NonEmpty )
31+import GHC.Generics (Generic)
30import Prelude
32import Prelude
31
33
32-- rel8
34-- rel8
35+import Rel8.FCF ( Eval, Exp )
33import Rel8.Schema.Dict ( Dict( Dict ) )
36import Rel8.Schema.Dict ( Dict( Dict ) )
34import qualified Rel8.Schema.Kind as K
37import qualified Rel8.Schema.Kind as K
35import Rel8.Schema.HTable ( HTable, hfield, htabulate, htabulateA, hspecs )
38import 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 )
36import Rel8.Schema.Null ( Unnullify, NotNull, Nullity( NotNull ) )
44import Rel8.Schema.Null ( Unnullify, NotNull, Nullity( NotNull ) )
37import Rel8.Schema.Spec ( Spec(..) )
45import Rel8.Schema.Spec ( Spec(..) )
38import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )
46import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )
@@ -40,9 +48,6 @@ import Rel8.Type.Information ( TypeInformation )
40
48
41-- semialign
49-- semialign
42import Data.Zip ( Unzip, Zip, Zippy(..) )
50import Data.Zip ( Unzip, Zip, Zippy(..) )
43−import Rel8.FCF
44−import Rel8.Schema.HTable.MapTable
45−import GHC.Generics (Generic)
46
51
47
52
48class Vector list where
53class Vector list where
@@ -122,3 +127,9 @@ hempty :: HTable t
122 -> HVectorize [] t context
127 -> HVectorize [] t context
123hempty empty = HVectorize $ htabulate $ \(HMapTableField field) ->
128hempty empty = HVectorize $ htabulate $ \(HMapTableField field) ->
124 empty (hfield hspecs field)
129 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 )
54import Rel8.Table.Eq ( EqTable, eqTable )
54import Rel8.Table.Eq ( EqTable, eqTable )
55import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )
55import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )
56import Rel8.Table.Ord ( OrdTable, ordTable )
56import Rel8.Table.Ord ( OrdTable, ordTable )
57+import Rel8.Table.Projection ( Biprojectable, Projectable, biproject, project )
57import Rel8.Table.Serialize ( ToExprs )
58import Rel8.Table.Serialize ( ToExprs )
58import Rel8.Table.Undefined ( undefined )
59import Rel8.Table.Undefined ( undefined )
59import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )
60import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )
@@ -78,10 +79,19 @@ data EitherTable context a b = EitherTable
78 deriving stock Functor
79 deriving stock Functor
79
80
80
81
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+
81instance Nullifiable context => Bifunctor (EitherTable context) where
87instance Nullifiable context => Bifunctor (EitherTable context) where
82 bimap f g (EitherTable tag a b) = EitherTable tag (fmap f a) (fmap g b)
88 bimap f g (EitherTable tag a b) = EitherTable tag (fmap f a) (fmap g b)
83
89
84
90
91+instance Projectable (EitherTable context a) where
92+ project f (EitherTable tag a b) = EitherTable tag a (project f b)
93+
94+
85instance (context ~ Expr, Table Expr a) => Apply (EitherTable context a) where
95instance (context ~ Expr, Table Expr a) => Apply (EitherTable context a) where
86 EitherTable tag l1 f <.> EitherTable tag' l2 a =
96 EitherTable tag l1 f <.> EitherTable tag' l2 a =
87 EitherTable (tag <> tag') (bool l1 l2 (isLeft tag)) (f <.> a)
97 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 )
25import Rel8.Expr.Array ( sappend, sempty, slistOf )
25import Rel8.Expr.Array ( sappend, sempty, slistOf )
26import Rel8.Schema.Dict ( Dict( Dict ) )
26import Rel8.Schema.Dict ( Dict( Dict ) )
27import Rel8.Schema.HTable.List ( HListTable )
27import 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+ )
29import qualified Rel8.Schema.Kind as K
33import qualified Rel8.Schema.Kind as K
30import Rel8.Schema.Name ( Name( Name ) )
34import Rel8.Schema.Name ( Name( Name ) )
31import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
35import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
@@ -42,6 +46,7 @@ import Rel8.Table.Alternative
42 )
46 )
43import Rel8.Table.Eq ( EqTable, eqTable )
47import Rel8.Table.Eq ( EqTable, eqTable )
44import Rel8.Table.Ord ( OrdTable, ordTable )
48import Rel8.Table.Ord ( OrdTable, ordTable )
49+import Rel8.Table.Projection ( Projectable, project, apply )
45import Rel8.Table.Serialize ( ToExprs )
50import Rel8.Table.Serialize ( ToExprs )
46
51
47
52
@@ -52,6 +57,10 @@ newtype ListTable context a =
52 ListTable (HListTable (Columns a) (Context a))
57 ListTable (HListTable (Columns a) (Context a))
53
58
54
59
60+instance Projectable (ListTable context) where
61+ project f (ListTable a) = ListTable (hproject (apply f) a)
62+
63+
55instance (Table context a, context ~ context') =>
64instance (Table context a, context ~ context') =>
56 Table context' (ListTable context a)
65 Table context' (ListTable context a)
57 where
66 where
src/Rel8/Table/Maybe.hs+5
@@ -58,6 +58,7 @@ import Rel8.Table.Alternative
58import Rel8.Table.Bool ( bool )
58import Rel8.Table.Bool ( bool )
59import Rel8.Table.Eq ( EqTable, eqTable )
59import Rel8.Table.Eq ( EqTable, eqTable )
60import Rel8.Table.Ord ( OrdTable, ordTable )
60import Rel8.Table.Ord ( OrdTable, ordTable )
61+import Rel8.Table.Projection ( Projectable, project )
61import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )
62import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )
62import Rel8.Table.Serialize ( ToExprs )
63import Rel8.Table.Serialize ( ToExprs )
63import Rel8.Table.Undefined ( undefined )
64import Rel8.Table.Undefined ( undefined )
@@ -85,6 +86,10 @@ data MaybeTable context a = MaybeTable
85 deriving stock Functor
86 deriving stock Functor
86
87
87
88
89+instance Projectable (MaybeTable context) where
90+ project f (MaybeTable tag a) = MaybeTable tag (project f a)
91+
92+
88instance context ~ Expr => Apply (MaybeTable context) where
93instance context ~ Expr => Apply (MaybeTable context) where
89 MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f <.> a)
94 MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f <.> a)
90
95
src/Rel8/Table/NonEmpty.hs+10−1
@@ -26,7 +26,11 @@ import Rel8.Expr ( Expr )
26import Rel8.Expr.Array ( sappend1, snonEmptyOf )
26import Rel8.Expr.Array ( sappend1, snonEmptyOf )
27import Rel8.Schema.Dict ( Dict( Dict ) )
27import Rel8.Schema.Dict ( Dict( Dict ) )
28import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
28import 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+ )
30import qualified Rel8.Schema.Kind as K
34import qualified Rel8.Schema.Kind as K
31import Rel8.Schema.Name ( Name( Name ) )
35import Rel8.Schema.Name ( Name( Name ) )
32import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
36import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
@@ -40,6 +44,7 @@ import Rel8.Table
40import Rel8.Table.Alternative ( AltTable, (<|>:) )
44import Rel8.Table.Alternative ( AltTable, (<|>:) )
41import Rel8.Table.Eq ( EqTable, eqTable )
45import Rel8.Table.Eq ( EqTable, eqTable )
42import Rel8.Table.Ord ( OrdTable, ordTable )
46import Rel8.Table.Ord ( OrdTable, ordTable )
47+import Rel8.Table.Projection ( Projectable, project, apply )
43import Rel8.Table.Serialize ( ToExprs )
48import Rel8.Table.Serialize ( ToExprs )
44
49
45
50
@@ -50,6 +55,10 @@ newtype NonEmptyTable context a =
50 NonEmptyTable (HNonEmptyTable (Columns a) (Context a))
55 NonEmptyTable (HNonEmptyTable (Columns a) (Context a))
51
56
52
57
58+instance Projectable (NonEmptyTable context) where
59+ project f (NonEmptyTable a) = NonEmptyTable (hproject (apply f) a)
60+
61+
53instance (Table context a, context ~ context') =>
62instance (Table context a, context ~ context') =>
54 Table context' (NonEmptyTable context a)
63 Table context' (NonEmptyTable context a)
55 where
64 where
src/Rel8/Table/Nullify.hs+12−1
@@ -39,7 +39,11 @@ import Rel8.Schema.Context.Nullify
39 )
39 )
40import Rel8.Schema.Dict ( Dict( Dict ) )
40import Rel8.Schema.Dict ( Dict( Dict ) )
41import Rel8.Schema.HTable ( HTable )
41import Rel8.Schema.HTable ( HTable )
42+import Rel8.Schema.HTable.Nullify
42−import Rel8.Schema.HTable.Nullify ( HNullify, hnulls, hnullify, hunnullify, hguard )
43+ ( HNullify, hnulls, hnullify, hunnullify
44+ , hguard
45+ , hproject
46+ )
43import qualified Rel8.Schema.Kind as K
47import qualified Rel8.Schema.Kind as K
44import qualified Rel8.Schema.Result as R
48import qualified Rel8.Schema.Result as R
45import Rel8.Table
49import Rel8.Table
@@ -49,6 +53,7 @@ import Rel8.Table
49 )
53 )
50import Rel8.Table.Eq ( EqTable, eqTable )
54import Rel8.Table.Eq ( EqTable, eqTable )
51import Rel8.Table.Ord ( OrdTable, ordTable )
55import Rel8.Table.Ord ( OrdTable, ordTable )
56+import Rel8.Table.Projection ( Projectable, apply, project )
52
57
53-- semigroupoids
58-- semigroupoids
54import Data.Functor.Apply ( Apply, (<.>), liftF2 )
59import Data.Functor.Apply ( Apply, (<.>), liftF2 )
@@ -62,6 +67,12 @@ data Nullify context a
62 | Fields (NonNullifiability context) (HNullify (Columns a) (Context a))
67 | Fields (NonNullifiability context) (HNullify (Columns a) (Context a))
63
68
64
69
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+
65instance Nullifiable context => Functor (Nullify context) where
76instance Nullifiable context => Functor (Nullify context) where
66 fmap f = \case
77 fmap f = \case
67 Table nullifiable a -> Table nullifiable (f a)
78 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 #-}
7+
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
60 )
60 )
61import Rel8.Table.Nullify ( Nullify, guard )
61import Rel8.Table.Nullify ( Nullify, guard )
62import Rel8.Table.Ord ( OrdTable, ordTable )
62import Rel8.Table.Ord ( OrdTable, ordTable )
63+import Rel8.Table.Projection ( Biprojectable, Projectable, biproject, project )
63import Rel8.Table.Serialize ( ToExprs )
64import Rel8.Table.Serialize ( ToExprs )
64import Rel8.Table.Undefined ( undefined )
65import Rel8.Table.Undefined ( undefined )
65import Rel8.Type.Tag ( MaybeTag )
66import Rel8.Type.Tag ( MaybeTag )
@@ -88,10 +89,18 @@ data TheseTable context a b = TheseTable
88 deriving stock Functor
89 deriving stock Functor
89
90
90
91
92+instance Biprojectable (TheseTable context) where
93+ biproject f g (TheseTable a b) = TheseTable (project f a) (project g b)
94+
95+
91instance Nullifiable context => Bifunctor (TheseTable context) where
96instance Nullifiable context => Bifunctor (TheseTable context) where
92 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)
97 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)
93
98
94
99
100+instance Projectable (TheseTable context a) where
101+ project f (TheseTable a b) = TheseTable a (project f b)
102+
103+
95instance (context ~ Expr, Table Expr a, Semigroup a) =>
104instance (context ~ Expr, Table Expr a, Semigroup a) =>
96 Apply (TheseTable context a)
105 Apply (TheseTable context a)
97 where
106 where