git.iko.soy/rel8
on master help sign in
Introduce Rel8.Table.Nullify (#104)
be54907Shane
rel8.cabal+2
compare with master
unifiedsplit
@@ -23,6 +23,7 @@ library
23 , base ^>= 4.14 || ^>=4.15
23 , base ^>= 4.14 || ^>=4.15
24 , bytestring
24 , bytestring
25 , case-insensitive
25 , case-insensitive
26+ , comonad
26 , contravariant
27 , contravariant
27 , hasql ^>= 1.4.5.1
28 , hasql ^>= 1.4.5.1
28 , opaleye ^>= 0.7.3.0
29 , opaleye ^>= 0.7.3.0
@@ -158,6 +159,7 @@ library
158 Rel8.Table.Maybe
159 Rel8.Table.Maybe
159 Rel8.Table.Name
160 Rel8.Table.Name
160 Rel8.Table.NonEmpty
161 Rel8.Table.NonEmpty
162+ Rel8.Table.Nullify
161 Rel8.Table.Opaleye
163 Rel8.Table.Opaleye
162 Rel8.Table.Ord
164 Rel8.Table.Ord
163 Rel8.Table.Order
165 Rel8.Table.Order
src/Rel8/Generic/Construction.hs+2−3
@@ -3,7 +3,6 @@
3{-# language DataKinds #-}
3{-# language DataKinds #-}
4{-# language FlexibleContexts #-}
4{-# language FlexibleContexts #-}
5{-# language FlexibleInstances #-}
5{-# language FlexibleInstances #-}
6−{-# language LambdaCase #-}
7{-# language MultiParamTypeClasses #-}
6{-# language MultiParamTypeClasses #-}
8{-# language NamedFieldPuns #-}
7{-# language NamedFieldPuns #-}
9{-# language ScopedTypeVariables #-}
8{-# language ScopedTypeVariables #-}
@@ -59,7 +58,7 @@ import Rel8.Kind.Algebra
59 , KnownAlgebra, algebraSing
58 , KnownAlgebra, algebraSing
60 )
59 )
61import qualified Rel8.Kind.Algebra as K
60import qualified Rel8.Kind.Algebra as K
62−import Rel8.Schema.Context.Nullify ( guardExpr, snullify )
61+import Rel8.Schema.Context.Nullify ( sguard, snullify )
63import Rel8.Schema.HTable ( HTable )
62import Rel8.Schema.HTable ( HTable )
64import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )
63import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )
65import qualified Rel8.Schema.Kind as K
64import qualified Rel8.Schema.Kind as K
@@ -349,7 +348,7 @@ ggaggregate gfromColumns gtoColumns agg es = case algebraSing @algebra of
349 @(Eval (rep (Reify Aggregate)))
348 @(Eval (rep (Reify Aggregate)))
350 (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)
349 (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)
351 (\tag' SSpec {nullity} (Reify (A (Aggregate a))) ->
350 (\tag' SSpec {nullity} (Reify (A (Aggregate a))) ->
352− Reify $ A $ Aggregate $ guardExpr (tag ==. litExpr tag') . snullify nullity <$> a)
351+ Reify $ A $ Aggregate $ sguard (tag ==. litExpr tag') . snullify nullity <$> a)
353 (HType (Reify (A (groupByExpr tag))))
352 (HType (Reify (A (groupByExpr tag))))
354 where
353 where
355 f =
354 f =
src/Rel8/Query/Either.hs+5−2
@@ -10,6 +10,9 @@ where
10-- base
10-- base
11import Prelude
11import Prelude
12
12
13+-- comonad
14+import Control.Comonad ( extract )
15+
13-- rel8
16-- rel8
14import Rel8.Expr ( Expr )
17import Rel8.Expr ( Expr )
15import Rel8.Expr.Eq ( (==.) )
18import Rel8.Expr.Eq ( (==.) )
@@ -27,14 +30,14 @@ import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
27keepLeftTable :: EitherTable Expr a b -> Query a
30keepLeftTable :: EitherTable Expr a b -> Query a
28keepLeftTable e@(EitherTable _ a _) = do
31keepLeftTable e@(EitherTable _ a _) = do
29 where_ $ isLeftTable e
32 where_ $ isLeftTable e
30− pure a
33+ pure (extract a)
31
34
32
35
33-- | Filter 'EitherTable's, keeping only 'rightTable's.
36-- | Filter 'EitherTable's, keeping only 'rightTable's.
34keepRightTable :: EitherTable Expr a b -> Query b
37keepRightTable :: EitherTable Expr a b -> Query b
35keepRightTable e@(EitherTable _ _ b) = do
38keepRightTable e@(EitherTable _ _ b) = do
36 where_ $ isRightTable e
39 where_ $ isRightTable e
37− pure b
40+ pure (extract b)
38
41
39
42
40-- | @bitraverseEitherTable f g x@ will pass all @leftTable@s through @f@ and
43-- | @bitraverseEitherTable f g x@ will pass all @leftTable@s through @f@ and
src/Rel8/Query/Maybe.hs+10−6
@@ -1,4 +1,5 @@
1{-# language GADTs #-}
1{-# language GADTs #-}
2+{-# language NamedFieldPuns #-}
2
3
3module Rel8.Query.Maybe
4module Rel8.Query.Maybe
4 ( optional
5 ( optional
@@ -10,6 +11,9 @@ where
10-- base
11-- base
11import Prelude
12import Prelude
12
13
14+-- comonad
15+import Control.Comonad ( extract )
16+
13-- opaleye
17-- opaleye
14import qualified Opaleye.Internal.MaybeFields as Opaleye
18import qualified Opaleye.Internal.MaybeFields as Opaleye
15
19
@@ -20,7 +24,7 @@ import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr )
20import Rel8.Query ( Query )
24import Rel8.Query ( Query )
21import Rel8.Query.Filter ( where_ )
25import Rel8.Query.Filter ( where_ )
22import Rel8.Query.Opaleye ( mapOpaleye )
26import Rel8.Query.Opaleye ( mapOpaleye )
23−import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
27+import Rel8.Table.Maybe ( MaybeTable(..), isJustTable )
24
28
25
29
26-- | Convert a query that might return zero rows to a query that always returns
30-- | Convert a query that might return zero rows to a query that always returns
@@ -29,10 +33,10 @@ import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
29-- To speak in more concrete terms, 'optional' is most useful to write @LEFT
33-- To speak in more concrete terms, 'optional' is most useful to write @LEFT
30-- JOIN@s.
34-- JOIN@s.
31optional :: Query a -> Query (MaybeTable Expr a)
35optional :: Query a -> Query (MaybeTable Expr a)
32−optional =
33− mapOpaleye $
34− Opaleye.optionalInternal $
36+optional = mapOpaleye $ Opaleye.optionalInternal $ \tag a -> MaybeTable
35− MaybeTable . E . fromPrimExpr . fromColumn
37+ { tag = E $ fromPrimExpr $ fromColumn tag
38+ , just = pure a
39+ }
36
40
37
41
38-- | Filter out 'MaybeTable's, returning only the tables that are not-null.
42-- | Filter out 'MaybeTable's, returning only the tables that are not-null.
@@ -43,7 +47,7 @@ optional =
43catMaybeTable :: MaybeTable Expr a -> Query a
47catMaybeTable :: MaybeTable Expr a -> Query a
44catMaybeTable ma@(MaybeTable _ a) = do
48catMaybeTable ma@(MaybeTable _ a) = do
45 where_ $ isJustTable ma
49 where_ $ isJustTable ma
46− pure a
50+ pure (extract a)
47
51
48
52
49-- | Extend an optional query with another query. This is useful if you want
53-- | Extend an optional query with another query. This is useful if you want
src/Rel8/Query/These.hs+9−6
@@ -15,6 +15,9 @@ where
15-- base
15-- base
16import Prelude
16import Prelude
17
17
18+-- comonad
19+import Control.Comonad ( extract )
20+
18-- opaleye
21-- opaleye
19import qualified Opaleye.Internal.PackMap as Opaleye
22import qualified Opaleye.Internal.PackMap as Opaleye
20import qualified Opaleye.Internal.PrimQuery as Opaleye
23import qualified Opaleye.Internal.PrimQuery as Opaleye
@@ -59,7 +62,7 @@ alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.QueryArr $ \i -> cas
59 tag''' = Opaleye.next tag''
62 tag''' = Opaleye.next tag''
60 join lateral = Opaleye.Join Opaleye.FullJoin on left'' right''
63 join lateral = Opaleye.Join Opaleye.FullJoin on left'' right''
61 where
64 where
62− on = toPrimExpr $ condition a b
65+ on = toPrimExpr $ condition (extract a) (extract b)
63 left'' = (lateral, Opaleye.Rebind True lbindings left')
66 left'' = (lateral, Opaleye.Rebind True lbindings left')
64 right'' = (lateral, Opaleye.Rebind True rbindings right')
67 right'' = (lateral, Opaleye.Rebind True rbindings right')
65 ma' = MaybeTable (E hasHere') a
68 ma' = MaybeTable (E hasHere') a
@@ -87,31 +90,31 @@ loseThereTable = keepThisTable
87keepThisTable :: TheseTable Expr a b -> Query a
90keepThisTable :: TheseTable Expr a b -> Query a
88keepThisTable t@(TheseTable (MaybeTable _ a) _) = do
91keepThisTable t@(TheseTable (MaybeTable _ a) _) = do
89 where_ $ isThisTable t
92 where_ $ isThisTable t
90− pure a
93+ pure (extract a)
91
94
92
95
93loseThisTable :: TheseTable Expr a b -> Query (MaybeTable Expr a, b)
96loseThisTable :: TheseTable Expr a b -> Query (MaybeTable Expr a, b)
94loseThisTable t@(TheseTable ma (MaybeTable _ b)) = do
97loseThisTable t@(TheseTable ma (MaybeTable _ b)) = do
95 where_ $ not_ $ isThisTable t
98 where_ $ not_ $ isThisTable t
96− pure (ma, b)
99+ pure (ma, extract b)
97
100
98
101
99keepThatTable :: TheseTable Expr a b -> Query b
102keepThatTable :: TheseTable Expr a b -> Query b
100keepThatTable t@(TheseTable _ (MaybeTable _ b)) = do
103keepThatTable t@(TheseTable _ (MaybeTable _ b)) = do
101 where_ $ isThatTable t
104 where_ $ isThatTable t
102− pure b
105+ pure (extract b)
103
106
104
107
105loseThatTable :: TheseTable Expr a b -> Query (a, MaybeTable Expr b)
108loseThatTable :: TheseTable Expr a b -> Query (a, MaybeTable Expr b)
106loseThatTable t@(TheseTable (MaybeTable _ a) mb) = do
109loseThatTable t@(TheseTable (MaybeTable _ a) mb) = do
107 where_ $ not_ $ isThatTable t
110 where_ $ not_ $ isThatTable t
108− pure (a, mb)
111+ pure (extract a, mb)
109
112
110
113
111keepThoseTable :: TheseTable Expr a b -> Query (a, b)
114keepThoseTable :: TheseTable Expr a b -> Query (a, b)
112keepThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
115keepThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
113 where_ $ isThoseTable t
116 where_ $ isThoseTable t
114− pure (a, b)
117+ pure (extract a, extract b)
115
118
116
119
117loseThoseTable :: TheseTable Expr a b -> Query (EitherTable Expr a b)
120loseThoseTable :: TheseTable Expr a b -> Query (EitherTable Expr a b)
src/Rel8/Schema/Context/Nullify.hs+109−47
@@ -1,17 +1,23 @@
1{-# language DataKinds #-}
1{-# language DataKinds #-}
2+{-# language EmptyCase #-}
2{-# language FlexibleContexts #-}
3{-# language FlexibleContexts #-}
3{-# language GADTs #-}
4{-# language GADTs #-}
5+{-# language LambdaCase #-}
4{-# language NamedFieldPuns #-}
6{-# language NamedFieldPuns #-}
5{-# language StandaloneKindSignatures #-}
7{-# language StandaloneKindSignatures #-}
6
8
7module Rel8.Schema.Context.Nullify
9module Rel8.Schema.Context.Nullify
10+ ( Nullifiability(..), NonNullifiability(..), nullifiableOrNot, absurd
11+ , Nullifiable, nullifiability
8− ( Nullifiable, nullifier, unnullifier
12+ , guarder, nullifier, unnullifier
9− , guardExpr, snullify
13+ , sguard, snullify
10 )
14 )
11where
15where
12
16
13-- base
17-- base
18+import Data.Bifunctor ( bimap )
19+import Data.Bool ( bool )
14−import Data.Kind ( Constraint )
20+import Data.Kind ( Constraint, Type )
15import Data.Monoid ( getFirst )
21import Data.Monoid ( getFirst )
16import Prelude hiding ( null )
22import Prelude hiding ( null )
17
23
@@ -20,73 +26,129 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
20
26
21-- rel8
27-- rel8
22import Rel8.Aggregate
28import Rel8.Aggregate
23− ( Aggregate( Aggregate ), Col( A )
29+ ( Col( A ), Aggregate( Aggregate )
24 , foldInputs, mapInputs
30 , foldInputs, mapInputs
25 )
31 )
26−import Rel8.Expr ( Expr, Col( E ) )
32+import Rel8.Expr ( Col( E ), Expr )
27import Rel8.Expr.Bool ( boolExpr )
33import Rel8.Expr.Bool ( boolExpr )
28import Rel8.Expr.Null ( nullify, unsafeUnnullify )
34import Rel8.Expr.Null ( nullify, unsafeUnnullify )
29import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
35import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
36+import Rel8.Kind.Context ( SContext(..) )
30import qualified Rel8.Schema.Kind as K
37import qualified Rel8.Schema.Kind as K
31−import Rel8.Schema.Name ( Name( Name ), Col( N ) )
38+import Rel8.Schema.Name ( Col( N ), Name( Name ) )
32−import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql )
39+import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )
33−import Rel8.Schema.Reify ( Reify, Col( Reify ) )
40+import Rel8.Schema.Reify ( Col( Reify ), Reify )
41+import Rel8.Schema.Result ( Col( R ), Result )
34import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
42import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
35−import Rel8.Type ( DBType )
43+
44+
45+type Nullifiability :: K.Context -> Type
46+data Nullifiability context where
47+ NAggregate :: Nullifiability Aggregate
48+ NExpr :: Nullifiability Expr
49+ NName :: Nullifiability Name
50+ NReify :: Nullifiability context -> Nullifiability (Reify context)
36
51
37
52
38type Nullifiable :: K.Context -> Constraint
53type Nullifiable :: K.Context -> Constraint
39class Nullifiable context where
54class Nullifiable context where
40− nullifier :: Sql DBType tag
55+ nullifiability :: Nullifiability context
41− => Col context ('Spec tag)
42− -> (Expr tag -> Expr Bool)
43− -> SSpec ('Spec a)
44− -> Col context ('Spec a)
45− -> Col context ('Spec (Nullify a))
46−
47− unnullifier :: ()
48− => SSpec ('Spec a)
49− -> Col context ('Spec (Nullify a))
50− -> Col context ('Spec a)
51
56
52
57
53instance Nullifiable Aggregate where
58instance Nullifiable Aggregate where
54− nullifier (A tag) isNonNull SSpec {nullity} (A (Aggregate a)) =
59+ nullifiability = NAggregate
55− A $
56− mapInputs (toPrimExpr . run . fromPrimExpr) $
57− Aggregate $
58− run <$> a
59− where
60− mtag = foldInputs (\_ -> pure . fromPrimExpr) tag
61− run = maybe id (guardExpr . isNonNull) (getFirst mtag) . snullify nullity
62−
63− unnullifier SSpec {nullity} (A (Aggregate a)) =
64− A $ Aggregate $ sunnullify nullity <$> a
65
60
66
61
67instance Nullifiable Expr where
62instance Nullifiable Expr where
68− nullifier (E tag) isNonNull SSpec {nullity} (E a) =
63+ nullifiability = NExpr
69− E $ guardExpr condition (snullify nullity a)
70− where
71− condition = isNonNull tag
72−
73− unnullifier SSpec {nullity} (E a) = E $ sunnullify nullity a
74
64
75
65
76instance Nullifiable Name where
66instance Nullifiable Name where
77− nullifier _ _ _ (N (Name a)) = N $ Name a
67+ nullifiability = NName
78− unnullifier _ (N (Name a)) = N $ Name a
79
68
80
69
81instance Nullifiable context => Nullifiable (Reify context) where
70instance Nullifiable context => Nullifiable (Reify context) where
82− nullifier (Reify tag) isNonNull spec (Reify a) =
71+ nullifiability = NReify nullifiability
83− Reify $ nullifier tag isNonNull spec a
72+
84−
73+
74+type NonNullifiability :: K.Context -> Type
75+data NonNullifiability context where
76+ NNResult :: NonNullifiability Result
77+ NNReify :: NonNullifiability context -> NonNullifiability (Reify context)
78+
79+
80+nullifiableOrNot :: ()
81+ => SContext context
82+ -> Either (NonNullifiability context) (Nullifiability context)
83+nullifiableOrNot = \case
84+ SAggregate -> Right NAggregate
85+ SExpr -> Right NExpr
86+ SName -> Right NName
87+ SResult -> Left NNResult
88+ SReify context -> bimap NNReify NReify $ nullifiableOrNot context
89+
90+
91+absurd :: Nullifiability context -> NonNullifiability context -> a
92+absurd = \case
93+ NAggregate -> \case
94+ NExpr -> \case
95+ NName -> \case
96+ NReify context -> \case
97+ NNReify context' -> absurd context context'
98+
99+
100+guarder :: ()
101+ => SContext context
102+ -> Col context ('Spec tag)
103+ -> (tag -> Bool)
104+ -> (Expr tag -> Expr Bool)
105+ -> Col context ('Spec (Maybe a))
106+ -> Col context ('Spec (Maybe a))
107+guarder SAggregate (A tag) _ isNonNull (A (Aggregate a)) =
108+ A $
109+ mapInputs (toPrimExpr . run . fromPrimExpr) $
110+ Aggregate $
111+ run <$> a
112+ where
113+ mtag = foldInputs (\_ -> pure . fromPrimExpr) tag
114+ run = maybe id (sguard . isNonNull) (getFirst mtag)
115+guarder SExpr (E tag) _ isNonNull (E a) = E $ sguard condition a
116+ where
117+ condition = isNonNull tag
118+guarder SName _ _ _ name = name
119+guarder SResult (R tag) isNonNull _ (R a) = R (bool Nothing a condition)
120+ where
121+ condition = isNonNull tag
122+guarder (SReify context) (Reify tag) isNonNull isNonNullExpr (Reify a) =
123+ Reify $ guarder context tag isNonNull isNonNullExpr a
124+
125+
126+nullifier :: ()
127+ => Nullifiability context
128+ -> SSpec ('Spec a)
129+ -> Col context ('Spec a)
130+ -> Col context ('Spec (Nullify a))
131+nullifier NAggregate SSpec {nullity} (A (Aggregate a)) =
132+ A $ Aggregate $ snullify nullity <$> a
133+nullifier NExpr SSpec {nullity} (E a) = E $ snullify nullity a
134+nullifier NName _ (N (Name a)) = N $ Name a
135+nullifier (NReify context) spec (Reify a) = Reify $ nullifier context spec a
136+
137+
138+unnullifier :: ()
139+ => Nullifiability context
140+ -> SSpec ('Spec a)
141+ -> Col context ('Spec (Nullify a))
142+ -> Col context ('Spec a)
143+unnullifier NAggregate SSpec {nullity} (A (Aggregate a)) =
144+ A $ Aggregate $ sunnullify nullity <$> a
145+unnullifier NExpr SSpec {nullity} (E a) = E $ sunnullify nullity a
146+unnullifier NName _ (N (Name a)) = N $ Name a
85− unnullifier spec (Reify a) = Reify (unnullifier spec a)
147+unnullifier (NReify context) spec (Reify a) = Reify (unnullifier context spec a)
86−
148+
87−
149+
88−guardExpr :: Expr Bool -> Expr (Maybe a) -> Expr (Maybe a)
150+sguard :: Expr Bool -> Expr (Maybe a) -> Expr (Maybe a)
89−guardExpr condition a = boolExpr null a condition
151+sguard condition a = boolExpr null a condition
90 where
152 where
91 null = fromPrimExpr $ Opaleye.ConstExpr Opaleye.NullLit
153 null = fromPrimExpr $ Opaleye.ConstExpr Opaleye.NullLit
92
154
src/Rel8/Schema/HTable/Nullify.hs+26−8
@@ -8,6 +8,7 @@
8{-# language LambdaCase #-}
8{-# language LambdaCase #-}
9{-# language MultiParamTypeClasses #-}
9{-# language MultiParamTypeClasses #-}
10{-# language NamedFieldPuns #-}
10{-# language NamedFieldPuns #-}
11+{-# language QuantifiedConstraints #-}
11{-# language RankNTypes #-}
12{-# language RankNTypes #-}
12{-# language RecordWildCards #-}
13{-# language RecordWildCards #-}
13{-# language ScopedTypeVariables #-}
14{-# language ScopedTypeVariables #-}
@@ -18,15 +19,24 @@
18module Rel8.Schema.HTable.Nullify
19module Rel8.Schema.HTable.Nullify
19 ( HNullify( HNullify )
20 ( HNullify( HNullify )
20 , Nullify
21 , Nullify
22+ , hguard
23+ , hnulls
24+ , hnullify
21− , hnulls, hnullify, hunnullify
25+ , hunnullify
22 )
26 )
23where
27where
24
28
25-- base
29-- base
30+import GHC.Generics ( Generic )
26import Prelude hiding ( null )
31import Prelude hiding ( null )
27
32
28-- rel8
33-- rel8
34+import Rel8.FCF ( Eval, Exp )
29import Rel8.Schema.HTable ( HTable, hfield, htabulate, htabulateA, hspecs )
35import Rel8.Schema.HTable ( HTable, hfield, htabulate, htabulateA, hspecs )
36+import Rel8.Schema.HTable.MapTable
37+ ( HMapTable, HMapTableField( HMapTableField )
38+ , MapSpec, mapInfo
39+ )
30import qualified Rel8.Schema.Kind as K
40import qualified Rel8.Schema.Kind as K
31import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
41import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
32import qualified Rel8.Schema.Null as Type ( Nullify )
42import qualified Rel8.Schema.Null as Type ( Nullify )
@@ -34,9 +44,6 @@ import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
34
44
35-- semigroupoids
45-- semigroupoids
36import Data.Functor.Apply ( Apply )
46import Data.Functor.Apply ( Apply )
37−import Rel8.Schema.HTable.MapTable
38−import Rel8.FCF
39−import GHC.Generics (Generic)
40
47
41
48
42type HNullify :: K.HTable -> K.HTable
49type HNullify :: K.HTable -> K.HTable
@@ -45,7 +52,6 @@ newtype HNullify table context = HNullify (HMapTable Nullify table context)
45 deriving anyclass HTable
52 deriving anyclass HTable
46
53
47
54
48−
49-- | Transform a 'Spec' by allowing it to be @null@.
55-- | Transform a 'Spec' by allowing it to be @null@.
50data Nullify :: Spec -> Exp Spec
56data Nullify :: Spec -> Exp Spec
51
57
@@ -61,7 +67,18 @@ instance MapSpec Nullify where
61 Null -> Null
67 Null -> Null
62 NotNull -> Null
68 NotNull -> Null
63 , ..
69 , ..
64− }
70+ }
71+
72+
73+hguard :: HTable t
74+ => (forall a. context ('Spec (Maybe a)) -> context ('Spec (Maybe a)))
75+ -> HNullify t context -> HNullify t context
76+hguard guarder (HNullify as) = HNullify $ htabulate $ \(HMapTableField field) ->
77+ case hfield hspecs field of
78+ SSpec {nullity} -> case hfield as (HMapTableField field) of
79+ a -> case nullity of
80+ Null -> guarder a
81+ NotNull -> guarder a
65
82
66
83
67hnulls :: HTable t
84hnulls :: HTable t
@@ -69,8 +86,9 @@ hnulls :: HTable t
69 => SSpec ('Spec a)
86 => SSpec ('Spec a)
70 -> context ('Spec (Type.Nullify a)))
87 -> context ('Spec (Type.Nullify a)))
71 -> HNullify t context
88 -> HNullify t context
72−hnulls null = HNullify $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of
89+hnulls null = HNullify $ htabulate $ \(HMapTableField field) ->
90+ case hfield hspecs field of
73− spec@SSpec {} -> null spec
91+ spec@SSpec {} -> null spec
74{-# INLINABLE hnulls #-}
92{-# INLINABLE hnulls #-}
75
93
76
94
src/Rel8/Table/Either.hs+46−41
@@ -23,25 +23,27 @@ module Rel8.Table.Either
23where
23where
24
24
25-- base
25-- base
26−import Control.Applicative ( liftA2 )
27import Control.Category ( id )
26import Control.Category ( id )
28import Data.Bifunctor ( Bifunctor, bimap )
27import Data.Bifunctor ( Bifunctor, bimap )
29−import Data.Functor.Identity ( runIdentity )
30import Data.Kind ( Type )
28import Data.Kind ( Type )
31import Data.Type.Equality ( apply )
29import Data.Type.Equality ( apply )
32import Prelude hiding ( id, undefined )
30import Prelude hiding ( id, undefined )
33
31
32+-- comonad
33+import Control.Comonad ( extract )
34+
34-- rel8
35-- rel8
35import Rel8.Aggregate ( Col( A ), Aggregate )
36import Rel8.Aggregate ( Col( A ), Aggregate )
36import Rel8.Expr ( Col( E ), Expr )
37import Rel8.Expr ( Col( E ), Expr )
37import Rel8.Expr.Aggregate ( groupByExpr )
38import Rel8.Expr.Aggregate ( groupByExpr )
38import Rel8.Expr.Serialize ( litExpr )
39import Rel8.Expr.Serialize ( litExpr )
40+import Rel8.Kind.Context ( Reifiable )
41+import Rel8.Schema.Context.Abstract ( Abstract )
39−import Rel8.Schema.Context.Nullify ( Nullifiable, nullifier, unnullifier )
42+import Rel8.Schema.Context.Nullify ( Nullifiable )
40import Rel8.Schema.Dict ( Dict( Dict ) )
43import Rel8.Schema.Dict ( Dict( Dict ) )
41import Rel8.Schema.HTable.Either ( HEitherTable(..) )
44import Rel8.Schema.HTable.Either ( HEitherTable(..) )
42import Rel8.Schema.HTable.Identity ( HIdentity(..) )
45import Rel8.Schema.HTable.Identity ( HIdentity(..) )
43import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
46import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
44−import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
45import qualified Rel8.Schema.Kind as K
47import qualified Rel8.Schema.Kind as K
46import Rel8.Schema.Name ( Col( N ), Name )
48import Rel8.Schema.Name ( Col( N ), Name )
47import Rel8.Schema.Spec ( Spec( Spec ) )
49import Rel8.Schema.Spec ( Spec( Spec ) )
@@ -51,6 +53,7 @@ import Rel8.Table
51 )
53 )
52import Rel8.Table.Bool ( bool )
54import Rel8.Table.Bool ( bool )
53import Rel8.Table.Eq ( EqTable, eqTable )
55import Rel8.Table.Eq ( EqTable, eqTable )
56+import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )
54import Rel8.Table.Ord ( OrdTable, ordTable )
57import Rel8.Table.Ord ( OrdTable, ordTable )
55import Rel8.Table.Recontextualize ( Recontextualize )
58import Rel8.Table.Recontextualize ( Recontextualize )
56import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
59import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
@@ -71,19 +74,19 @@ import Data.Functor.Bind ( Bind, (>>-) )
71type EitherTable :: K.Context -> Type -> Type -> Type
74type EitherTable :: K.Context -> Type -> Type -> Type
72data EitherTable context a b = EitherTable
75data EitherTable context a b = EitherTable
73 { tag :: Col context ('Spec EitherTag)
76 { tag :: Col context ('Spec EitherTag)
74− , left :: a
77+ , left :: Nullify context a
75− , right :: b
78+ , right :: Nullify context b
76 }
79 }
77 deriving stock Functor
80 deriving stock Functor
78
81
79
82
80−instance Bifunctor (EitherTable context) where
83+instance Nullifiable context => Bifunctor (EitherTable context) where
81− bimap f g (EitherTable tag a b) = EitherTable tag (f a) (g b)
84+ bimap f g (EitherTable tag a b) = EitherTable tag (fmap f a) (fmap g b)
82
85
83
86
84instance (context ~ Expr, Table Expr a) => Apply (EitherTable context a) where
87instance (context ~ Expr, Table Expr a) => Apply (EitherTable context a) where
85 EitherTable (E tag) l1 f <.> EitherTable (E tag') l2 a =
88 EitherTable (E tag) l1 f <.> EitherTable (E tag') l2 a =
86− EitherTable (E (tag <> tag')) (bool l1 l2 (isLeft tag)) (f a)
89+ EitherTable (E (tag <> tag')) (bool l1 l2 (isLeft tag)) (f <.> a)
87
90
88
91
89instance (context ~ Expr, Table Expr a) => Applicative (EitherTable context a) where
92instance (context ~ Expr, Table Expr a) => Applicative (EitherTable context a) where
@@ -92,7 +95,7 @@ instance (context ~ Expr, Table Expr a) => Applicative (EitherTable context a) w
92
95
93
96
94instance (context ~ Expr, Table Expr a) => Bind (EitherTable context a) where
97instance (context ~ Expr, Table Expr a) => Bind (EitherTable context a) where
95− EitherTable (E tag) l1 a >>- f = case f a of
98+ EitherTable (E tag) l1 a >>- f = case f (extract a) of
96 EitherTable (E tag') l2 b ->
99 EitherTable (E tag') l2 b ->
97 EitherTable (E (tag <> tag')) (bool l1 l2 (isRight tag)) b
100 EitherTable (E (tag <> tag')) (bool l1 l2 (isRight tag)) b
98
101
@@ -109,7 +112,7 @@ instance (context ~ Expr, Table Expr a, Table Expr b) =>
109
112
110instance
113instance
111 ( Table context a, Table context b
114 ( Table context a, Table context b
112− , Nullifiable context, context ~ context'
115+ , Reifiable context, Abstract context, context ~ context'
113 )
116 )
114 => Table context' (EitherTable context a b)
117 => Table context' (EitherTable context a b)
115 where
118 where
@@ -117,29 +120,28 @@ instance
117 type Context (EitherTable context a b) = Context a
120 type Context (EitherTable context a b) = Context a
118
121
119 toColumns EitherTable {tag, left, right} = HEitherTable
122 toColumns EitherTable {tag, left, right} = HEitherTable
120− { htag = hlabel (HType tag)
123+ { htag = hlabel $ HType tag
121− , hleft = hlabel $ hnullify (nullifier tag isLeft) $ toColumns left
124+ , hleft = hlabel $ guard tag (== IsLeft) isLeft $ toColumns left
122− , hright = hlabel $ hnullify (nullifier tag isRight) $ toColumns right
125+ , hright = hlabel $ guard tag (== IsRight) isRight $ toColumns right
123 }
126 }
124
127
125 fromColumns HEitherTable {htag, hleft, hright} = EitherTable
128 fromColumns HEitherTable {htag, hleft, hright} = EitherTable
126− { tag = unHIdentity (hunlabel htag)
129+ { tag = unHIdentity $ hunlabel htag
127− , left =
128− fromColumns $
130+ , left = fromColumns $ hunlabel hleft
129− runIdentity $
130− hunnullify (\spec -> pure . unnullifier spec) $
131− hunlabel
132− hleft
133− , right =
134− fromColumns $
131+ , right = fromColumns $ hunlabel hright
135− runIdentity $
136− hunnullify (\spec -> pure . unnullifier spec) $
137− hunlabel
138− hright
139 }
132 }
140
133
141− reify = liftA2 bimap reify reify
134+ reify proof EitherTable {tag, left, right} = EitherTable
142− unreify = liftA2 bimap unreify unreify
135+ { tag
136+ , left = reify proof left
137+ , right = reify proof right
138+ }
139+
140+ unreify proof EitherTable {tag, left, right} = EitherTable
141+ { tag
142+ , left = unreify proof left
143+ , right = unreify proof right
144+ }
143
145
144 coherence = coherence @context @a
146 coherence = coherence @context @a
145 congruence proof abstract =
147 congruence proof abstract =
@@ -149,8 +151,8 @@ instance
149
151
150
152
151instance
153instance
152− ( Nullifiable from, from ~ from'
154+ ( Reifiable from, Abstract from, from ~ from'
153− , Nullifiable to, to ~ to'
155+ , Reifiable to, Abstract to, to ~ to'
154 , Recontextualize from to a1 b1
156 , Recontextualize from to a1 b1
155 , Recontextualize from to a2 b2
157 , Recontextualize from to a2 b2
156 )
158 )
@@ -162,8 +164,8 @@ instance (EqTable a, EqTable b, context ~ Expr) =>
162 where
164 where
163 eqTable = HEitherTable
165 eqTable = HEitherTable
164 { htag = hlabel (HType Dict)
166 { htag = hlabel (HType Dict)
165− , hleft = hlabel (hnullify (\_ Dict -> Dict) (eqTable @a))
167+ , hleft = hlabel (eqTable @(Nullify context a))
166− , hright = hlabel (hnullify (\_ Dict -> Dict) (eqTable @b))
168+ , hright = hlabel (eqTable @(Nullify context b))
167 }
169 }
168
170
169
171
@@ -172,8 +174,8 @@ instance (OrdTable a, OrdTable b, context ~ Expr) =>
172 where
174 where
173 ordTable = HEitherTable
175 ordTable = HEitherTable
174 { htag = hlabel (HType Dict)
176 { htag = hlabel (HType Dict)
175− , hleft = hlabel (hnullify (\_ Dict -> Dict) (ordTable @a))
177+ , hleft = hlabel (ordTable @(Nullify context a))
176− , hright = hlabel (hnullify (\_ Dict -> Dict) (ordTable @b))
178+ , hright = hlabel (ordTable @(Nullify context b))
177 }
179 }
178
180
179
181
@@ -207,17 +209,17 @@ isRightTable EitherTable {tag = E tag} = isRight tag
207eitherTable :: Table Expr c
209eitherTable :: Table Expr c
208 => (a -> c) -> (b -> c) -> EitherTable Expr a b -> c
210 => (a -> c) -> (b -> c) -> EitherTable Expr a b -> c
209eitherTable f g EitherTable {tag = E tag, left, right} =
211eitherTable f g EitherTable {tag = E tag, left, right} =
210− bool (f left) (g right) (isRight tag)
212+ bool (f (extract left)) (g (extract right)) (isRight tag)
211
213
212
214
213-- | Construct a left 'EitherTable'. Like 'Left'.
215-- | Construct a left 'EitherTable'. Like 'Left'.
214leftTable :: Table Expr b => a -> EitherTable Expr a b
216leftTable :: Table Expr b => a -> EitherTable Expr a b
215−leftTable a = EitherTable (E (litExpr IsLeft)) a undefined
217+leftTable a = EitherTable (E (litExpr IsLeft)) (pure a) undefined
216
218
217
219
218-- | Construct a right 'EitherTable'. Like 'Right'.
220-- | Construct a right 'EitherTable'. Like 'Right'.
219rightTable :: Table Expr a => b -> EitherTable Expr a b
221rightTable :: Table Expr a => b -> EitherTable Expr a b
220−rightTable = EitherTable (E (litExpr IsRight)) undefined
222+rightTable = EitherTable (E (litExpr IsRight)) undefined . pure
221
223
222
224
223-- | Lift a pair of aggregating functions to operate on an 'EitherTable'.
225-- | Lift a pair of aggregating functions to operate on an 'EitherTable'.
@@ -227,8 +229,11 @@ aggregateEitherTable :: ()
227 -> (exprs' -> aggregates')
229 -> (exprs' -> aggregates')
228 -> EitherTable Expr exprs exprs'
230 -> EitherTable Expr exprs exprs'
229 -> EitherTable Aggregate aggregates aggregates'
231 -> EitherTable Aggregate aggregates aggregates'
230−aggregateEitherTable f g (EitherTable (E tag) a b) =
232+aggregateEitherTable f g (EitherTable (E tag) a b) = EitherTable
231− EitherTable (A (groupByExpr tag)) (f a) (g b)
233+ { tag = A (groupByExpr tag)
234+ , left = aggregateNullify f a
235+ , right = aggregateNullify g b
236+ }
232
237
233
238
234-- | Construct a 'EitherTable' in the 'Name' context. This can be useful if you
239-- | Construct a 'EitherTable' in the 'Name' context. This can be useful if you
@@ -243,4 +248,4 @@ nameEitherTable
243 -> b
248 -> b
244 -- ^ Names of the columns in the @b@ table.
249 -- ^ Names of the columns in the @b@ table.
245 -> EitherTable Name a b
250 -> EitherTable Name a b
246−nameEitherTable = EitherTable . N
251+nameEitherTable tag left right = EitherTable (N tag) (pure left) (pure right)
src/Rel8/Table/Maybe.hs+36−30
@@ -23,26 +23,30 @@ where
23
23
24-- base
24-- base
25import Control.Category ( id )
25import Control.Category ( id )
26−import Data.Functor.Identity ( runIdentity )
27import Data.Kind ( Type )
26import Data.Kind ( Type )
27+import Data.Maybe ( isJust )
28import Data.Type.Equality ( apply )
28import Data.Type.Equality ( apply )
29import Prelude hiding ( id, null, undefined )
29import Prelude hiding ( id, null, undefined )
30
30
31+-- comonad
32+import Control.Comonad ( extract )
33+
31-- rel8
34-- rel8
32import Rel8.Aggregate ( Col( A ), Aggregate )
35import Rel8.Aggregate ( Col( A ), Aggregate )
33import Rel8.Expr ( Col( E ), Expr )
36import Rel8.Expr ( Col( E ), Expr )
34import Rel8.Expr.Aggregate ( groupByExpr )
37import Rel8.Expr.Aggregate ( groupByExpr )
35import Rel8.Expr.Bool ( boolExpr )
38import Rel8.Expr.Bool ( boolExpr )
36import Rel8.Expr.Null ( isNull, isNonNull, null, nullify )
39import Rel8.Expr.Null ( isNull, isNonNull, null, nullify )
37−import Rel8.Schema.Context.Nullify ( Nullifiable, nullifier, unnullifier )
40+import Rel8.Kind.Context ( Reifiable )
41+import Rel8.Schema.Context.Abstract ( Abstract )
38import Rel8.Schema.Dict ( Dict( Dict ) )
42import Rel8.Schema.Dict ( Dict( Dict ) )
39import qualified Rel8.Schema.Kind as K
43import qualified Rel8.Schema.Kind as K
40import Rel8.Schema.HTable.Identity ( HIdentity(..) )
44import Rel8.Schema.HTable.Identity ( HIdentity(..) )
41import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
45import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
42import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
46import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
43−import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
44import Rel8.Schema.Name ( Col( N ), Name )
47import Rel8.Schema.Name ( Col( N ), Name )
45−import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql, nullable )
48+import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )
49+import qualified Rel8.Schema.Null as N
46import Rel8.Schema.Spec ( Spec( Spec ) )
50import Rel8.Schema.Spec ( Spec( Spec ) )
47import Rel8.Table
51import Rel8.Table
48 ( Table, Columns, Context, fromColumns, toColumns
52 ( Table, Columns, Context, fromColumns, toColumns
@@ -55,6 +59,7 @@ import Rel8.Table.Alternative
55import Rel8.Table.Bool ( bool )
59import Rel8.Table.Bool ( bool )
56import Rel8.Table.Eq ( EqTable, eqTable )
60import Rel8.Table.Eq ( EqTable, eqTable )
57import Rel8.Table.Ord ( OrdTable, ordTable )
61import Rel8.Table.Ord ( OrdTable, ordTable )
62+import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )
58import Rel8.Table.Recontextualize ( Recontextualize )
63import Rel8.Table.Recontextualize ( Recontextualize )
59import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
64import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
60import Rel8.Table.Undefined ( undefined )
65import Rel8.Table.Undefined ( undefined )
@@ -77,14 +82,14 @@ import Data.Functor.Bind ( Bind, (>>-) )
77type MaybeTable :: K.Context -> Type -> Type
82type MaybeTable :: K.Context -> Type -> Type
78data MaybeTable context a = MaybeTable
83data MaybeTable context a = MaybeTable
79 { tag :: Col context ('Spec (Maybe MaybeTag))
84 { tag :: Col context ('Spec (Maybe MaybeTag))
80− , just :: a
85+ , just :: Nullify context a
81 }
86 }
82 deriving stock Functor
87 deriving stock Functor
83
88
84
89
85instance context ~ Expr => Apply (MaybeTable context) where
90instance context ~ Expr => Apply (MaybeTable context) where
86 MaybeTable (E tag) f <.> MaybeTable (E tag') a =
91 MaybeTable (E tag) f <.> MaybeTable (E tag') a =
87− MaybeTable (E (tag <> tag')) (f a)
92+ MaybeTable (E (tag <> tag')) (f <.> a)
88
93
89
94
90-- | Has the same behavior as the @Applicative@ instance for @Maybe@. See also:
95-- | Has the same behavior as the @Applicative@ instance for @Maybe@. See also:
@@ -95,7 +100,7 @@ instance context ~ Expr => Applicative (MaybeTable context) where
95
100
96
101
97instance context ~ Expr => Bind (MaybeTable context) where
102instance context ~ Expr => Bind (MaybeTable context) where
98− MaybeTable (E tag) a >>- f = case f a of
103+ MaybeTable (E tag) a >>- f = case f (extract a) of
99 MaybeTable (E tag') b -> MaybeTable (E (tag <> tag')) b
104 MaybeTable (E tag') b -> MaybeTable (E (tag <> tag')) b
100
105
101
106
@@ -124,34 +129,35 @@ instance (context ~ Expr, Table Expr a, Semigroup a) =>
124 mempty = nothingTable
129 mempty = nothingTable
125
130
126
131
132+instance
133+ ( Table context a
127−instance (Table context a, Nullifiable context, context ~ context') =>
134+ , Reifiable context, Abstract context, context ~ context'
135+ )
128− Table context' (MaybeTable context a)
136+ => Table context' (MaybeTable context a)
129 where
137 where
130 type Columns (MaybeTable context a) = HMaybeTable (Columns a)
138 type Columns (MaybeTable context a) = HMaybeTable (Columns a)
131 type Context (MaybeTable context a) = Context a
139 type Context (MaybeTable context a) = Context a
132
140
133 toColumns MaybeTable {tag, just} = HMaybeTable
141 toColumns MaybeTable {tag, just} = HMaybeTable
134− { htag = hlabel (HIdentity tag)
142+ { htag = hlabel $ HIdentity tag
135− , hjust = hlabel $ hnullify (nullifier tag isNonNull) $ toColumns just
143+ , hjust = hlabel $ guard tag isJust isNonNull $ toColumns just
136 }
144 }
137
145
138 fromColumns HMaybeTable {htag, hjust} = MaybeTable
146 fromColumns HMaybeTable {htag, hjust} = MaybeTable
139− { tag = unHIdentity (hunlabel htag)
147+ { tag = unHIdentity $ hunlabel htag
140− , just = fromColumns $ runIdentity $
148+ , just = fromColumns $ hunlabel hjust
141− hunnullify ((pure .) . unnullifier) (hunlabel hjust)
142 }
149 }
143
150
144− reify = fmap fmap reify
151+ reify proof (MaybeTable tag a) = MaybeTable tag (reify proof a)
145− unreify = fmap fmap unreify
152+ unreify proof (MaybeTable tag a) = MaybeTable tag (unreify proof a)
146−
147 coherence = coherence @context @a
153 coherence = coherence @context @a
148 congruence proof abstract = id `apply` congruence @context @a proof abstract
154 congruence proof abstract = id `apply` congruence @context @a proof abstract
149
155
150
156
151instance
157instance
152− ( Nullifiable from, from ~ from'
153− , Nullifiable to, to ~ to'
154− , Recontextualize from to a b
158+ ( Recontextualize from to a b
159+ , Reifiable from, Abstract from, from ~ from'
160+ , Reifiable to, Abstract to, to ~ to'
155 )
161 )
156 => Recontextualize from to (MaybeTable from' a) (MaybeTable to' b)
162 => Recontextualize from to (MaybeTable from' a) (MaybeTable to' b)
157
163
@@ -159,14 +165,14 @@ instance
159instance (EqTable a, context ~ Expr) => EqTable (MaybeTable context a) where
165instance (EqTable a, context ~ Expr) => EqTable (MaybeTable context a) where
160 eqTable = HMaybeTable
166 eqTable = HMaybeTable
161 { htag = hlabel (HType Dict)
167 { htag = hlabel (HType Dict)
162− , hjust = hlabel (hnullify (\_ Dict -> Dict) (eqTable @a))
168+ , hjust = hlabel (eqTable @(Nullify context a))
163 }
169 }
164
170
165
171
166instance (OrdTable a, context ~ Expr) => OrdTable (MaybeTable context a) where
172instance (OrdTable a, context ~ Expr) => OrdTable (MaybeTable context a) where
167 ordTable = HMaybeTable
173 ordTable = HMaybeTable
168 { htag = hlabel (HType Dict)
174 { htag = hlabel (HType Dict)
169− , hjust = hlabel (hnullify (\_ Dict -> Dict) (ordTable @a))
175+ , hjust = hlabel (ordTable @(Nullify context a))
170 }
176 }
171
177
172
178
@@ -192,29 +198,29 @@ isJustTable (MaybeTable (E tag) _) = isNonNull tag
192
198
193-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.
199-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.
194maybeTable :: Table Expr b => b -> (a -> b) -> MaybeTable Expr a -> b
200maybeTable :: Table Expr b => b -> (a -> b) -> MaybeTable Expr a -> b
195−maybeTable b f ma@(MaybeTable _ a) = bool (f a) b (isNothingTable ma)
201+maybeTable b f ma@(MaybeTable _ a) = bool (f (extract a)) b (isNothingTable ma)
196{-# INLINABLE maybeTable #-}
202{-# INLINABLE maybeTable #-}
197
203
198
204
199-- | The null table. Like 'Nothing'.
205-- | The null table. Like 'Nothing'.
200nothingTable :: Table Expr a => MaybeTable Expr a
206nothingTable :: Table Expr a => MaybeTable Expr a
201−nothingTable = MaybeTable (E null) undefined
207+nothingTable = MaybeTable (E null) (pure undefined)
202
208
203
209
204-- | Lift any table into 'MaybeTable'. Like 'Just'. Note you can also use
210-- | Lift any table into 'MaybeTable'. Like 'Just'. Note you can also use
205-- 'pure'.
211-- 'pure'.
206justTable :: a -> MaybeTable Expr a
212justTable :: a -> MaybeTable Expr a
207−justTable = MaybeTable (E mempty)
213+justTable = MaybeTable (E mempty) . pure
208
214
209
215
210-- | Project a single expression out of a 'MaybeTable'. You can think of this
216-- | Project a single expression out of a 'MaybeTable'. You can think of this
211-- operator like the '$' operator, but it also has the ability to return
217-- operator like the '$' operator, but it also has the ability to return
212-- @null@.
218-- @null@.
213($?) :: forall a b. Sql DBType b
219($?) :: forall a b. Sql DBType b
214− => (a -> Expr b) -> MaybeTable Expr a -> Expr (Nullify b)
220+ => (a -> Expr b) -> MaybeTable Expr a -> Expr (N.Nullify b)
215f $? ma@(MaybeTable _ a) = case nullable @b of
221f $? ma@(MaybeTable _ a) = case nullable @b of
216− Null -> boolExpr (f a) null (isNothingTable ma)
222+ Null -> boolExpr (f (extract a)) null (isNothingTable ma)
217− NotNull -> boolExpr (nullify (f a)) null (isNothingTable ma)
223+ NotNull -> boolExpr (nullify (f (extract a))) null (isNothingTable ma)
218infixl 4 $?
224infixl 4 $?
219
225
220
226
@@ -225,7 +231,7 @@ aggregateMaybeTable :: ()
225 -> MaybeTable Expr exprs
231 -> MaybeTable Expr exprs
226 -> MaybeTable Aggregate aggregates
232 -> MaybeTable Aggregate aggregates
227aggregateMaybeTable f (MaybeTable (E tag) a) =
233aggregateMaybeTable f (MaybeTable (E tag) a) =
228− MaybeTable (A (groupByExpr tag)) (f a)
234+ MaybeTable (A (groupByExpr tag)) (aggregateNullify f a)
229
235
230
236
231-- | Construct a 'MaybeTable' in the 'Name' context. This can be useful if you
237-- | Construct a 'MaybeTable' in the 'Name' context. This can be useful if you
@@ -238,4 +244,4 @@ nameMaybeTable
238 -> a
244 -> a
239 -- ^ Names of the columns in @a@.
245 -- ^ Names of the columns in @a@.
240 -> MaybeTable Name a
246 -> MaybeTable Name a
241−nameMaybeTable = MaybeTable . N
247+nameMaybeTable tag = MaybeTable (N tag) . pure
src/Rel8/Table/Nullify.hsnew file+204
@@ -0,0 +1,204 @@
1+{-# language DataKinds #-}
2+{-# language FlexibleInstances #-}
3+{-# language LambdaCase #-}
4+{-# language MultiParamTypeClasses #-}
5+{-# language ScopedTypeVariables #-}
6+{-# language StandaloneKindSignatures #-}
7+{-# language TypeApplications #-}
8+{-# language TypeFamilies #-}
9+{-# language UndecidableInstances #-}
10+
11+module Rel8.Table.Nullify
12+ ( Nullify
13+ , aggregateNullify
14+ , guard
15+ )
16+where
17+
18+-- base
19+import Control.Applicative ( liftA2 )
20+import Control.Category ( id )
21+import Data.Functor.Identity ( runIdentity )
22+import Data.Kind ( Type )
23+import Data.Type.Equality ( (:~:)( Refl ), apply )
24+import Prelude hiding ( id )
25+
26+-- comonad
27+import Control.Comonad ( Comonad, duplicate, extract, ComonadApply, (<@>) )
28+
29+-- rel8
30+import Rel8.Aggregate ( Aggregate )
31+import Rel8.Expr ( Expr )
32+import Rel8.Kind.Context ( Reifiable, contextSing )
33+import Rel8.Schema.Context ( Col )
34+import Rel8.Schema.Context.Abstract ( Abstract, exclusivity, virtual )
35+import Rel8.Schema.Context.Nullify
36+ ( Nullifiability( NAggregate, NExpr )
37+ , NonNullifiability( NNReify )
38+ , Nullifiable, nullifiability
39+ , nullifiableOrNot, absurd
40+ , guarder
41+ , nullifier
42+ , unnullifier
43+ )
44+import Rel8.Schema.Dict ( Dict( Dict ) )
45+import Rel8.Schema.HTable ( HTable )
46+import Rel8.Schema.HTable.Nullify ( HNullify, hnullify, hunnullify, hguard )
47+import qualified Rel8.Schema.Kind as K
48+import Rel8.Schema.Reify ( hreify, hunreify )
49+import Rel8.Schema.Spec ( Spec( Spec ) )
50+import Rel8.Table
51+ ( Table, Columns, Context, toColumns, fromColumns
52+ , reify, unreify, coherence, congruence
53+ )
54+import Rel8.Table.Eq ( EqTable, eqTable )
55+import Rel8.Table.Ord ( OrdTable, ordTable )
56+import Rel8.Table.Recontextualize ( Recontextualize )
57+
58+-- semigroupoids
59+import Data.Functor.Apply ( Apply, (<.>), liftF2 )
60+import Data.Functor.Bind ( Bind, (>>-) )
61+import Data.Functor.Extend ( Extend, duplicated )
62+
63+
64+type Nullify :: K.Context -> Type -> Type
65+data Nullify context a
66+ = Table (Nullifiability context) a
67+ | Fields (NonNullifiability context) (HNullify (Columns a) (Col (Context a)))
68+
69+
70+instance Nullifiable context => Functor (Nullify context) where
71+ fmap f = \case
72+ Table nullifiable a -> Table nullifiable (f a)
73+ Fields notNullifiable _ -> absurd nullifiability notNullifiable
74+
75+
76+instance Nullifiable context => Foldable (Nullify context) where
77+ foldMap f = \case
78+ Table _ a -> f a
79+ Fields notNullifiable _ -> absurd nullifiability notNullifiable
80+
81+
82+instance Nullifiable context => Traversable (Nullify context) where
83+ traverse f = \case
84+ Table nullifiable a -> Table nullifiable <$> f a
85+ Fields notNullifiable _ -> absurd nullifiability notNullifiable
86+
87+
88+instance Nullifiable context => Apply (Nullify context) where
89+ liftF2 f = \case
90+ Table nullifiable a -> \case
91+ Table _ b -> Table nullifiable (f a b)
92+ Fields notNullifiable _ -> absurd nullifiable notNullifiable
93+ Fields notNullifiable _ -> absurd nullifiability notNullifiable
94+
95+
96+instance Nullifiable context => Applicative (Nullify context) where
97+ pure = Table nullifiability
98+ liftA2 = liftF2
99+
100+
101+instance Nullifiable context => Bind (Nullify context) where
102+ Table _ a >>- f = f a
103+ Fields notNullifiable _ >>- _ = absurd nullifiability notNullifiable
104+
105+
106+instance Nullifiable context => Monad (Nullify context) where
107+ (>>=) = (>>-)
108+
109+
110+instance Nullifiable context => Extend (Nullify context) where
111+ duplicated = \case
112+ Table nullifiable a -> Table nullifiable (Table nullifiable a)
113+ Fields notNullifiable _ -> absurd nullifiability notNullifiable
114+
115+
116+instance Nullifiable context => Comonad (Nullify context) where
117+ extract = \case
118+ Table _ a -> a
119+ Fields notNullifiable _ -> absurd nullifiability notNullifiable
120+ duplicate = duplicated
121+
122+
123+instance Nullifiable context => ComonadApply (Nullify context) where
124+ (<@>) = (<.>)
125+
126+
127+instance
128+ ( Table context a
129+ , Reifiable context, Abstract context, context ~ context'
130+ )
131+ => Table context' (Nullify context a)
132+ where
133+ type Columns (Nullify context a) = HNullify (Columns a)
134+ type Context (Nullify context a) = Context a
135+
136+ fromColumns = case nullifiableOrNot contextSing of
137+ Left notNullifiable -> Fields notNullifiable
138+ Right nullifiable ->
139+ Table nullifiable .
140+ fromColumns .
141+ runIdentity .
142+ hunnullify (\spec -> pure . unnullifier nullifiable spec)
143+
144+ toColumns = \case
145+ Table nullifiable a -> hnullify (nullifier nullifiable) (toColumns a)
146+ Fields _ a -> a
147+
148+ reify proof@Refl = \case
149+ Table nullifiable a -> Table nullifiable (reify proof a)
150+ Fields notNullifiable a -> case notNullifiable of
151+ NNReify (_ :: NonNullifiability ctx) ->
152+ case coherence @context @a proof abstract of
153+ Refl -> case congruence @context @a proof abstract of
154+ Refl -> Fields notNullifiable (hreify a)
155+ where
156+ abstract = exclusivity (virtual @ctx)
157+
158+ unreify proof@Refl = \case
159+ Table nullifiable a -> Table nullifiable (unreify proof a)
160+ Fields notNullifiable a -> case notNullifiable of
161+ NNReify (_ :: NonNullifiability ctx) ->
162+ case coherence @context @a proof abstract of
163+ Refl -> case congruence @context @a proof abstract of
164+ Refl -> Fields notNullifiable (hunreify a)
165+ where
166+ abstract = exclusivity (virtual @ctx)
167+
168+ coherence = coherence @context @a
169+ congruence proof abstract = id `apply` congruence @context @a proof abstract
170+
171+
172+instance
173+ ( Recontextualize from to a b
174+ , Reifiable from, Abstract from, from ~ from'
175+ , Reifiable to, Abstract to, to ~ to'
176+ )
177+ => Recontextualize from' to' (Nullify from a) (Nullify to b)
178+
179+
180+instance (EqTable a, context ~ Expr) => EqTable (Nullify context a) where
181+ eqTable = hnullify (\_ Dict -> Dict) (eqTable @a)
182+
183+
184+instance (OrdTable a, context ~ Expr) => OrdTable (Nullify context a) where
185+ ordTable = hnullify (\_ Dict -> Dict) (ordTable @a)
186+
187+
188+aggregateNullify :: ()
189+ => (exprs -> aggregates)
190+ -> Nullify Expr exprs
191+ -> Nullify Aggregate aggregates
192+aggregateNullify f = \case
193+ Table _ a -> Table NAggregate (f a)
194+ Fields notNullifiable _ -> absurd NExpr notNullifiable
195+
196+
197+guard :: (Reifiable context, HTable t)
198+ => Col context ('Spec tag)
199+ -> (tag -> Bool)
200+ -> (Expr tag -> Expr Bool)
201+ -> HNullify t (Col context)
202+ -> HNullify t (Col context)
203+guard tag isNonNull isNonNullExpr =
204+ hguard (guarder contextSing tag isNonNull isNonNullExpr)
src/Rel8/Table/These.hs+27−32
@@ -26,11 +26,10 @@ module Rel8.Table.These
26where
26where
27
27
28-- base
28-- base
29−import Control.Applicative ( liftA2 )
30import Control.Category ( id )
29import Control.Category ( id )
31import Data.Bifunctor ( Bifunctor, bimap )
30import Data.Bifunctor ( Bifunctor, bimap )
32−import Data.Functor.Identity ( runIdentity )
33import Data.Kind ( Type )
31import Data.Kind ( Type )
32+import Data.Maybe ( isJust )
34import Data.Type.Equality ( apply )
33import Data.Type.Equality ( apply )
35import Prelude hiding ( id, undefined )
34import Prelude hiding ( id, undefined )
36
35
@@ -39,11 +38,12 @@ import Rel8.Aggregate ( Aggregate )
39import Rel8.Expr ( Expr )
38import Rel8.Expr ( Expr )
40import Rel8.Expr.Bool ( (&&.), not_ )
39import Rel8.Expr.Bool ( (&&.), not_ )
41import Rel8.Expr.Null ( isNonNull )
40import Rel8.Expr.Null ( isNonNull )
41+import Rel8.Kind.Context ( Reifiable )
42+import Rel8.Schema.Context.Abstract ( Abstract )
42−import Rel8.Schema.Context.Nullify ( Nullifiable, nullifier, unnullifier )
43+import Rel8.Schema.Context.Nullify ( Nullifiable )
43import Rel8.Schema.Dict ( Dict( Dict ) )
44import Rel8.Schema.Dict ( Dict( Dict ) )
44import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
45import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
45import Rel8.Schema.HTable.Identity ( HIdentity(..) )
46import Rel8.Schema.HTable.Identity ( HIdentity(..) )
46−import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
47import Rel8.Schema.HTable.These ( HTheseTable(..) )
47import Rel8.Schema.HTable.These ( HTheseTable(..) )
48import qualified Rel8.Schema.Kind as K
48import qualified Rel8.Schema.Kind as K
49import Rel8.Schema.Name ( Name )
49import Rel8.Schema.Name ( Name )
@@ -59,6 +59,7 @@ import Rel8.Table.Maybe
59 , aggregateMaybeTable
59 , aggregateMaybeTable
60 , nameMaybeTable
60 , nameMaybeTable
61 )
61 )
62+import Rel8.Table.Nullify ( Nullify, guard )
62import Rel8.Table.Ord ( OrdTable, ordTable )
63import Rel8.Table.Ord ( OrdTable, ordTable )
63import Rel8.Table.Recontextualize ( Recontextualize )
64import Rel8.Table.Recontextualize ( Recontextualize )
64import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
65import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
@@ -88,7 +89,7 @@ data TheseTable context a b = TheseTable
88 deriving stock Functor
89 deriving stock Functor
89
90
90
91
91−instance Bifunctor (TheseTable context) where
92+instance Nullifiable context => Bifunctor (TheseTable context) where
92 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)
93 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)
93
94
94
95
@@ -138,7 +139,7 @@ instance (context ~ Expr, Table Expr a, Table Expr b, Semigroup a, Semigroup b)
138
139
139instance
140instance
140 ( Table context a, Table context b
141 ( Table context a, Table context b
141− , Nullifiable context, context ~ context'
142+ , Reifiable context, Abstract context, context ~ context'
142 )
143 )
143 => Table context' (TheseTable context a b)
144 => Table context' (TheseTable context a b)
144 where
145 where
@@ -146,39 +147,33 @@ instance
146 type Context (TheseTable context a b) = Context a
147 type Context (TheseTable context a b) = Context a
147
148
148 toColumns TheseTable {here, there} = HTheseTable
149 toColumns TheseTable {here, there} = HTheseTable
149− { hhereTag = hlabel (HIdentity (tag here))
150+ { hhereTag = hlabel $ HIdentity $ tag here
150 , hhere =
151 , hhere =
151− hlabel $ hnullify (nullifier (tag here) isNonNull) $ toColumns $
152+ hlabel $ guard (tag here) isJust isNonNull $ toColumns $ just here
152− just here
153− , hthereTag = hlabel (HIdentity (tag there))
153+ , hthereTag = hlabel $ HIdentity $ tag there
154 , hthere =
154 , hthere =
155− hlabel $ hnullify (nullifier (tag there) isNonNull) $ toColumns $
155+ hlabel $ guard (tag there) isJust isNonNull $ toColumns $ just there
156− just there
157 }
156 }
158
157
159 fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable
158 fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable
160 { here = MaybeTable
159 { here = MaybeTable
161 { tag = unHIdentity $ hunlabel hhereTag
160 { tag = unHIdentity $ hunlabel hhereTag
162− , just =
163− fromColumns $
161+ , just = fromColumns $ hunlabel hhere
164− runIdentity $
165− hunnullify (\a -> pure . unnullifier a) $
166− hunlabel
167− hhere
168 }
162 }
169 , there = MaybeTable
163 , there = MaybeTable
170 { tag = unHIdentity $ hunlabel hthereTag
164 { tag = unHIdentity $ hunlabel hthereTag
171− , just =
172− fromColumns $
165+ , just = fromColumns $ hunlabel hthere
173− runIdentity $
174− hunnullify (\a -> pure . unnullifier a) $
175− hunlabel
176− hthere
177 }
166 }
178 }
167 }
179
168
180− reify = liftA2 bimap reify reify
169+ reify proof TheseTable {here, there} = TheseTable
181− unreify = liftA2 bimap unreify unreify
170+ { here = reify proof here
171+ , there = reify proof there
172+ }
173+ unreify proof TheseTable {here, there} = TheseTable
174+ { here = unreify proof here
175+ , there = unreify proof there
176+ }
182
177
183 coherence = coherence @context @a
178 coherence = coherence @context @a
184 congruence proof abstract =
179 congruence proof abstract =
@@ -188,8 +183,8 @@ instance
188
183
189
184
190instance
185instance
191− ( Nullifiable from, from ~ from'
186+ ( Reifiable from, Abstract from, from ~ from'
192− , Nullifiable to, to ~ to'
187+ , Reifiable to, Abstract to, to ~ to'
193 , Recontextualize from to a1 b1
188 , Recontextualize from to a1 b1
194 , Recontextualize from to a2 b2
189 , Recontextualize from to a2 b2
195 )
190 )
@@ -201,9 +196,9 @@ instance (EqTable a, EqTable b, context ~ Expr) =>
201 where
196 where
202 eqTable = HTheseTable
197 eqTable = HTheseTable
203 { hhereTag = hlabel (HType Dict)
198 { hhereTag = hlabel (HType Dict)
204− , hhere = hlabel (hnullify (\_ Dict -> Dict) (eqTable @a))
199+ , hhere = hlabel (eqTable @(Nullify context a))
205 , hthereTag = hlabel (HType Dict)
200 , hthereTag = hlabel (HType Dict)
206− , hthere = hlabel (hnullify (\_ Dict -> Dict) (eqTable @b))
201+ , hthere = hlabel (eqTable @(Nullify context b))
207 }
202 }
208
203
209
204
@@ -212,9 +207,9 @@ instance (OrdTable a, OrdTable b, context ~ Expr) =>
212 where
207 where
213 ordTable = HTheseTable
208 ordTable = HTheseTable
214 { hhereTag = hlabel (HType Dict)
209 { hhereTag = hlabel (HType Dict)
215− , hhere = hlabel (hnullify (\_ Dict -> Dict) (ordTable @a))
210+ , hhere = hlabel (ordTable @(Nullify context a))
216 , hthereTag = hlabel (HType Dict)
211 , hthereTag = hlabel (HType Dict)
217− , hthere = hlabel (hnullify (\_ Dict -> Dict) (ordTable @b))
212+ , hthere = hlabel (ordTable @(Nullify context b))
218 }
213 }
219
214
220
215