5824baa · rel8 · git.iko.soy

git.iko.soy/rel8

on master help sign in

Parameterise Insertion by necessity

5824baaShane O'Brien5 years ago

src/Rel8/Column/Field.hs+16−11

compare with master

unifiedsplit

@@ -24,7 +24,7 @@ import Rel8.Kind.Necessity

24 , KnownNecessity, necessitySing

25 )

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

27−import Rel8.Schema.Insert ( Insert, Col(..) )

27+import Rel8.Schema.Insert ( Insert, Insertion(..), Col(..) )

28import qualified Rel8.Schema.Kind as K

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

30import Rel8.Schema.Null ( Sql )

@@ -61,7 +61,7 @@ instance (Reifiable context, KnownNecessity necessity, Sql DBType a) =>

61 type Columns (AField context necessity a) = HIdentity ('Spec '[] necessity a)

62 type Unreify (AField context necessity a) = Field context necessity a

64− fromColumns (HIdentity (Reify a)) = sfromColumn contextSing a

64+ fromColumns (HIdentity (Reify a)) = sfromColumn contextSing necessitySing a

65 toColumns = HIdentity . Reify . stoColumn contextSing necessitySing

66 reify _ = AField

67 unreify _ (AField a) = a

@@ -80,17 +80,22 @@ instance

81sfromColumn :: ()

82 => SContext context

83+ -> SNecessity necessity

83 -> Col context ('Spec labels necessity a)

84 -> Col context ('Spec labels necessity a)

84 -> AField context necessity a

85 -> AField context necessity a

85sfromColumn = \case

86sfromColumn = \case

86− SAggregate -> \(Aggregation a) -> AField a

87+ SAggregate -> \_ (Aggregation a) -> AField a

87− SExpr -> \(DB a) -> AField a

88+ SExpr -> \_ (DB a) -> AField a

88− SResult -> \(Result a) -> AField a

89+ SResult -> \_ (Result a) -> AField a

89 SInsert -> \case

90 SInsert -> \case

90− RequiredInsert a -> AField a

91+ SRequired -> \case

91− OptionalInsert a -> AField a

92+ InsertCol (Insertion a) -> AField a

93+ SOptional -> \case

94+ InsertCol Default -> AField Nothing

95+ InsertCol (Insertion a) -> AField (Just a)

92− SName -> \(NameCol a) -> AField (Name a)

96+ SName -> \_ (NameCol a) -> AField (Name a)

97+ SReify context ->

93− SReify context -> \(Reify a) -> AField (sfromColumn context a)

98+ \necessity (Reify a) -> AField (sfromColumn context necessity a)

100

96stoColumn :: ()

101stoColumn :: ()

@@ -103,8 +108,8 @@ stoColumn = \case

103 SExpr -> \_ (AField a) -> DB a

108 SExpr -> \_ (AField a) -> DB a

104 SResult -> \_ (AField a) -> Result a

109 SResult -> \_ (AField a) -> Result a

105 SInsert -> \case

110 SInsert -> \case

106− SRequired -> \(AField a) -> RequiredInsert a

111+ SRequired -> \(AField a) -> InsertCol (Insertion a)

107− SOptional -> \(AField a) -> OptionalInsert a

112+ SOptional -> \(AField ma) -> InsertCol $ maybe Default Insertion ma

108 SName -> \_ (AField (Name a)) -> NameCol a

113 SName -> \_ (AField (Name a)) -> NameCol a

109 SReify context ->

114 SReify context ->

110 \necessity (AField a) -> Reify (stoColumn context necessity a)

115 \necessity (AField a) -> Reify (stoColumn context necessity a)

src/Rel8/Generic/Construction.hs+6−9

@@ -61,15 +61,14 @@ import Rel8.Kind.Algebra

61 , KnownAlgebra, algebraSing

62 )

63import qualified Rel8.Kind.Algebra as K

64−import Rel8.Kind.Necessity ( SNecessity( SOptional, SRequired ) )

65import Rel8.Schema.Context.Nullify ( runTag )

64import Rel8.Schema.Context.Nullify ( runTag )

66import Rel8.Schema.HTable ( HTable )

65import Rel8.Schema.HTable ( HTable )

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

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

68−import Rel8.Schema.Insert ( Col( OptionalInsert, RequiredInsert ), Insert )

67+import Rel8.Schema.Insert ( Col( InsertCol ), Insert, Insertion(..) )

69import qualified Rel8.Schema.Kind as K

68import qualified Rel8.Schema.Kind as K

70import Rel8.Schema.Name ( Col( NameCol ), Name( Name ) )

69import Rel8.Schema.Name ( Col( NameCol ), Name( Name ) )

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

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

72−import Rel8.Schema.Spec ( SSpec( SSpec, necessity, nullity, info ) )

71+import Rel8.Schema.Spec ( SSpec( SSpec, nullity, info ) )

73import Rel8.Schema.Reify ( Col( Reify ), Reify, hreify, hunreify )

72import Rel8.Schema.Reify ( Col( Reify ), Reify, hreify, hunreify )

74import Rel8.Schema.Result ( Result )

73import Rel8.Schema.Result ( Result )

75import Rel8.Table

74import Rel8.Table

@@ -190,15 +189,13 @@ gginsert gfromColumns = case algebraSing @algebra of

190 @name

189 @name

191 @(Eval (rep (Reify Insert)))

190 @(Eval (rep (Reify Insert)))

192 (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)

191 (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)

193− (\SSpec {necessity, info} -> Reify $ case necessity of

192+ (\SSpec {info} -> Reify $ InsertCol (Insertion (snull info)))

194− SRequired -> RequiredInsert (snull info)

195− SOptional -> OptionalInsert (Just (snull info)))

196 (\SSpec {nullity} -> case nullity of

193 (\SSpec {nullity} -> case nullity of

197 Null -> id

194 Null -> id

198 NotNull -> \case

195 NotNull -> \case

199− Reify (RequiredInsert a) -> Reify (RequiredInsert (nullify a))

196+ Reify (InsertCol Default) -> Reify (InsertCol Default)

200− Reify (OptionalInsert a) -> Reify (OptionalInsert (nullify <$> a)))

197+ Reify (InsertCol (Insertion a)) -> Reify (InsertCol (Insertion (nullify a))))

201− (HType . Reify . RequiredInsert . litExpr)

198+ (HType . Reify . InsertCol . Insertion . litExpr)

202

199

203

200

204type GGConstructable :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Constraint

201type GGConstructable :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Constraint

src/Rel8/Schema/Insert.hs+34−36

@@ -15,7 +15,7 @@

15module Rel8.Schema.Insert

16 ( Insert(..)

17 , OnConflict(..)

18− , Col( RequiredInsert, OptionalInsert )

18+ , Col( InsertCol )

19 , Inserts

20 , Insertion(..)

21 )

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

29-- rel8

30import Rel8.Aggregate ( Aggregate )

31import Rel8.Expr ( Expr )

32−import Rel8.Kind.Necessity ( Necessity(Optional, Required) )

32+import Rel8.Kind.Necessity ( Necessity(Optional, Required), KnownNecessity )

33import Rel8.Schema.Context ( Interpretation(..) )

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

35import Rel8.Schema.Context.Nullify

36 ( Nullifiable, encodeTag, decodeTag, nullifier, unnullifier

37 , runTag, unnull

38 )

39−import Rel8.Schema.HTable.Identity ( HIdentity( HType ), HType )

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

40import Rel8.Schema.Name ( Name, Selects )

41import Rel8.Schema.Null ( Sql )

42import Rel8.Schema.Reify ( notReify )

@@ -79,80 +79,78 @@ data Insert a where

80instance Interpretation Insert where

81 data Col Insert _spec where

82− RequiredInsert :: Expr a -> Col Insert ('Spec labels 'Required a)

82+ InsertCol :: Insertion necessity a -> Col Insert ('Spec labels necessity a)

83− OptionalInsert :: Maybe (Expr a) -> Col Insert ('Spec labels 'Optional a)

86−type Insertion :: Type -> Type

85+type Insertion :: Necessity -> Type -> Type

87−newtype Insertion a = Insertion (Expr a)

86+data Insertion necessity a where

87+ Default :: Insertion 'Optional a

88+ Insertion :: Expr a -> Insertion necessity a

91+instance (KnownNecessity necessity, Sql DBType a) =>

90−instance Sql DBType a => Table Insert (Insertion a) where

92+ Table Insert (Insertion necessity a)

93+ where

91− type Columns (Insertion a) = HType a

94+ type Columns (Insertion necessity a) = HIdentity ('Spec '[] necessity a)

92− type Context (Insertion a) = Insert

95+ type Context (Insertion necessity a) = Insert

94− toColumns (Insertion a) = HType (RequiredInsert a)

97+ toColumns = HIdentity . InsertCol

95− fromColumns (HType (RequiredInsert a)) = Insertion a

98+ fromColumns (HIdentity (InsertCol a)) = a

96 reify = notReify

99 reify = notReify

97 unreify = notReify

100 unreify = notReify

101

102

100instance Sql DBType a =>

103instance Sql DBType a =>

101− Recontextualize Aggregate Insert (Aggregate (Expr a)) (Insertion a)

104+ Recontextualize Aggregate Insert (Aggregate (Expr a)) (Insertion 'Required a)

102

105

103

106

104−instance Sql DBType a => Recontextualize Expr Insert (Expr a) (Insertion a)

107+instance Sql DBType a => Recontextualize Expr Insert (Expr a) (Insertion 'Required a)

105

108

106

109

107instance Sql DBType a =>

110instance Sql DBType a =>

108− Recontextualize Result Insert (Identity a) (Insertion a)

111+ Recontextualize Result Insert (Identity a) (Insertion 'Required a)

109

112

110

113

111instance Sql DBType a =>

114instance Sql DBType a =>

112− Recontextualize Insert Aggregate (Insertion a) (Aggregate (Expr a))

115+ Recontextualize Insert Aggregate (Insertion 'Required a) (Aggregate (Expr a))

113

116

114

117

115−instance Sql DBType a => Recontextualize Insert Expr (Insertion a) (Expr a)

118+instance Sql DBType a => Recontextualize Insert Expr (Insertion 'Required a) (Expr a)

116

119

117

120

118instance Sql DBType a =>

121instance Sql DBType a =>

119− Recontextualize Insert Result (Insertion a) (Identity a)

122+ Recontextualize Insert Result (Insertion 'Required a) (Identity a)

120

123

121

124

122−instance Sql DBType a => Recontextualize Insert Insert (Insertion a) (Insertion a)

125+instance Sql DBType a => Recontextualize Insert Insert (Insertion 'Required a) (Insertion 'Required a)

123

126

124

127

125−instance Sql DBType a => Recontextualize Insert Name (Insertion a) (Name a)

128+instance Sql DBType a => Recontextualize Insert Name (Insertion 'Required a) (Name a)

126

129

127

130

128−instance Sql DBType a => Recontextualize Name Insert (Name a) (Insertion a)

131+instance Sql DBType a => Recontextualize Name Insert (Name a) (Insertion 'Required a)

129

132

130

133

131instance Labelable Insert where

134instance Labelable Insert where

132− labeler = \case

135+ labeler (InsertCol a) = InsertCol a

133− RequiredInsert a -> RequiredInsert a

134− OptionalInsert ma -> OptionalInsert ma

135−

136− unlabeler = \case

136+ unlabeler (InsertCol a) = InsertCol a

137− RequiredInsert a -> RequiredInsert a

138− OptionalInsert ma -> OptionalInsert ma

139

137

140

138

141instance Nullifiable Insert where

139instance Nullifiable Insert where

142− encodeTag = RequiredInsert . expr

140+ encodeTag = InsertCol . Insertion . expr

141+

143− decodeTag (RequiredInsert a) = fromExpr a

142+ decodeTag (InsertCol (Insertion a)) = fromExpr a

144

143

145 nullifier Tag {expr} test SSpec {nullity} = \case

144 nullifier Tag {expr} test SSpec {nullity} = \case

146− RequiredInsert a ->

145+ InsertCol Default -> InsertCol Default

147− RequiredInsert $ runTag nullity condition a

146+ InsertCol (Insertion a) ->

148− OptionalInsert ma ->

149− OptionalInsert $ runTag nullity condition <$> ma

147+ InsertCol $ Insertion $ runTag nullity condition a

150 where

148 where

151 condition = test expr

149 condition = test expr

152

150

153 unnullifier SSpec {nullity} = \case

151 unnullifier SSpec {nullity} = \case

154− RequiredInsert a -> RequiredInsert $ unnull nullity a

152+ InsertCol Default -> InsertCol Default

155− OptionalInsert ma -> OptionalInsert $ unnull nullity <$> ma

153+ InsertCol (Insertion a) -> InsertCol $ Insertion $ unnull nullity a

156

154

157 {-# INLINABLE encodeTag #-}

155 {-# INLINABLE encodeTag #-}

158 {-# INLINABLE decodeTag #-}

156 {-# INLINABLE decodeTag #-}

src/Rel8/Table/Insert.hs+6−8

@@ -16,7 +16,7 @@ import Prelude

16import Rel8.Expr ( Col(..) )

17import Rel8.Kind.Necessity ( SNecessity( SOptional, SRequired ) )

18import Rel8.Schema.HTable ( hfield, htabulate, hspecs )

19−import Rel8.Schema.Insert ( Inserts, Col(..) )

19+import Rel8.Schema.Insert ( Inserts, Col( InsertCol ), Insertion(..) )

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

21import Rel8.Table ( fromColumns, toColumns )

@@ -28,10 +28,8 @@ import Rel8.Table ( fromColumns, toColumns )

28toInsert :: Inserts exprs inserts => exprs -> inserts

29toInsert (toColumns -> exprs) = fromColumns $ htabulate $ \field ->

30 case hfield hspecs field of

31− SSpec {necessity} -> case hfield exprs field of

31+ SSpec {} -> InsertCol $ case hfield exprs field of

32− DB expr -> case necessity of

32+ DB expr -> Insertion expr

33− SRequired -> RequiredInsert expr

34− SOptional -> OptionalInsert (Just expr)

37-- | @toInsertDefaults@ converts a 'Table' of 'Expr's into a 'Table' that can

35-- | @toInsertDefaults@ converts a 'Table' of 'Expr's into a 'Table' that can

@@ -46,6 +44,6 @@ toInsertDefaults :: Inserts exprs inserts => exprs -> inserts

46toInsertDefaults (toColumns -> exprs) = fromColumns $ htabulate $ \field ->

44toInsertDefaults (toColumns -> exprs) = fromColumns $ htabulate $ \field ->

47 case hfield hspecs field of

45 case hfield hspecs field of

48 SSpec {necessity} -> case hfield exprs field of

46 SSpec {necessity} -> case hfield exprs field of

49− DB expr -> case necessity of

47+ DB expr -> InsertCol $ case necessity of

50− SRequired -> RequiredInsert expr

48+ SRequired -> Insertion expr

51− SOptional -> OptionalInsert Nothing

49+ SOptional -> Default

src/Rel8/Table/Opaleye.hs+8−3

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

1{-# language BlockArguments #-}

2{-# language DisambiguateRecordFields #-}

3{-# language FlexibleContexts #-}

4+{-# language LambdaCase #-}

4{-# language NamedFieldPuns #-}

5{-# language NamedFieldPuns #-}

5{-# language TypeFamilies #-}

6{-# language TypeFamilies #-}

6{-# language ViewPatterns #-}

7{-# language ViewPatterns #-}

@@ -44,7 +45,7 @@ import Rel8.Expr.Opaleye

44 )

45 )

45import Rel8.Kind.Necessity ( SNecessity( SRequired, SOptional ) )

46import Rel8.Kind.Necessity ( SNecessity( SRequired, SOptional ) )

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

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

47−import Rel8.Schema.Insert ( Insert, Inserts, Col(..) )

48+import Rel8.Schema.Insert ( Insert, Inserts, Col( InsertCol ), Insertion(..) )

48import Rel8.Schema.Name ( Name, Selects, Col(..) )

49import Rel8.Schema.Name ( Name, Selects, Col(..) )

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

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

50import Rel8.Schema.Table ( TableSchema(..) )

51import Rel8.Schema.Table ( TableSchema(..) )

@@ -98,13 +99,17 @@ tableFields (toColumns -> names) = dimap toColumns fromColumns $

98 go :: SSpec spec -> Col Name spec -> Opaleye.TableFields (Col Insert spec) (Col Expr spec)

99 go :: SSpec spec -> Col Name spec -> Opaleye.TableFields (Col Insert spec) (Col Expr spec)

99 go SSpec {necessity} (NameCol name) = case necessity of

100 go SSpec {necessity} (NameCol name) = case necessity of

100 SRequired ->

101 SRequired ->

101− lmap (\(RequiredInsert a) -> toColumn $ toPrimExpr a) $

102+ lmap (\(InsertCol (Insertion a)) -> toColumn $ toPrimExpr a) $

102 DB . fromPrimExpr . fromColumn <$>

103 DB . fromPrimExpr . fromColumn <$>

103 Opaleye.requiredTableField name

104 Opaleye.requiredTableField name

104 SOptional ->

105 SOptional ->

105− lmap (\(OptionalInsert ma) -> toColumn . toPrimExpr <$> ma) $

106+ lmap (\(InsertCol ma) -> toColumn . toPrimExpr <$> fromInsert ma) $

106 DB . fromPrimExpr . fromColumn <$>

107 DB . fromPrimExpr . fromColumn <$>

107 Opaleye.optionalTableField name

108 Opaleye.optionalTableField name

109+ where

110+ fromInsert = \case

111+ Default -> Nothing

112+ Insertion a -> Just a

108

113

109

114

110unpackspec :: Table Expr a => Opaleye.Unpackspec a a

115unpackspec :: Table Expr a => Opaleye.Unpackspec a a