716d9f1 · rel8 · git.iko.soy

rel8.cabal+1−1

compare with master

unifiedsplit

@@ -134,7 +134,7 @@ library

134 Rel8.Schema.Reify

135 Rel8.Schema.Result

136 Rel8.Schema.Spec

137− Rel8.Schema.Spec.ConstrainDBType

137+ Rel8.Schema.Spec.Constrain

138 Rel8.Schema.Table

139

140 Rel8.Statement.Delete

src/Rel8/Schema/Context/Nullify.hs+5−67

@@ -9,14 +9,13 @@

9{-# language TypeFamilies #-}

10

11module Rel8.Schema.Context.Nullify

12− ( Nullifiable( ConstrainTag, encodeTag, decodeTag, nullifier, unnullifier )

12+ ( Nullifiable( encodeTag, decodeTag, nullifier, unnullifier )

13− , HNullifiable( HConstrainTag, hencodeTag, hdecodeTag, hnullifier, hunnullifier )

14 , runTag, unnull

13 , runTag, unnull

15 )

14 )

16where

15where

17

16

18-- base

17-- base

19−import Data.Kind ( Constraint, Type )

18+import Data.Kind ( Constraint )

20import GHC.TypeLits ( KnownSymbol )

19import GHC.TypeLits ( KnownSymbol )

21import Prelude hiding ( null )

20import Prelude hiding ( null )

22

21

@@ -36,31 +35,18 @@ import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )

36import Rel8.Schema.Context ( Interpretation )

35import Rel8.Schema.Context ( Interpretation )

37import qualified Rel8.Schema.Kind as K

36import qualified Rel8.Schema.Kind as K

38import Rel8.Schema.Name ( Name( Name ), Col( N ) )

37import Rel8.Schema.Name ( Name( Name ), Col( N ) )

39−import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql )

38+import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )

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

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

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

42−import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )

43−import qualified Rel8.Schema.Spec.ConstrainDBType as ConstrainDBType

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

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

45

41

46

42

47type Nullifiable :: K.Context -> Constraint

43type Nullifiable :: K.Context -> Constraint

48class Interpretation context => Nullifiable context where

44class Interpretation context => Nullifiable context where

49− type ConstrainTag context :: Type -> Constraint

50− type ConstrainTag _context = DefaultConstrainTag

51−

52− encodeTag ::

45+ encodeTag :: Taggable a

53− ( Sql (ConstrainTag context) a

54− , Taggable a

55− )

56 => Tag label a

46 => Tag label a

57 -> Col context ('Spec a)

47 -> Col context ('Spec a)

58

48

59− decodeTag ::

60− ( Sql (ConstrainTag context) a

61− , KnownSymbol label

49+ decodeTag :: (KnownSymbol label, Taggable a)

62− , Taggable a

63− )

64 => Col context ('Spec a)

50 => Col context ('Spec a)

65 -> Tag label a

51 -> Tag label a

66

52

@@ -137,51 +123,3 @@ unnull :: Nullity a -> Expr (Nullify a) -> Expr a

137unnull nullity a = case nullity of

123unnull nullity a = case nullity of

138 Null -> a

124 Null -> a

139 NotNull -> unsafeUnnullify a

125 NotNull -> unsafeUnnullify a

140−

141−

142−type HNullifiable :: K.HContext -> Constraint

143−class HNullifiable context where

144− type HConstrainTag context :: Type -> Constraint

145− type HConstrainTag _context = DefaultConstrainTag

146−

147− hencodeTag :: (Sql (HConstrainTag context) a, KnownSymbol label, Taggable a)

148− => Tag label a

149− -> context ('Spec a)

150−

151− hdecodeTag :: (Sql (HConstrainTag context) a, KnownSymbol label, Taggable a)

152− => context ('Spec a)

153− -> Tag label a

154−

155− hnullifier :: ()

156− => Tag label a

157− -> (Expr a -> Expr Bool)

158− -> SSpec ('Spec x)

159− -> context ('Spec x)

160− -> context ('Spec (Nullify x))

161−

162− hunnullifier :: ()

163− => SSpec ('Spec x)

164− -> context ('Spec (Nullify x))

165− -> context ('Spec x)

166−

167−

168−instance Nullifiable context => HNullifiable (Col context) where

169− type HConstrainTag (Col context) = ConstrainTag context

170− hencodeTag = encodeTag

171− hdecodeTag = decodeTag

172− hnullifier = nullifier

173− hunnullifier = unnullifier

174−

175−

176−instance HNullifiable (Dict (ConstrainDBType constraint)) where

177− type HConstrainTag (Dict (ConstrainDBType constraint)) = constraint

178−

179− hencodeTag _ = Dict

180− hdecodeTag = mempty

181− hnullifier _ _ = ConstrainDBType.nullifier

182− hunnullifier = ConstrainDBType.unnullifier

183−

184−

185−type DefaultConstrainTag :: Type -> Constraint

186−class DefaultConstrainTag a

187−instance DefaultConstrainTag a

src/Rel8/Schema/Spec/Constrain.hsnew file+32

@@ -0,0 +1,32 @@

1+{-# language ConstraintKinds #-}

2+{-# language DataKinds #-}

3+{-# language FlexibleInstances #-}

4+{-# language MultiParamTypeClasses #-}

5+{-# language StandaloneKindSignatures #-}

6+{-# language TypeFamilies #-}

7+{-# language UndecidableInstances #-}

8+{-# language UndecidableSuperClasses #-}

9+

10+module Rel8.Schema.Spec.Constrain

11+ ( ConstrainSpec

12+ )

13+where

14+

15+-- base

16+import Data.Kind ( Constraint, Type )

17+import Prelude ()

18+

19+-- rel8

20+import Rel8.Schema.Spec ( Spec( Spec ) )

21+

22+

23+type Unspec :: Spec -> Type

24+type family Unspec spec where

25+ Unspec ('Spec a) = a

26+

27+

28+type ConstrainSpec :: (Type -> Constraint) -> Spec -> Constraint

29+class (spec ~ 'Spec (Unspec spec), constraint (Unspec spec)) =>

30+ ConstrainSpec constraint spec

31+instance (spec ~ 'Spec (Unspec spec), constraint (Unspec spec)) =>

32+ ConstrainSpec constraint spec

src/Rel8/Schema/Spec/ConstrainDBType.hsdeleted−89

@@ -1,89 +0,0 @@

1−{-# language ConstraintKinds #-}

2−{-# language DataKinds #-}

3−{-# language FlexibleInstances #-}

4−{-# language MultiParamTypeClasses #-}

5−{-# language NamedFieldPuns #-}

6−{-# language QuantifiedConstraints #-}

7−{-# language StandaloneKindSignatures #-}

8−{-# language TypeFamilies #-}

9−{-# language UndecidableInstances #-}

10−

11−module Rel8.Schema.Spec.ConstrainDBType

12− ( ConstrainDBType

13− , dbTypeNullity, dbTypeDict

14− , nullifier, unnullifier

15− )

16−where

17−

18−-- base

19−import Data.Kind ( Constraint, Type )

20−import Prelude

21−

22−-- rel8

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

24−import Rel8.Schema.Null

25− ( Nullify, Unnullify

26− , Nullity( Null, NotNull )

27− , Sql, nullable

28− )

29−import Rel8.Schema.Spec ( Spec( Spec ), SSpec( SSpec, nullity ) )

30−

31−

32−type ConstrainDBType :: (Type -> Constraint) -> Spec -> Constraint

33−class

34− ( forall c a. ()

35− => (spec ~ 'Spec a)

36− => (forall x. (constraint x => c x)) => Sql c a

37− )

38− => ConstrainDBType constraint spec

39−instance

40− ( spec ~ 'Spec a

41− , Sql constraint a

42− )

43− => ConstrainDBType constraint spec

44−

45−

46−dbTypeNullity :: Dict (ConstrainDBType c) ('Spec a) -> Nullity a

47−dbTypeNullity = step2 . step1

48− where

49− step1 :: Dict (ConstrainDBType c) ('Spec a) -> Dict (Sql c) a

50− step1 Dict = Dict

51−

52− step2 :: Dict (Sql c) a -> Nullity a

53− step2 Dict = nullable

54−

55−

56−dbTypeDict :: Dict (ConstrainDBType c) ('Spec a) -> Dict c (Unnullify a)

57−dbTypeDict = step2 . step1

58− where

59− step1 :: Dict (ConstrainDBType c) ('Spec a) -> Dict (Sql c) a

60− step1 Dict = Dict

61−

62− step2 :: Dict (Sql c) a -> Dict c (Unnullify a)

63− step2 Dict = Dict

64−

65−

66−fromNullityDict :: Nullity a -> Dict c (Unnullify a) -> Dict (ConstrainDBType c) ('Spec a)

67−fromNullityDict Null Dict = Dict

68−fromNullityDict NotNull Dict = Dict

69−

70−

71−nullifier :: ()

72− => SSpec ('Spec a)

73− -> Dict (ConstrainDBType c) ('Spec a)

74− -> Dict (ConstrainDBType c) ('Spec (Nullify a))

75−nullifier SSpec {} dict = case dbTypeDict dict of

76− Dict -> case dbTypeNullity dict of

77− Null -> Dict

78− NotNull -> Dict

79−

80−

81−unnullifier :: ()

82− => SSpec ('Spec a)

83− -> Dict (ConstrainDBType c) ('Spec (Nullify a))

84− -> Dict (ConstrainDBType c) ('Spec a)

85−unnullifier SSpec {nullity} dict = case dbTypeDict dict of

86− Dict -> case nullity of

87− Null -> Dict

88− NotNull -> case dbTypeNullity dict of

89− Null -> fromNullityDict nullity Dict

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

@@ -26,8 +26,9 @@ import Rel8.Expr.Aggregate

26import Rel8.Schema.Dict ( Dict( Dict ) )

27import Rel8.Schema.HTable ( HTable, hfield, htabulate )

28import Rel8.Schema.HTable.Vectorize ( hvectorize )

29+import Rel8.Schema.Null ( Sql )

29import Rel8.Schema.Spec ( SSpec( SSpec, info ) )

30import Rel8.Schema.Spec ( SSpec( SSpec, info ) )

30−import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )

31+import Rel8.Schema.Spec.Constrain ( ConstrainSpec )

31import Rel8.Table ( toColumns, fromColumns )

32import Rel8.Table ( toColumns, fromColumns )

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

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

33import Rel8.Table.List ( ListTable )

34import Rel8.Table.List ( ListTable )

@@ -43,7 +44,7 @@ groupBy = fromColumns . hgroupBy (eqTable @exprs) . toColumns

43

44

45

45hgroupBy :: HTable t

46hgroupBy :: HTable t

46− => t (Dict (ConstrainDBType DBEq)) -> t (Col Expr) -> t (Col Aggregate)

47+ => t (Dict (ConstrainSpec (Sql DBEq))) -> t (Col Expr) -> t (Col Aggregate)

47hgroupBy eqs exprs = fromColumns $ htabulate $ \field ->

48hgroupBy eqs exprs = fromColumns $ htabulate $ \field ->

48 case hfield eqs field of

49 case hfield eqs field of

49 Dict -> case hfield exprs field of

50 Dict -> case hfield exprs field of

src/Rel8/Table/Either.hs+44−58

@@ -33,12 +33,11 @@ import Prelude hiding ( undefined )

33import Rel8.Expr ( Expr )

34import Rel8.Expr.Serialize ( litExpr )

35import Rel8.Schema.Context.Nullify

36− ( Nullifiable, ConstrainTag

36+ ( Nullifiable

37− , HNullifiable, HConstrainTag

37+ , encodeTag, decodeTag

38− , hencodeTag, hdecodeTag

38+ , nullifier, unnullifier

39− , hnullifier, hunnullifier

40 )

39 )

41−import Rel8.Schema.HTable ( HTable )

40+import Rel8.Schema.Dict ( Dict( Dict ) )

42import Rel8.Schema.HTable.Either ( HEitherTable(..) )

41import Rel8.Schema.HTable.Either ( HEitherTable(..) )

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

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

44import Rel8.Schema.HTable.Label ( hlabel, hunlabel )

43import Rel8.Schema.HTable.Label ( hlabel, hunlabel )

@@ -107,22 +106,45 @@ instance (Table Expr a, Table Expr b) => Semigroup (EitherTable a b) where

107

106

108instance

107instance

109 ( Table context a, Table context b

108 ( Table context a, Table context b

110− , Nullifiable context, ConstrainTag context EitherTag

109+ , Nullifiable context

111− ) =>

110+ )

112− Table context (EitherTable a b)

111+ => Table context (EitherTable a b)

113 where

112 where

114 type Columns (EitherTable a b) = HEitherTable (Columns a) (Columns b)

113 type Columns (EitherTable a b) = HEitherTable (Columns a) (Columns b)

115 type Context (EitherTable a b) = Context a

114 type Context (EitherTable a b) = Context a

116

115

117− toColumns = toColumns2 toColumns toColumns

116+ toColumns EitherTable {tag, left, right} = HEitherTable

118− fromColumns = fromColumns2 fromColumns fromColumns

117+ { htag

118+ , hleft = hlabel $ hnullify (nullifier tag isLeft) $ toColumns left

119+ , hright = hlabel $ hnullify (nullifier tag isRight) $ toColumns right

120+ }

121+ where

122+ htag = hlabel $ HType $ encodeTag tag

123+

124+ fromColumns HEitherTable {htag, hleft, hright} = EitherTable

125+ { tag

126+ , left =

127+ fromColumns $

128+ runIdentity $

129+ hunnullify (\a -> pure . unnullifier a) $

130+ hunlabel

131+ hleft

132+ , right =

133+ fromColumns $

134+ runIdentity $

135+ hunnullify (\a -> pure . unnullifier a) $

136+ hunlabel

137+ hright

138+ }

139+ where

140+ tag = decodeTag $ unHIdentity $ hunlabel htag

141+

119 reify = liftA2 bimap reify reify

142 reify = liftA2 bimap reify reify

120 unreify = liftA2 bimap unreify unreify

143 unreify = liftA2 bimap unreify unreify

121

144

122

145

123instance

146instance

124− ( Nullifiable from, ConstrainTag from EitherTag

147+ ( Nullifiable from, Nullifiable to

125− , Nullifiable to, ConstrainTag to EitherTag

126 , Recontextualize from to a1 b1

148 , Recontextualize from to a1 b1

127 , Recontextualize from to a2 b2

149 , Recontextualize from to a2 b2

128 )

150 )

@@ -130,11 +152,19 @@ instance

130

152

131

153

132instance (EqTable a, EqTable b) => EqTable (EitherTable a b) where

154instance (EqTable a, EqTable b) => EqTable (EitherTable a b) where

133− eqTable = toColumns2 id id (rightTableWith (eqTable @a) (eqTable @b))

155+ eqTable = HEitherTable

156+ { htag = hlabel (HType Dict)

157+ , hleft = hlabel (hnullify (\_ Dict -> Dict) (eqTable @a))

158+ , hright = hlabel (hnullify (\_ Dict -> Dict) (eqTable @b))

159+ }

134

160

135

161

136instance (OrdTable a, OrdTable b) => OrdTable (EitherTable a b) where

162instance (OrdTable a, OrdTable b) => OrdTable (EitherTable a b) where

137− ordTable = toColumns2 id id (rightTableWith (ordTable @a) (ordTable @b))

163+ ordTable = HEitherTable

164+ { htag = hlabel (HType Dict)

165+ , hleft = hlabel (hnullify (\_ Dict -> Dict) (ordTable @a))

166+ , hright = hlabel (hnullify (\_ Dict -> Dict) (ordTable @b))

167+ }

138

168

139

169

140type instance FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)

170type instance FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)

@@ -196,47 +226,3 @@ nameEitherTable

196 -- ^ Names of the columns in the @b@ table.

226 -- ^ Names of the columns in the @b@ table.

197 -> EitherTable a b

227 -> EitherTable a b

198nameEitherTable = EitherTable . fromName

228nameEitherTable = EitherTable . fromName

199−

200−

201−toColumns2 ::

202− ( HTable t

203− , HTable u

204− , HConstrainTag context EitherTag

205− , HNullifiable context

206− )

207− => (a -> t context)

208− -> (b -> u context)

209− -> EitherTable a b

210− -> HEitherTable t u context

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

212− { htag

213− , hleft = hlabel $ hnullify (hnullifier tag isLeft) $ f left

214− , hright = hlabel $ hnullify (hnullifier tag isRight) $ g right

215− }

216− where

217− htag = hlabel $ HType $ hencodeTag tag

218−

219−

220−fromColumns2 ::

221− ( HTable t

222− , HTable u

223− , HConstrainTag context EitherTag

224− , HNullifiable context

225− )

226− => (t context -> a)

227− -> (u context -> b)

228− -> HEitherTable t u context

229− -> EitherTable a b

230−fromColumns2 f g HEitherTable {htag, hleft, hright} = EitherTable

231− { tag

232− , left = f $ runIdentity $

233− hunnullify (\a -> pure . hunnullifier a) $

234− hunlabel

235− hleft

236− , right = g $ runIdentity $

237− hunnullify (\a -> pure . hunnullifier a) $

238− hunlabel

239− hright

240− }

241− where

242− tag = hdecodeTag $ unHIdentity $ hunlabel htag

src/Rel8/Table/Eq.hs+7−7

@@ -45,7 +45,7 @@ import Rel8.Schema.HTable

45 )

46import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )

47import Rel8.Schema.Null ( Sql )

48−import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType, nullifier )

48+import Rel8.Schema.Spec.Constrain ( ConstrainSpec )

49import Rel8.Table ( Table, Columns, toColumns, TColumns )

50import Rel8.Type.Eq ( DBEq )

51

@@ -55,14 +55,14 @@ import Rel8.Type.Eq ( DBEq )

55-- means "all columns in a 'Table' have an instance of 'DBEq'".

56type EqTable :: Type -> Constraint

57class Table Expr a => EqTable a where

58− eqTable :: Columns a (Dict (ConstrainDBType DBEq))

58+ eqTable :: Columns a (Dict (ConstrainSpec (Sql DBEq)))

59

60 default eqTable ::

61 ( KnownAlgebra (GAlgebra (Rep (Record a)))

62− , Eval (GGTable (GAlgebra (Rep (Record a))) TEqTable TColumns (Dict (ConstrainDBType DBEq)) (Rep (Record a)))

62+ , Eval (GGTable (GAlgebra (Rep (Record a))) TEqTable TColumns (Dict (ConstrainSpec (Sql DBEq))) (Rep (Record a)))

63 , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))

64 )

65− => Columns a (Dict (ConstrainDBType DBEq))

65+ => Columns a (Dict (ConstrainSpec (Sql DBEq)))

66 eqTable =

67 ggtable

68 @(GAlgebra (Rep (Record a)))

@@ -70,7 +70,7 @@ class Table Expr a => EqTable a where

70 @TColumns

71 @(Rep (Record a))

72 table

73− nullifier

73+ (\_ Dict -> Dict)

74 where

75 table (_ :: proxy x) = eqTable @x

76

@@ -82,11 +82,11 @@ type instance Eval (TEqTable a) = EqTable a

82instance

83 ( HTable t

84 , f ~ Col Expr

85− , HConstrainTable t (ConstrainDBType DBEq)

85+ , HConstrainTable t (ConstrainSpec (Sql DBEq))

86 )

87 => EqTable (t f)

88 where

89− eqTable = hdicts @(Columns (t f)) @(ConstrainDBType DBEq)

89+ eqTable = hdicts @(Columns (t f)) @(ConstrainSpec (Sql DBEq))

90

91

92instance Sql DBEq a => EqTable (Expr a) where

src/Rel8/Table/List.hs+6−9

@@ -29,7 +29,6 @@ import Rel8.Schema.HTable.Vectorize ( happend, hempty, hvectorize )

29import Rel8.Schema.Name ( Col( N ), Name( Name ) )

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

31import Rel8.Schema.Spec ( SSpec(..) )

32−import Rel8.Schema.Spec.ConstrainDBType ( dbTypeDict, dbTypeNullity )

33import Rel8.Schema.Reify ( hreify, hunreify )

32import Rel8.Schema.Reify ( hreify, hunreify )

34import Rel8.Table

33import Rel8.Table

35 ( Table, Context, Columns, fromColumns, toColumns

34 ( Table, Context, Columns, fromColumns, toColumns

@@ -75,20 +74,18 @@ instance

75instance EqTable a => EqTable (ListTable a) where

74instance EqTable a => EqTable (ListTable a) where

76 eqTable =

75 eqTable =

77 hvectorize

76 hvectorize

78− (\SSpec {} (Identity dict) -> case dbTypeDict dict of

77+ (\SSpec {nullity} (Identity Dict) -> case nullity of

79− Dict -> case dbTypeNullity dict of

80− Null -> Dict

78+ Null -> Dict

81− NotNull -> Dict)

79+ NotNull -> Dict)

82 (Identity (eqTable @a))

80 (Identity (eqTable @a))

83

81

84

82

85instance OrdTable a => OrdTable (ListTable a) where

83instance OrdTable a => OrdTable (ListTable a) where

86 ordTable =

84 ordTable =

87 hvectorize

85 hvectorize

88− (\SSpec {} (Identity dict) -> case dbTypeDict dict of

86+ (\SSpec {nullity} (Identity Dict) -> case nullity of

89− Dict -> case dbTypeNullity dict of

90− Null -> Dict

87+ Null -> Dict

91− NotNull -> Dict)

88+ NotNull -> Dict)

92 (Identity (ordTable @a))

89 (Identity (ordTable @a))

93

90

94

91

src/Rel8/Table/Maybe.hs+31−46

@@ -31,12 +31,11 @@ import Rel8.Expr ( Expr )

31import Rel8.Expr.Bool ( boolExpr )

32import Rel8.Expr.Null ( isNull, isNonNull, null, nullify )

33import Rel8.Schema.Context.Nullify

34− ( Nullifiable, ConstrainTag

34+ ( Nullifiable

35− , HNullifiable, HConstrainTag

35+ , encodeTag, decodeTag

36− , hencodeTag, hdecodeTag

36+ , nullifier, unnullifier

37− , hnullifier, hunnullifier

38 )

37 )

39−import Rel8.Schema.HTable ( HTable )

38+import Rel8.Schema.Dict ( Dict( Dict ) )

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

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

41import Rel8.Schema.HTable.Label ( hlabel, hunlabel )

40import Rel8.Schema.HTable.Label ( hlabel, hunlabel )

42import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )

41import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )

@@ -129,32 +128,51 @@ instance (Table Expr a, Semigroup a) => Monoid (MaybeTable a) where

129instance

128instance

130 ( Table context a

129 ( Table context a

131 , Nullifiable context

130 , Nullifiable context

132− , ConstrainTag context MaybeTag

131+ )

133− ) => Table context (MaybeTable a)

132+ => Table context (MaybeTable a)

134 where

133 where

135 type Columns (MaybeTable a) = HMaybeTable (Columns a)

134 type Columns (MaybeTable a) = HMaybeTable (Columns a)

136 type Context (MaybeTable a) = Context a

135 type Context (MaybeTable a) = Context a

137

136

138− toColumns = toColumns1 toColumns

137+ toColumns MaybeTable {tag, just} = HMaybeTable

139− fromColumns = fromColumns1 fromColumns

138+ { htag

139+ , hjust = hlabel $ hnullify (nullifier tag isNonNull) $ toColumns just

140+ }

141+ where

142+ htag = hlabel (HType (encodeTag tag))

143+

144+ fromColumns HMaybeTable {htag, hjust} = MaybeTable

145+ { tag

146+ , just = fromColumns $ runIdentity $

147+ hunnullify (\a -> pure . unnullifier a) (hunlabel hjust)

148+ }

149+ where

150+ tag = decodeTag (unHIdentity (hunlabel htag))

151+

140 reify = fmap fmap reify

152 reify = fmap fmap reify

141 unreify = fmap fmap unreify

153 unreify = fmap fmap unreify

142

154

143

155

144instance

156instance

145− ( Nullifiable from, ConstrainTag from MaybeTag

157+ ( Nullifiable from

146− , Nullifiable to, ConstrainTag to MaybeTag

158+ , Nullifiable to

147 , Recontextualize from to a b

159 , Recontextualize from to a b

148 )

160 )

149 => Recontextualize from to (MaybeTable a) (MaybeTable b)

161 => Recontextualize from to (MaybeTable a) (MaybeTable b)

150

162

151

163

152instance EqTable a => EqTable (MaybeTable a) where

164instance EqTable a => EqTable (MaybeTable a) where

153− eqTable = toColumns1 id (justTable (eqTable @a))

165+ eqTable = HMaybeTable

166+ { htag = hlabel (HType Dict)

167+ , hjust = hlabel (hnullify (\_ Dict -> Dict) (eqTable @a))

168+ }

154

169

155

170

156instance OrdTable a => OrdTable (MaybeTable a) where

171instance OrdTable a => OrdTable (MaybeTable a) where

157− ordTable = toColumns1 id (justTable (ordTable @a))

172+ ordTable = HMaybeTable

173+ { htag = hlabel (HType Dict)

174+ , hjust = hlabel (hnullify (\_ Dict -> Dict) (ordTable @a))

175+ }

158

176

159

177

160type instance FromExprs (MaybeTable a) = Maybe (FromExprs a)

178type instance FromExprs (MaybeTable a) = Maybe (FromExprs a)

@@ -214,36 +232,3 @@ nameMaybeTable

214 -- ^ Names of the columns in @a@.

232 -- ^ Names of the columns in @a@.

215 -> MaybeTable a

233 -> MaybeTable a

216nameMaybeTable = MaybeTable . fromName

234nameMaybeTable = MaybeTable . fromName

217−

218−

219−toColumns1 ::

220− ( HTable t

221− , HConstrainTag context MaybeTag

222− , HNullifiable context

223− )

224− => (a -> t context)

225− -> MaybeTable a

226− -> HMaybeTable t context

227−toColumns1 f MaybeTable {tag, just} = HMaybeTable

228− { htag

229− , hjust = hlabel $ hnullify (hnullifier tag isNonNull) $ f just

230− }

231− where

232− htag = hlabel (HType (hencodeTag tag))

233−

234−

235−fromColumns1 ::

236− ( HTable t

237− , HConstrainTag context MaybeTag

238− , HNullifiable context

239− )

240− => (t context -> a)

241− -> HMaybeTable t context

242− -> MaybeTable a

243−fromColumns1 f HMaybeTable {htag, hjust} = MaybeTable

244− { tag

245− , just = f $ runIdentity $

246− hunnullify (\a -> pure . hunnullifier a) (hunlabel hjust)

247− }

248− where

249− tag = hdecodeTag (unHIdentity (hunlabel htag))

src/Rel8/Table/NonEmpty.hs+6−9

@@ -31,7 +31,6 @@ import Rel8.Schema.Name ( Col( N ), Name( Name ) )

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

32import Rel8.Schema.Reify ( hreify, hunreify )

33import Rel8.Schema.Spec ( SSpec(..) )

34−import Rel8.Schema.Spec.ConstrainDBType ( dbTypeDict, dbTypeNullity )

35import Rel8.Table

34import Rel8.Table

36 ( Table, Context, Columns, fromColumns, toColumns

35 ( Table, Context, Columns, fromColumns, toColumns

37 , reify, unreify

36 , reify, unreify

@@ -74,20 +73,18 @@ instance

74instance EqTable a => EqTable (NonEmptyTable a) where

73instance EqTable a => EqTable (NonEmptyTable a) where

75 eqTable =

74 eqTable =

76 hvectorize

75 hvectorize

77− (\SSpec {} (Identity dict) -> case dbTypeDict dict of

76+ (\SSpec {nullity} (Identity Dict) -> case nullity of

78− Dict -> case dbTypeNullity dict of

79− Null -> Dict

77+ Null -> Dict

80− NotNull -> Dict)

78+ NotNull -> Dict)

81 (Identity (eqTable @a))

79 (Identity (eqTable @a))

82

80

83

81

84instance OrdTable a => OrdTable (NonEmptyTable a) where

82instance OrdTable a => OrdTable (NonEmptyTable a) where

85 ordTable =

83 ordTable =

86 hvectorize

84 hvectorize

87− (\SSpec {} (Identity dict) -> case dbTypeDict dict of

85+ (\SSpec {nullity} (Identity Dict) -> case nullity of

88− Dict -> case dbTypeNullity dict of

89− Null -> Dict

86+ Null -> Dict

90− NotNull -> Dict)

87+ NotNull -> Dict)

91 (Identity (ordTable @a))

88 (Identity (ordTable @a))

92

89

93

90

src/Rel8/Table/Ord.hs+8−8

@@ -43,7 +43,7 @@ import Rel8.Schema.HTable

43 )

44import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )

45import Rel8.Schema.Null (Sql)

46−import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType, nullifier )

46+import Rel8.Schema.Spec.Constrain ( ConstrainSpec )

47import Rel8.Table ( Columns, toColumns, TColumns )

48import Rel8.Table.Bool ( bool )

49import Rel8.Table.Eq ( EqTable )

@@ -56,14 +56,14 @@ import Rel8.Type.Ord ( DBOrd )

56-- columns in a 'Table' have an instance of 'DBOrd'".

57type OrdTable :: Type -> Constraint

58class EqTable a => OrdTable a where

59− ordTable :: Columns a (Dict (ConstrainDBType DBOrd))

59+ ordTable :: Columns a (Dict (ConstrainSpec (Sql DBOrd)))

60

61 default ordTable ::

62 ( KnownAlgebra (GAlgebra (Rep (Record a)))

63− , Eval (GGTable (GAlgebra (Rep (Record a))) TOrdTable TColumns (Dict (ConstrainDBType DBOrd)) (Rep (Record a)))

63+ , Eval (GGTable (GAlgebra (Rep (Record a))) TOrdTable TColumns (Dict (ConstrainSpec (Sql DBOrd))) (Rep (Record a)))

64 , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))

65 )

66− => Columns a (Dict (ConstrainDBType DBOrd))

66+ => Columns a (Dict (ConstrainSpec (Sql DBOrd)))

67 ordTable =

68 ggtable

69 @(GAlgebra (Rep (Record a)))

@@ -71,7 +71,7 @@ class EqTable a => OrdTable a where

71 @TColumns

72 @(Rep (Record a))

73 table

74− nullifier

74+ (\_ Dict -> Dict)

75 where

76 table (_ :: proxy x) = ordTable @x

77

@@ -83,12 +83,12 @@ type instance Eval (TOrdTable a) = OrdTable a

83instance

84 ( HTable t

85 , f ~ Col Expr

86− , HConstrainTable t (ConstrainDBType DBEq)

86+ , HConstrainTable t (ConstrainSpec (Sql DBEq))

87− , HConstrainTable t (ConstrainDBType DBOrd)

87+ , HConstrainTable t (ConstrainSpec (Sql DBOrd))

88 )

89 => OrdTable (t f)

90 where

91− ordTable = hdicts @(Columns (t f)) @(ConstrainDBType DBOrd)

91+ ordTable = hdicts @(Columns (t f)) @(ConstrainSpec (Sql DBOrd))

92

93

94instance Sql DBOrd a => OrdTable (Expr a) where

src/Rel8/Table/Order.hs+13−15

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

1{-# language DataKinds #-}

2+{-# language NamedFieldPuns #-}

2{-# language ScopedTypeVariables #-}

3{-# language ScopedTypeVariables #-}

3{-# language TypeApplications #-}

4{-# language TypeApplications #-}

4{-# language TypeFamilies #-}

5{-# language TypeFamilies #-}

@@ -21,10 +22,9 @@ import Rel8.Order ( Order )

21import Rel8.Schema.Dict ( Dict( Dict ) )

22import Rel8.Schema.Dict ( Dict( Dict ) )

22import Rel8.Schema.HTable (htabulateA, hfield, hspecs)

23import Rel8.Schema.HTable (htabulateA, hfield, hspecs)

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

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

24−import Rel8.Schema.Spec ( SSpec( SSpec ) )

25+import Rel8.Schema.Spec ( SSpec( SSpec, nullity ) )

25−import Rel8.Schema.Spec.ConstrainDBType ( dbTypeDict, dbTypeNullity )

26import Rel8.Table ( Columns, toColumns )

27−import Rel8.Table.Ord

27+import Rel8.Table.Ord ( OrdTable, ordTable )

28

29

30-- | Construct an 'Order' for a 'Table' by sorting all columns into ascending

@@ -32,12 +32,11 @@ import Rel8.Table.Ord

32ascTable :: forall a. OrdTable a => Order a

33ascTable = contramap toColumns $ getConst $

34 htabulateA @(Columns a) $ \field -> case hfield hspecs field of

35− SSpec {} -> case hfield (ordTable @a) field of

35+ SSpec {nullity} -> case hfield (ordTable @a) field of

36− dict@Dict -> case dbTypeDict dict of

37− Dict -> Const $ unE . (`hfield` field) >$<

36+ Dict -> Const $ unE . (`hfield` field) >$<

38− case dbTypeNullity dict of

37+ case nullity of

39− Null -> nullsFirst asc

38+ Null -> nullsFirst asc

40− NotNull -> asc

39+ NotNull -> asc

41

40

42

41

43-- | Construct an 'Order' for a 'Table' by sorting all columns into descending

42-- | Construct an 'Order' for a 'Table' by sorting all columns into descending

@@ -45,9 +44,8 @@ ascTable = contramap toColumns $ getConst $

45descTable :: forall a. OrdTable a => Order a

44descTable :: forall a. OrdTable a => Order a

46descTable = contramap toColumns $ getConst $

45descTable = contramap toColumns $ getConst $

47 htabulateA @(Columns a) $ \field -> case hfield hspecs field of

46 htabulateA @(Columns a) $ \field -> case hfield hspecs field of

48− SSpec {} -> case hfield (ordTable @a) field of

47+ SSpec {nullity} -> case hfield (ordTable @a) field of

49− dict@Dict -> case dbTypeDict dict of

50− Dict -> Const $ unE . (`hfield` field) >$<

48+ Dict -> Const $ unE . (`hfield` field) >$<

51− case dbTypeNullity dict of

49+ case nullity of

52− Null -> nullsLast desc

50+ Null -> nullsLast desc

53− NotNull -> desc

51+ NotNull -> desc

src/Rel8/Table/Rel8able.hs+7−6

@@ -36,13 +36,14 @@ import Rel8.Schema.Context ( Col )

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

37import qualified Rel8.Schema.Kind as K

38import Rel8.Schema.HTable ( HConstrainTable, hdicts )

39+import Rel8.Schema.Null ( Sql )

39import Rel8.Schema.Reify ( hreify, hunreify, UnwrapReify )

40import Rel8.Schema.Reify ( hreify, hunreify, UnwrapReify )

40import Rel8.Schema.Result ( Result )

41import Rel8.Schema.Result ( Result )

41import Rel8.Table

42import Rel8.Table

42 ( Table, Columns, Context, Congruent, fromColumns, toColumns

43 ( Table, Columns, Context, Congruent, fromColumns, toColumns

43 , Unreify, reify, unreify

44 , Unreify, reify, unreify

44 )

45 )

45−import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )

46+import Rel8.Schema.Spec.Constrain ( ConstrainSpec )

46import Rel8.Table.ADT ( ADT( ADT ), ADTable, fromADT, toADT )

47import Rel8.Table.ADT ( ADT( ADT ), ADTable, fromADT, toADT )

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

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

48import Rel8.Table.HKD ( HKD )

49import Rel8.Table.HKD ( HKD )

@@ -84,22 +85,22 @@ instance

84instance

85instance

85 ( context ~ Expr

86 ( context ~ Expr

86 , Rel8able t

87 , Rel8able t

87− , HConstrainTable (Columns (t context)) (ConstrainDBType DBEq)

88+ , HConstrainTable (Columns (t context)) (ConstrainSpec (Sql DBEq))

88 )

89 )

89 => EqTable (t context)

90 => EqTable (t context)

90 where

91 where

91− eqTable = hdicts @(Columns (t context)) @(ConstrainDBType DBEq)

92+ eqTable = hdicts @(Columns (t context)) @(ConstrainSpec (Sql DBEq))

92

93

94

94instance

95instance

95 ( context ~ Expr

96 ( context ~ Expr

96 , Rel8able t

97 , Rel8able t

97− , HConstrainTable (Columns (t context)) (ConstrainDBType DBEq)

98+ , HConstrainTable (Columns (t context)) (ConstrainSpec (Sql DBEq))

98− , HConstrainTable (Columns (t context)) (ConstrainDBType DBOrd)

99+ , HConstrainTable (Columns (t context)) (ConstrainSpec (Sql DBOrd))

99 )

100 )

100 => OrdTable (t context)

101 => OrdTable (t context)

101 where

102 where

102− ordTable = hdicts @(Columns (t context)) @(ConstrainDBType DBOrd)

103+ ordTable = hdicts @(Columns (t context)) @(ConstrainSpec (Sql DBOrd))

103

104

105

105type instance FromExprs (t Expr) = FromExprs' t

106type instance FromExprs (t Expr) = FromExprs' t

src/Rel8/Table/These.hs+63−73

@@ -37,12 +37,11 @@ import Rel8.Expr ( Expr )

37import Rel8.Expr.Bool ( (&&.), not_ )

38import Rel8.Expr.Null ( isNonNull )

39import Rel8.Schema.Context.Nullify

40− ( Nullifiable, ConstrainTag

40+ ( Nullifiable

41− , HNullifiable, HConstrainTag

41+ , encodeTag, decodeTag

42− , hencodeTag, hdecodeTag

42+ , nullifier, unnullifier

43− , hnullifier, hunnullifier

44 )

43 )

45−import Rel8.Schema.HTable ( HTable )

44+import Rel8.Schema.Dict ( Dict( Dict ) )

46import Rel8.Schema.HTable.Label ( hlabel, hunlabel )

45import Rel8.Schema.HTable.Label ( hlabel, hunlabel )

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

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

48import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )

47import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )

@@ -132,33 +131,82 @@ instance (Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>

132

131

133instance

132instance

134 ( Table context a, Table context b

133 ( Table context a, Table context b

135− , Nullifiable context, ConstrainTag context MaybeTag

134+ , Nullifiable context

135+ )

136− ) => Table context (TheseTable a b)

136+ => Table context (TheseTable a b)

137 where

138 type Columns (TheseTable a b) = HTheseTable (Columns a) (Columns b)

139 type Context (TheseTable a b) = Context a

140

141− toColumns = toColumns2 toColumns toColumns

141+ toColumns TheseTable {here, there} = HTheseTable

142− fromColumns = fromColumns2 fromColumns fromColumns

142+ { hhereTag = hlabel $ HType $ encodeTag (toHereTag (tag here))

143+ , hhere =

144+ hlabel $ hnullify (nullifier (tag here) isNonNull) $ toColumns $

145+ just here

146+ , hthereTag = hlabel $ HType $ encodeTag (toThereTag (tag there))

147+ , hthere =

148+ hlabel $ hnullify (nullifier (tag there) isNonNull) $ toColumns $

149+ just there

150+ }

151+

152+ fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable

153+ { here =

154+ let

155+ tag = decodeTag $ unHIdentity $ hunlabel hhereTag

156+ in

157+ MaybeTable

158+ { tag

159+ , just =

160+ fromColumns $

161+ runIdentity $

162+ hunnullify (\a -> pure . unnullifier a) $

163+ hunlabel

164+ hhere

165+ }

166+ , there =

167+ let

168+ tag = decodeTag $ unHIdentity $ hunlabel hthereTag

169+ in

170+ MaybeTable

171+ { tag

172+ , just =

173+ fromColumns $

174+ runIdentity $

175+ hunnullify (\a -> pure . unnullifier a) $

176+ hunlabel

177+ hthere

178+ }

179+ }

180+

181+

143 reify = liftA2 bimap reify reify

182 reify = liftA2 bimap reify reify

144 unreify = liftA2 bimap unreify unreify

183 unreify = liftA2 bimap unreify unreify

145

184

146

185

147instance

186instance

148− ( Nullifiable from, ConstrainTag from MaybeTag

187+ ( Nullifiable from, Nullifiable to

149− , Nullifiable to, ConstrainTag to MaybeTag

150 , Recontextualize from to a1 b1

188 , Recontextualize from to a1 b1

151 , Recontextualize from to a2 b2

189 , Recontextualize from to a2 b2

152− ) =>

190+ )

153− Recontextualize from to (TheseTable a1 a2) (TheseTable b1 b2)

191+ => Recontextualize from to (TheseTable a1 a2) (TheseTable b1 b2)

154

192

155

193

156instance (EqTable a, EqTable b) => EqTable (TheseTable a b) where

194instance (EqTable a, EqTable b) => EqTable (TheseTable a b) where

157− eqTable = toColumns2 id id (thoseTable (eqTable @a) (eqTable @b))

195+ eqTable = HTheseTable

196+ { hhereTag = hlabel (HType Dict)

197+ , hhere = hlabel (hnullify (\_ Dict -> Dict) (eqTable @a))

198+ , hthereTag = hlabel (HType Dict)

199+ , hthere = hlabel (hnullify (\_ Dict -> Dict) (eqTable @b))

200+ }

158

201

159

202

160instance (OrdTable a, OrdTable b) => OrdTable (TheseTable a b) where

203instance (OrdTable a, OrdTable b) => OrdTable (TheseTable a b) where

161− ordTable = toColumns2 id id (thoseTable (ordTable @a) (ordTable @b))

204+ ordTable = HTheseTable

205+ { hhereTag = hlabel (HType Dict)

206+ , hhere = hlabel (hnullify (\_ Dict -> Dict) (ordTable @a))

207+ , hthereTag = hlabel (HType Dict)

208+ , hthere = hlabel (hnullify (\_ Dict -> Dict) (ordTable @b))

209+ }

162

210

163

211

164type instance FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)

212type instance FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)

@@ -275,61 +323,3 @@ nameTheseTable here there a b =

275 { here = nameMaybeTable here a

323 { here = nameMaybeTable here a

276 , there = nameMaybeTable there b

324 , there = nameMaybeTable there b

277 }

325 }

278−

279−

280−toColumns2 ::

281− ( HTable t

282− , HTable u

283− , HConstrainTag context MaybeTag

284− , HNullifiable context

285− )

286− => (a -> t context)

287− -> (b -> u context)

288− -> TheseTable a b

289− -> HTheseTable t u context

290−toColumns2 f g TheseTable {here, there} = HTheseTable

291− { hhereTag = hlabel $ HType $ hencodeTag (toHereTag (tag here))

292− , hhere =

293− hlabel $ hnullify (hnullifier (tag here) isNonNull) $ f (just here)

294− , hthereTag = hlabel $ HType $ hencodeTag (toThereTag (tag there))

295− , hthere =

296− hlabel $ hnullify (hnullifier (tag there) isNonNull) $ g (just there)

297− }

298−

299−

300−fromColumns2 ::

301− ( HTable t

302− , HTable u

303− , HConstrainTag context MaybeTag

304− , HNullifiable context

305− )

306− => (t context -> a)

307− -> (u context -> b)

308− -> HTheseTable t u context

309− -> TheseTable a b

310−fromColumns2 f g HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable

311− { here =

312− let

313− tag = hdecodeTag $ unHIdentity $ hunlabel hhereTag

314− in

315− MaybeTable

316− { tag

317− , just = f $

318− runIdentity $

319− hunnullify (\a -> pure . hunnullifier a) $

320− hunlabel

321− hhere

322− }

323− , there =

324− let

325− tag = hdecodeTag $ unHIdentity $ hunlabel hthereTag

326− in

327− MaybeTable

328− { tag

329− , just = g $

330− runIdentity $

331− hunnullify (\a -> pure . hunnullifier a) $

332− hunlabel

333− hthere

334− }

335− }