5824baa · rel8 · git.iko.soy

git.iko.soy/rel8

Parameterise Insertion by necessity

commit5824baa5cc44f50289a70ab629e43b649573257f authorShane O'Brien <shane.obrien@circuithub.com> dateSun 13 Jun 2021, 16:01 (5 years ago) parent89ec060

5 files changed+70−67

compare with master

unifiedsplit

src/Rel8/Column/Field.hs+16−11 src/Rel8/Generic/Construction.hs+6−9 src/Rel8/Schema/Insert.hs+34−36 src/Rel8/Table/Insert.hs+6−8 src/Rel8/Table/Opaleye.hs+8−3

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

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

2424 , KnownNecessity, necessitySing

2525 )

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

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

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

2828import qualified Rel8.Schema.Kind as K

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

3030import Rel8.Schema.Null ( Sql )

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

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

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

6363

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

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

6565 toColumns = HIdentity . Reify . stoColumn contextSing necessitySing

6666 reify _ = AField

6767 unreify _ (AField a) = a

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

8080

8181sfromColumn :: ()

8282 => SContext context

83+ -> SNecessity necessity

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

8485 -> AField context necessity a

8586sfromColumn = \case

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

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

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

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

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

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

8990 SInsert -> \case

90− RequiredInsert a -> AField a

91− OptionalInsert a -> AField a

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

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

91+ SRequired -> \case

92+ InsertCol (Insertion a) -> AField a

93+ SOptional -> \case

94+ InsertCol Default -> AField Nothing

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

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

97+ SReify context ->

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

9499

95100

96101stoColumn :: ()

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

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

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

105110 SInsert -> \case

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

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

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

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

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

109114 SReify context ->

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

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

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

6161 , KnownAlgebra, algebraSing

6262 )

6363import qualified Rel8.Kind.Algebra as K

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

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

6665import Rel8.Schema.HTable ( HTable )

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

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

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

6968import qualified Rel8.Schema.Kind as K

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

7170import 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 ) )

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

7473import Rel8.Schema.Result ( Result )

7574import Rel8.Table

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

190189 @name

191190 @(Eval (rep (Reify Insert)))

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

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

194− SRequired -> RequiredInsert (snull info)

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

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

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

197194 Null -> id

198195 NotNull -> \case

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

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

201− (HType . Reify . RequiredInsert . litExpr)

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

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

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

202199

203200

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

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

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

1515module Rel8.Schema.Insert

1616 ( Insert(..)

1717 , OnConflict(..)

18− , Col( RequiredInsert, OptionalInsert )

18+ , Col( InsertCol )

1919 , Inserts

2020 , Insertion(..)

2121 )

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

2929-- rel8

3030import Rel8.Aggregate ( Aggregate )

3131import Rel8.Expr ( Expr )

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

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

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

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

3535import Rel8.Schema.Context.Nullify

3636 ( Nullifiable, encodeTag, decodeTag, nullifier, unnullifier

3737 , runTag, unnull

3838 )

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

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

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

4141import Rel8.Schema.Null ( Sql )

4242import Rel8.Schema.Reify ( notReify )

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

7979

8080instance Interpretation Insert where

8181 data Col Insert _spec where

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

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

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

8483

8584

86−type Insertion :: Type -> Type

87−newtype Insertion a = Insertion (Expr a)

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

86+data Insertion necessity a where

87+ Default :: Insertion 'Optional a

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

8889

8990

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

91− type Columns (Insertion a) = HType a

92− type Context (Insertion a) = Insert

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

92+ Table Insert (Insertion necessity a)

93+ where

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

95+ type Context (Insertion necessity a) = Insert

9396

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

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

97+ toColumns = HIdentity . InsertCol

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

9699 reify = notReify

97100 unreify = notReify

98101

99102

100103instance Sql DBType a =>

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

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

102105

103106

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)

105108

106109

107110instance Sql DBType a =>

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

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

109112

110113

111114instance Sql DBType a =>

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

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

113116

114117

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)

116119

117120

118121instance Sql DBType a =>

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

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

120123

121124

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)

123126

124127

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)

126129

127130

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)

129132

130133

131134instance Labelable Insert where

132− labeler = \case

133− RequiredInsert a -> RequiredInsert a

134− OptionalInsert ma -> OptionalInsert ma

135−

136− unlabeler = \case

137− RequiredInsert a -> RequiredInsert a

138− OptionalInsert ma -> OptionalInsert ma

135+ labeler (InsertCol a) = InsertCol a

136+ unlabeler (InsertCol a) = InsertCol a

139137

140138

141139instance Nullifiable Insert where

142− encodeTag = RequiredInsert . expr

143− decodeTag (RequiredInsert a) = fromExpr a

140+ encodeTag = InsertCol . Insertion . expr

141+

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

144143

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

146− RequiredInsert a ->

147− RequiredInsert $ runTag nullity condition a

148− OptionalInsert ma ->

149− OptionalInsert $ runTag nullity condition <$> ma

145+ InsertCol Default -> InsertCol Default

146+ InsertCol (Insertion a) ->

147+ InsertCol $ Insertion $ runTag nullity condition a

150148 where

151149 condition = test expr

152150

153151 unnullifier SSpec {nullity} = \case

154− RequiredInsert a -> RequiredInsert $ unnull nullity a

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

152+ InsertCol Default -> InsertCol Default

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

156154

157155 {-# INLINABLE encodeTag #-}

158156 {-# INLINABLE decodeTag #-}

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

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

1616import Rel8.Expr ( Col(..) )

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

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

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

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

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

2121import Rel8.Table ( fromColumns, toColumns )

2222

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

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

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

3030 case hfield hspecs field of

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

32− DB expr -> case necessity of

33− SRequired -> RequiredInsert expr

34− SOptional -> OptionalInsert (Just expr)

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

32+ DB expr -> Insertion expr

3533

3634

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

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

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

4745 case hfield hspecs field of

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

49− DB expr -> case necessity of

50− SRequired -> RequiredInsert expr

51− SOptional -> OptionalInsert Nothing

47+ DB expr -> InsertCol $ case necessity of

48+ SRequired -> Insertion expr

49+ SOptional -> Default

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

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

11{-# language BlockArguments #-}

22{-# language DisambiguateRecordFields #-}

33{-# language FlexibleContexts #-}

4+{-# language LambdaCase #-}

45{-# language NamedFieldPuns #-}

56{-# language TypeFamilies #-}

67{-# language ViewPatterns #-}

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

4445 )

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

4647import 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(..) )

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

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

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

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

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

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

100101 SRequired ->

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

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

102103 DB . fromPrimExpr . fromColumn <$>

103104 Opaleye.requiredTableField name

104105 SOptional ->

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

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

106107 DB . fromPrimExpr . fromColumn <$>

107108 Opaleye.optionalTableField name

109+ where

110+ fromInsert = \case

111+ Default -> Nothing

112+ Insertion a -> Just a

108113

109114

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