b135026 · rel8 · git.iko.soy

git.iko.soy/rel8

We don't need the Identity instance for Taggable, dropping it simplifies things

commitb135026b549201b980984c8b35547d411a53a467 authorShane O'Brien <shane.obrien@circuithub.com> dateTue 30 Mar 2021, 11:35 (6 years ago) parente3bde04

6 files changed+40−114

compare with master

unifiedsplit

src/Rel8/Schema/Context/Nullify.hs+16−50 src/Rel8/Schema/Insert.hs+6−6 src/Rel8/Table/Either.hs+6−5 src/Rel8/Table/Maybe.hs+5−9 src/Rel8/Table/Tag.hs+5−41 src/Rel8/Table/These.hs+2−3

src/Rel8/Schema/Context/Nullify.hs+16−50

@@ -13,13 +13,12 @@

1313module Rel8.Schema.Context.Nullify

1414 ( Nullifiable( ConstrainTag, encodeTag, decodeTag, nullifier, unnullifier )

1515 , HNullifiable( HConstrainTag, hencodeTag, hdecodeTag, hnullifier, hunnullifier )

16− , runTag, runTagExpr, unnull, unnullExpr

16+ , runTag, unnull

1717 )

1818where

1919

2020-- base

2121import Control.Monad ( guard )

22−import Data.Functor.Identity ( Identity )

2322import Data.Kind ( Constraint, Type )

2423import GHC.TypeLits ( KnownSymbol )

2524import Prelude hiding ( null )

@@ -38,7 +37,7 @@ import Rel8.Expr.Bool ( boolExpr )

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

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

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

41−import Rel8.Schema.Context ( Interpretation, Col(..) )

40+import Rel8.Schema.Context ( Interpretation )

4241import qualified Rel8.Schema.Kind as K

4342import Rel8.Schema.Name ( Name( Name ), Col(..) )

4443import Rel8.Schema.Nullability

@@ -52,10 +51,7 @@ import Rel8.Schema.Spec.ConstrainDBType

5251 ( ConstrainDBType

5352 , dbTypeDict, dbTypeNullability, fromNullabilityDict

5453 )

55−import Rel8.Table.Tag

56− ( Tag(..), Taggable

57− , fromAggregate, fromExpr, fromIdentity, fromName

58− )

54+import Rel8.Table.Tag ( Tag(..), Taggable, fromAggregate, fromExpr, fromName )

5955

6056

6157type Nullifiable :: K.Context -> Constraint

@@ -81,7 +77,6 @@ class Interpretation context => Nullifiable context where

8177

8278 nullifier :: ()

8379 => Tag label a

84− -> (a -> Bool)

8580 -> (Expr a -> Expr Bool)

8681 -> SSpec ('Spec labels necessity x)

8782 -> Col context ('Spec labels necessity x)

@@ -99,15 +94,15 @@ instance Nullifiable Aggregate where

9994

10095 decodeTag (Aggregation aggregate) = fromAggregate aggregate

10196

102− nullifier Tag {expr} _ test SSpec {nullability} (Aggregation aggregate) =

97+ nullifier Tag {expr} test SSpec {nullability} (Aggregation aggregate) =

10398 Aggregation $

104− mapInputs (toPrimExpr . runTagExpr nullability condition . fromPrimExpr) $

105− runTagExpr nullability condition <$> aggregate

99+ mapInputs (toPrimExpr . runTag nullability condition . fromPrimExpr) $

100+ runTag nullability condition <$> aggregate

106101 where

107102 condition = test expr

108103

109104 unnullifier SSpec {nullability} (Aggregation aggregate) =

110− Aggregation $ unnullExpr nullability <$> aggregate

105+ Aggregation $ unnull nullability <$> aggregate

111106

112107 {-# INLINABLE encodeTag #-}

113108 {-# INLINABLE decodeTag #-}

@@ -118,22 +113,9 @@ instance Nullifiable Aggregate where

118113instance Nullifiable Expr where

119114 encodeTag Tag {expr} = DB expr

120115 decodeTag (DB a) = fromExpr a

121− nullifier Tag {expr} _ test SSpec {nullability} (DB a) =

122− DB $ runTagExpr nullability (test expr) a

123− unnullifier SSpec {nullability} (DB a) = DB $ unnullExpr nullability a

124−

125− {-# INLINABLE encodeTag #-}

126− {-# INLINABLE decodeTag #-}

127− {-# INLINABLE nullifier #-}

128− {-# INLINABLE unnullifier #-}

129−

130−

131−instance Nullifiable Identity where

132− encodeTag Tag {identity} = Result identity

133− decodeTag (Result a) = fromIdentity a

134− nullifier Tag {identity} test _ SSpec {nullability} (Result a) =

135− Result $ runTag nullability (test identity) a

136− unnullifier SSpec {nullability} (Result a) = Result $ unnull nullability a

116+ nullifier Tag {expr} test SSpec {nullability} (DB a) =

117+ DB $ runTag nullability (test expr) a

118+ unnullifier SSpec {nullability} (DB a) = DB $ unnull nullability a

137119

138120 {-# INLINABLE encodeTag #-}

139121 {-# INLINABLE decodeTag #-}

@@ -144,7 +126,7 @@ instance Nullifiable Identity where

144126instance Nullifiable Name where

145127 encodeTag Tag {name = Name name} = NameCol name

146128 decodeTag (NameCol name) = fromName (Name name)

147− nullifier _ _ _ _ (NameCol name) = NameCol name

129+ nullifier _ _ _ (NameCol name) = NameCol name

148130 unnullifier _ (NameCol name) = NameCol name

149131

150132 {-# INLINABLE encodeTag #-}

@@ -153,35 +135,20 @@ instance Nullifiable Name where

153135 {-# INLINABLE unnullifier #-}

154136

155137

156−runTagExpr :: Nullability a -> Expr Bool -> Expr a -> Expr (Nullify a)

157−runTagExpr nullability tag a = case nullability of

138+runTag :: Nullability a -> Expr Bool -> Expr a -> Expr (Nullify a)

139+runTag nullability tag a = case nullability of

158140 Nullable -> boolExpr null a tag

159141 NonNullable -> boolExpr null (nullify a) tag

160142 where

161143 null = fromPrimExpr $ Opaleye.ConstExpr Opaleye.NullLit

162144

163145

164−unnullExpr :: Nullability a -> Expr (Nullify a) -> Expr a

165−unnullExpr nullability a = case nullability of

146+unnull :: Nullability a -> Expr (Nullify a) -> Expr a

147+unnull nullability a = case nullability of

166148 Nullable -> a

167149 NonNullable -> unsafeUnnullify a

168150

169151

170−runTag :: Nullability a -> Bool -> a -> Nullify a

171−runTag nullability tag a = case nullability of

172− Nullable -> a <* guard tag

173− NonNullable -> a <$ guard tag

174−

175−

176−unnull :: Nullability a -> Nullify a -> a

177−unnull nullability ma = case nullability of

178− Nullable -> ma

179− NonNullable -> case ma of

180− Just a -> a

181− Nothing ->

182− error "Rel8.Schema.Context.Nullify.unnull: mismatch between tag and data"

183−

184−

185152type HNullifiable :: K.HContext -> Constraint

186153class HNullifiable context where

187154 type HConstrainTag context :: Type -> Constraint

@@ -197,7 +164,6 @@ class HNullifiable context where

197164

198165 hnullifier :: ()

199166 => Tag label a

200− -> (a -> Bool)

201167 -> (Expr a -> Expr Bool)

202168 -> SSpec ('Spec labels necessity x)

203169 -> context ('Spec labels necessity x)

@@ -223,7 +189,7 @@ instance HNullifiable (Dict (ConstrainDBType constraint)) where

223189 hencodeTag _ = Dict

224190 hdecodeTag = mempty

225191

226− hnullifier _ _ _ SSpec {} dict = case dbTypeDict dict of

192+ hnullifier _ _ SSpec {} dict = case dbTypeDict dict of

227193 Dict -> case dbTypeNullability dict of

228194 Nullable -> Dict

229195 NonNullable -> Dict

src/Rel8/Schema/Insert.hs+6−6

@@ -36,7 +36,7 @@ import Rel8.Schema.Context ( Interpretation(..) )

3636import Rel8.Schema.Context.Label ( Labelable(..) )

3737import Rel8.Schema.Context.Nullify

3838 ( Nullifiable, encodeTag, decodeTag, nullifier, unnullifier

39− , runTagExpr, unnullExpr

39+ , runTag, unnull

4040 )

4141import Rel8.Schema.HTable.Type ( HType(HType) )

4242import qualified Rel8.Schema.Kind as K

@@ -138,17 +138,17 @@ instance Nullifiable Insert where

138138 encodeTag = RequiredInsert . expr

139139 decodeTag (RequiredInsert a) = fromExpr a

140140

141− nullifier Tag {expr} _ test SSpec {nullability} = \case

141+ nullifier Tag {expr} test SSpec {nullability} = \case

142142 RequiredInsert a ->

143− RequiredInsert $ runTagExpr nullability condition a

143+ RequiredInsert $ runTag nullability condition a

144144 OptionalInsert ma ->

145− OptionalInsert $ runTagExpr nullability condition <$> ma

145+ OptionalInsert $ runTag nullability condition <$> ma

146146 where

147147 condition = test expr

148148

149149 unnullifier SSpec {nullability} = \case

150− RequiredInsert a -> RequiredInsert $ unnullExpr nullability a

151− OptionalInsert ma -> OptionalInsert $ unnullExpr nullability <$> ma

150+ RequiredInsert a -> RequiredInsert $ unnull nullability a

151+ OptionalInsert ma -> OptionalInsert $ unnull nullability <$> ma

152152

153153 {-# INLINABLE encodeTag #-}

154154 {-# INLINABLE decodeTag #-}

src/Rel8/Table/Either.hs+6−5

@@ -29,6 +29,7 @@ import Prelude hiding ( undefined )

2929import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )

3030import Rel8.Expr ( Expr )

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

32+import Rel8.Expr.Serialize ( litExpr )

3233import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler, hlabeler )

3334import Rel8.Schema.Context.Nullify

3435 ( Nullifiable, ConstrainTag

@@ -48,7 +49,7 @@ import Rel8.Table.Lifted

4849 )

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

5051import Rel8.Table.Recontextualize ( Recontextualize )

51−import Rel8.Table.Tag ( Tag(..), fromIdentity, fromName )

52+import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )

5253import Rel8.Table.Undefined ( undefined )

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

5455

@@ -100,8 +101,8 @@ instance Table2 EitherTable where

100101

101102 toColumns2 f g EitherTable {tag, left, right} = HEitherTable

102103 { htag

103− , hleft = hnullify (hnullifier tag (== IsLeft) isLeft) $ f left

104− , hright = hnullify (hnullifier tag (== IsRight) isRight) $ g right

104+ , hleft = hnullify (hnullifier tag isLeft) $ f left

105+ , hright = hnullify (hnullifier tag isRight) $ g right

105106 }

106107 where

107108 htag = HIdentity (hencodeTag tag)

@@ -177,7 +178,7 @@ eitherTable f g EitherTable {tag, left, right} =

177178

178179

179180leftTable :: Table Expr b => a -> EitherTable a b

180−leftTable a = EitherTable (fromIdentity IsLeft) a undefined

181+leftTable a = EitherTable (fromExpr (litExpr IsLeft)) a undefined

181182

182183

183184rightTable :: Table Expr a => b -> EitherTable a b

@@ -185,7 +186,7 @@ rightTable = rightTableWith undefined

185186

186187

187188rightTableWith :: a -> b -> EitherTable a b

188−rightTableWith = EitherTable (fromIdentity IsRight)

189+rightTableWith = EitherTable (fromExpr (litExpr IsRight))

189190

190191

191192aggregateEitherTable :: ()

src/Rel8/Table/Maybe.hs+5−9

@@ -22,10 +22,8 @@ module Rel8.Table.Maybe

2222where

2323

2424-- base

25−import qualified Data.Bool as Bool

2625import Data.Functor.Identity ( runIdentity )

2726import Data.Kind ( Type )

28−import Data.Maybe ( isJust, isNothing )

2927import Prelude hiding ( null, repeat, undefined, zipWith )

3028

3129-- rel8

@@ -62,10 +60,10 @@ import Rel8.Table.Lifted

6260 )

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

6462import Rel8.Table.Recontextualize ( Recontextualize )

65−import Rel8.Table.Tag ( Tag(..), fromIdentity, fromName )

63+import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )

6664import Rel8.Table.Undefined ( undefined )

6765import Rel8.Type ( DBType )

68−import Rel8.Type.Tag ( MaybeTag( IsJust ) )

66+import Rel8.Type.Tag ( MaybeTag )

6967

7068-- semigroupoids

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

@@ -114,8 +112,6 @@ instance AltTable MaybeTable where

114112 ma@(MaybeTable tag a) <|>: MaybeTable tag' b = MaybeTable

115113 { tag = (tag <> tag')

116114 { expr = boolExpr (expr tag) (expr tag') condition

117− , identity =

118− Bool.bool (identity tag) (identity tag') (isNothing (identity tag))

119115 }

120116 , just = bool a b condition

121117 }

@@ -141,7 +137,7 @@ instance Table1 MaybeTable where

141137

142138 toColumns1 f MaybeTable {tag, just} = HMaybeTable

143139 { htag

144− , hjust = hnullify (hnullifier tag isJust isNonNull) $ f just

140+ , hjust = hnullify (hnullifier tag isNonNull) $ f just

145141 }

146142 where

147143 htag = HIdentity (hencodeTag tag)

@@ -203,13 +199,13 @@ maybeTable b f ma@(MaybeTable _ a) = bool (f a) b (isNothingTable ma)

203199

204200-- | The null table. Like 'Nothing'.

205201nothingTable :: Table Expr a => MaybeTable a

206−nothingTable = MaybeTable (fromIdentity Nothing) undefined

202+nothingTable = MaybeTable (fromExpr null) undefined

207203

208204

209205-- | Lift any table into 'MaybeTable'. Like 'Just'. Note you can also use

210206-- 'pure'.

211207justTable :: a -> MaybeTable a

212−justTable = MaybeTable (fromIdentity (Just IsJust))

208+justTable = MaybeTable (fromExpr mempty)

213209

214210

215211-- | Project a single expression out of a 'MaybeTable'. You can think of this

src/Rel8/Table/Tag.hs+5−41

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

11{-# language DataKinds #-}

2−{-# language FlexibleContexts #-}

32{-# language FlexibleInstances #-}

43{-# language GADTs #-}

54{-# language InstanceSigs #-}

@@ -13,14 +12,13 @@ module Rel8.Table.Tag

1312 ( Tag(..), Taggable

1413 , fromAggregate

1514 , fromExpr

16− , fromIdentity

1715 , fromName

1816 )

1917where

2018

2119-- base

22−import Control.Applicative ( (<|>), empty, liftA2 )

23−import Data.Kind ( Type )

20+import Control.Applicative ( (<|>), empty )

21+import Data.Kind ( Constraint, Type )

2422import Data.Foldable ( fold )

2523import Data.Monoid ( getFirst )

2624import Data.Proxy ( Proxy( Proxy ) )

@@ -31,14 +29,9 @@ import Prelude

3129import Rel8.Aggregate ( Aggregate, Aggregator, foldInputs )

3230import Rel8.Expr ( Expr )

3331import Rel8.Expr.Opaleye ( fromPrimExpr )

34−import Rel8.Expr.Serialize ( litExpr )

3532import Rel8.Schema.Dict ( Dict( Dict ) )

3633import Rel8.Schema.Name ( Name( Name ) )

37−import Rel8.Schema.Nullability

38− ( Nullability( Nullable, NonNullable )

39− , Sql, nullabilization, mapSql

40− )

41−import Rel8.Type ( DBType )

34+import Rel8.Schema.Nullability ( Sql, mapSql )

4235import Rel8.Type.Monoid ( DBMonoid )

4336import Rel8.Type.Semigroup ( DBSemigroup )

4437

@@ -47,28 +40,23 @@ type Tag :: Symbol -> Type -> Type

4740data Tag label a = Tag

4841 { expr :: Expr a

4942 , aggregator :: Maybe Aggregator

50− , identity :: a

5143 , name :: Name a

5244 }

5345

5446

47+type Taggable :: Type -> Constraint

5548class Taggable a where

5649 tappend :: KnownSymbol label => Tag label a -> Tag label a -> Tag label a

5750 tempty :: KnownSymbol label => Tag label a

58− tlit :: a -> Expr a

5951

6052

61−instance (Sql Monoid a, Sql DBMonoid a) => Taggable a where

53+instance Sql DBMonoid a => Taggable a where

6254 tappend :: forall label. KnownSymbol label

6355 => Tag label a -> Tag label a -> Tag label a

6456 tappend a b = Tag

6557 { expr = case mapSql dbSemigroupFromDBMonoid (Dict @_ @a) of

6658 Dict -> expr a <> expr b

6759 , aggregator = aggregator a <|> aggregator b

68− , identity = case mapSql semigroupFromMonoid (Dict @_ @a) of

69− Dict -> case nullabilization @a of

70− Nullable -> liftA2 (<>) (identity a) (identity b)

71− NonNullable -> identity a <> identity b

7260 , name = case (name a, symbolVal (Proxy @label)) of

7361 (Name x, y)

7462 | x == y -> name b

@@ -79,17 +67,9 @@ instance (Sql Monoid a, Sql DBMonoid a) => Taggable a where

7967 tempty = Tag

8068 { expr = mempty

8169 , aggregator = empty

82− , identity = case nullabilization @a of

83− Nullable -> Just mempty

84− NonNullable -> mempty

8570 , name = Name (symbolVal (Proxy @label))

8671 }

8772

88− tlit = case mapSql (dbTypeFromDBSemigroup . dbSemigroupFromDBMonoid) dict of

89− Dict -> litExpr

90− where

91− dict = Dict @_ @a

92−

9373

9474instance (KnownSymbol label, Taggable a) => Semigroup (Tag label a) where

9575 (<>) = tappend

@@ -114,25 +94,9 @@ fromExpr :: forall label a. (KnownSymbol label, Taggable a)

11494fromExpr expr = (tempty @a @label) {expr}

11595

11696

117−fromIdentity :: forall a label. (KnownSymbol label, Taggable a)

118− => a -> Tag label a

119−fromIdentity identity = (mempty @(Tag label a))

120− { expr = tlit identity

121− , identity

122− }

123−

124−

12597fromName :: forall a label. Taggable a => Name a -> Tag label a

12698fromName name = (mempty @(Tag "" a)) {name}

12799

128100

129−dbTypeFromDBSemigroup :: Dict DBSemigroup a -> Dict DBType a

130−dbTypeFromDBSemigroup Dict = Dict

131−

132−

133101dbSemigroupFromDBMonoid :: Dict DBMonoid a -> Dict DBSemigroup a

134102dbSemigroupFromDBMonoid Dict = Dict

135−

136−

137−semigroupFromMonoid :: Dict Monoid a -> Dict Semigroup a

138−semigroupFromMonoid Dict = Dict

src/Rel8/Table/These.hs+2−3

@@ -27,7 +27,6 @@ where

2727import Data.Bifunctor ( Bifunctor, bimap )

2828import Data.Functor.Identity ( runIdentity )

2929import Data.Kind ( Type )

30−import Data.Maybe ( isJust )

3130import Prelude hiding ( undefined )

3231

3332-- rel8

@@ -125,10 +124,10 @@ instance Table2 TheseTable where

125124 toColumns2 f g TheseTable {here, there} = HTheseTable

126125 { hhereTag = HIdentity $ hencodeTag (toHereTag (tag here))

127126 , hhere =

128− hnullify (hnullifier (tag here) isJust isNonNull) $ f (just here)

127+ hnullify (hnullifier (tag here) isNonNull) $ f (just here)

129128 , hthereTag = HIdentity $ hencodeTag (toThereTag (tag there))

130129 , hthere =

131− hnullify (hnullifier (tag there) isJust isNonNull) $ g (just there)

130+ hnullify (hnullifier (tag there) isNonNull) $ g (just there)

132131 }

133132

134133 fromColumns2 f g HTheseTable {hhereTag, hhere, hthereTag, hthere} =