5e4df50 · rel8 · git.iko.soy

git.iko.soy/rel8

on master help sign in

Complete overhaul of Rel8.Schema.Generic

5e4df50Shane O'Brien6 years ago

rel8.cabal+1−4

compare with master

unifiedsplit

@@ -87,7 +87,6 @@ library

88 Rel8.Schema.Column

89 Rel8.Schema.Context

90− Rel8.Schema.Context.Identity

91 Rel8.Schema.Context.Label

90 Rel8.Schema.Context.Label

92 Rel8.Schema.Context.Nullify

91 Rel8.Schema.Context.Nullify

93 Rel8.Schema.Dict

92 Rel8.Schema.Dict

@@ -117,6 +116,7 @@ library

117 Rel8.Schema.Spec

116 Rel8.Schema.Spec

118 Rel8.Schema.Spec.ConstrainDBType

117 Rel8.Schema.Spec.ConstrainDBType

119 Rel8.Schema.Spec.ConstrainType

118 Rel8.Schema.Spec.ConstrainType

119+ Rel8.Schema.Structure

120 Rel8.Schema.Table

121

122 Rel8.Statement.Delete

@@ -133,7 +133,6 @@ library

133 Rel8.Table.Either

134 Rel8.Table.Eq

135 Rel8.Table.Insert

136− Rel8.Table.Lifted

137 Rel8.Table.List

136 Rel8.Table.List

138 Rel8.Table.Maybe

137 Rel8.Table.Maybe

139 Rel8.Table.Name

138 Rel8.Table.Name

@@ -163,8 +162,6 @@ library

163 Rel8.Type.Sum

162 Rel8.Type.Sum

164 Rel8.Type.Tag

163 Rel8.Type.Tag

165

164

166− Rel8.Schema.Structure

167−

168test-suite tests

165test-suite tests

169 type: exitcode-stdio-1.0

166 type: exitcode-stdio-1.0

170 build-depends:

167 build-depends:

src/Rel8.hs+2−4

@@ -28,7 +28,7 @@ module Rel8

28 -- * Tables and higher-kinded tables

29 , Rel8able

30 , Column, Field, Necessity( Required, Optional )

31− , Default, Label

31+ , Default

32 , HMaybe

33 , HList

34 , HNonEmpty

@@ -268,7 +268,7 @@ import Rel8.Query.These

268import Rel8.Query.Values

269import Rel8.Schema.Column

270import Rel8.Schema.Context.Label

271−import Rel8.Schema.Field (Field)

271+import Rel8.Schema.Field

272import Rel8.Schema.Generic

273import Rel8.Schema.HTable

274import Rel8.Schema.Name

@@ -307,5 +307,3 @@ import Rel8.Type.ReadShow

307import Rel8.Type.Semigroup

308import Rel8.Type.String

309import Rel8.Type.Sum

310−

311−

src/Rel8/Expr/Eq.hs+1−1

@@ -22,7 +22,7 @@ import Prelude

22import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

24-- rel8

25−import Rel8.Expr ( Expr )

25+import {-# SOURCE #-} Rel8.Expr ( Expr )

26import Rel8.Expr.Bool ( (&&.), (||.), false, or_, coalesce )

27import Rel8.Expr.Null ( isNull, unsafeLiftOpNull )

28import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr, zipPrimExprsWith )

src/Rel8/Schema/Column.hs+3−103

@@ -3,67 +3,24 @@

3{-# language StandaloneKindSignatures #-}

5module Rel8.Schema.Column

6− ( Column, Default, Label

6+ ( Column, Default

7− , HEither

8− , HList

9− , HMaybe

10− , HNonEmpty

11− , HThese

12 )

7 )

13where

8where

15-- base

10-- base

16−import Data.Functor.Identity ( Identity )

17import Data.Kind ( Type )

11import Data.Kind ( Type )

18−import Data.List.NonEmpty ( NonEmpty )

19−import GHC.TypeLits ( Symbol )

20−import Prelude

12+import Prelude ()

22-- rel8

14-- rel8

23−import Rel8.Aggregate ( Aggregate )

24−import Rel8.Expr ( Expr )

25−import Rel8.Kind.Labels ( Labels )

26import Rel8.Kind.Necessity ( Necessity( Required, Optional ) )

15import Rel8.Kind.Necessity ( Necessity( Required, Optional ) )

27import Rel8.Schema.Field ( Field )

16import Rel8.Schema.Field ( Field )

28−import Rel8.Schema.Insert ( Insert )

29import qualified Rel8.Schema.Kind as K

17import qualified Rel8.Schema.Kind as K

30−import Rel8.Schema.Name ( Name )

31−import Rel8.Schema.Structure

32− ( Structure

33− , Shape( Either, List, Maybe, NonEmpty, These )

34− , Shape1

35− , Shape2

36− )

37−import Rel8.Table.Either ( EitherTable )

38−import Rel8.Table.List ( ListTable )

39−import Rel8.Table.Maybe ( MaybeTable )

40−import Rel8.Table.NonEmpty ( NonEmptyTable )

41−import Rel8.Table.These ( TheseTable )

42−

43−-- these

44−import Data.These ( These )

45−

46−

47−type Label :: Symbol -> Type -> Type

48−data Label label a

51type Default :: Type -> Type

20type Default :: Type -> Type

52data Default a

21data Default a

55−type GetLabel :: Type -> Labels

56−type family GetLabel a where

57− GetLabel (Label label _) = '[label]

58− GetLabel _ = '[]

59−

60−

61−type UnwrapLabel :: Type -> Type

62−type family UnwrapLabel a where

63− UnwrapLabel (Label _ a) = a

64− UnwrapLabel a = a

65−

66−

67type GetNecessity :: Type -> Necessity

24type GetNecessity :: Type -> Necessity

68type family GetNecessity a where

25type family GetNecessity a where

69 GetNecessity (Default _) = 'Optional

26 GetNecessity (Default _) = 'Optional

@@ -82,61 +39,4 @@ type family UnwrapDefault a where

82-- both query data and rows decoded to Haskell.

39-- both query data and rows decoded to Haskell.

83type Column :: K.Context -> Type -> Type

40type Column :: K.Context -> Type -> Type

84type Column context a =

41type Column context a =

85− Field context (GetLabel a)

86− (GetNecessity (UnwrapLabel a))

87− (UnwrapDefault (UnwrapLabel a))

42+ Field context (GetNecessity a) (UnwrapDefault a)

88−

89−

90−type HEither :: K.Context -> Type -> Type -> Type

91−type family HEither context where

92− HEither Structure = Shape2 'Either

93− HEither Aggregate = EitherTable

94− HEither Expr = EitherTable

95− HEither Identity = Either

96− HEither Insert = EitherTable

97− HEither Name = EitherTable

98− HEither _ = Either

99−

100−

101−type HList :: K.Context -> Type -> Type

102−type family HList context where

103− HList Structure = Shape1 'List

104− HList Aggregate = ListTable

105− HList Expr = ListTable

106− HList Identity = []

107− HList Insert = ListTable

108− HList Name = ListTable

109− HList _ = []

110−

111−

112−type HMaybe :: K.Context -> Type -> Type

113−type family HMaybe context where

114− HMaybe Structure = Shape1 'Maybe

115− HMaybe Aggregate = MaybeTable

116− HMaybe Expr = MaybeTable

117− HMaybe Identity = Maybe

118− HMaybe Insert = MaybeTable

119− HMaybe Name = MaybeTable

120− HMaybe _ = Maybe

121−

122−

123−type HNonEmpty :: K.Context -> Type -> Type

124−type family HNonEmpty context where

125− HNonEmpty Structure = Shape1 'NonEmpty

126− HNonEmpty Aggregate = NonEmptyTable

127− HNonEmpty Expr = NonEmptyTable

128− HNonEmpty Identity = NonEmpty

129− HNonEmpty Insert = NonEmptyTable

130− HNonEmpty Name = NonEmptyTable

131− HNonEmpty _ = NonEmpty

132−

133−

134−type HThese :: K.Context -> Type -> Type -> Type

135−type family HThese context where

136− HThese Structure = Shape2 'These

137− HThese Aggregate = TheseTable

138− HThese Expr = TheseTable

139− HThese Identity = These

140− HThese Insert = TheseTable

141− HThese Name = TheseTable

142− HThese _ = These

src/Rel8/Schema/Context/Identity.hsdeleted−196

@@ -1,196 +0,0 @@

1−{-# language DataKinds #-}

2−{-# language DisambiguateRecordFields #-}

3−{-# language NamedFieldPuns #-}

4−{-# language TypeFamilies #-}

5−

6−module Rel8.Schema.Context.Identity

7− ( fromHEitherTable, toHEitherTable

8− , fromHListTable, toHListTable

9− , fromHMaybeTable, toHMaybeTable

10− , fromHNonEmptyTable, toHNonEmptyTable

11− , fromHTheseTable, toHTheseTable

12− )

13−where

14−

15−-- base

16−import Data.Functor ( ($>) )

17−import Data.Functor.Identity ( Identity )

18−import Data.List.NonEmpty ( NonEmpty )

19−import Prelude hiding ( null )

20−

21−-- rel8

22−import Rel8.Schema.Context ( Col( Result ) )

23−import Rel8.Schema.HTable ( HTable )

24−import Rel8.Schema.HTable.Either ( HEitherTable(..) )

25−import Rel8.Schema.HTable.Identity ( HIdentity(..) )

26−import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )

27−import Rel8.Schema.HTable.List ( HListTable )

28−import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )

29−import Rel8.Schema.HTable.Nullify ( hnulls, hnullify, hunnullify )

30−import Rel8.Schema.HTable.These ( HTheseTable(..) )

31−import Rel8.Schema.HTable.Vectorize ( hvectorize, hunvectorize )

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

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

34−import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), MaybeTag( IsJust ) )

35−

36−-- these

37−import Data.These ( These( This, That, These ) )

38−import Data.These.Combinators ( justHere, justThere )

39−

40−

41−toHEitherTable :: (HTable t, HTable u)

42− => Either (t (Col Identity)) (u (Col Identity))

43− -> HEitherTable t u (Col Identity)

44−toHEitherTable = either hleft hright

45− where

46− hleft table = HEitherTable

47− { htag = HIdentity (Result IsLeft)

48− , hleft = hnullify nullifier table

49− , hright = hnulls null

50− }

51− hright table = HEitherTable

52− { htag = HIdentity (Result IsRight)

53− , hleft = hnulls null

54− , hright = hnullify nullifier table

55− }

56−{-# INLINABLE toHEitherTable #-}

57−

58−

59−fromHEitherTable :: (HTable t, HTable u)

60− => HEitherTable t u (Col Identity)

61− -> Either (t (Col Identity)) (u (Col Identity))

62−fromHEitherTable HEitherTable {htag, hleft, hright} = case htag of

63− HIdentity (Result tag) -> case tag of

64− IsLeft -> maybe err Left $ hunnullify unnullifier hleft

65− IsRight -> maybe err Right $ hunnullify unnullifier hright

66− where

67− err = error "fromHEitherTable: mismatch between tag and data"

68−{-# INLINABLE fromHEitherTable #-}

69−

70−

71−toHListTable :: HTable t => [t (Col Identity)] -> HListTable t (Col Identity)

72−toHListTable = hvectorize vectorizer

73−{-# INLINABLE toHListTable #-}

74−

75−

76−fromHListTable :: HTable t => HListTable t (Col Identity) -> [t (Col Identity)]

77−fromHListTable = hunvectorize unvectorizer

78−{-# INLINABLE fromHListTable #-}

79−

80−

81−toHMaybeTable :: HTable t => Maybe (t (Col Identity)) -> HMaybeTable t (Col Identity)

82−toHMaybeTable = maybe hnothing hjust

83− where

84− hnothing = HMaybeTable

85− { htag = HIdentity (Result Nothing)

86− , hjust = hnulls null

87− }

88− hjust table = HMaybeTable

89− { htag = HIdentity (Result (Just IsJust))

90− , hjust = hnullify nullifier table

91− }

92−{-# INLINABLE toHMaybeTable #-}

93−

94−

95−fromHMaybeTable :: HTable t => HMaybeTable t (Col Identity) -> Maybe (t (Col Identity))

96−fromHMaybeTable HMaybeTable {htag, hjust} = case htag of

97− HIdentity (Result tag) -> tag $>

98− case hunnullify unnullifier hjust of

99− Nothing -> error "fromHMaybeTable: mismatch between tag and data"

100− Just just -> just

101−{-# INLINABLE fromHMaybeTable #-}

102−

103−

104−toHNonEmptyTable :: HTable t => NonEmpty (t (Col Identity)) -> HNonEmptyTable t (Col Identity)

105−toHNonEmptyTable = hvectorize vectorizer

106−{-# INLINABLE toHNonEmptyTable #-}

107−

108−

109−fromHNonEmptyTable :: HTable t => HNonEmptyTable t (Col Identity) -> NonEmpty (t (Col Identity))

110−fromHNonEmptyTable = hunvectorize unvectorizer

111−{-# INLINABLE fromHNonEmptyTable #-}

112−

113−

114−toHTheseTable :: (HTable t, HTable u)

115− => These (t (Col Identity)) (u (Col Identity))

116− -> HTheseTable t u (Col Identity)

117−toHTheseTable tables = HTheseTable

118− { hhereTag = relabel hhereTag

119− , hhere

120− , hthereTag = relabel hthereTag

121− , hthere

122− }

123− where

124− HMaybeTable

125− { htag = hhereTag

126− , hjust = hhere

127− } = toHMaybeTable (justHere tables)

128− HMaybeTable

129− { htag = hthereTag

130− , hjust = hthere

131− } = toHMaybeTable (justThere tables)

132−{-# INLINABLE toHTheseTable #-}

133−

134−

135−fromHTheseTable :: (HTable t, HTable u)

136− => HTheseTable t u (Col Identity)

137− -> These (t (Col Identity)) (u (Col Identity))

138−fromHTheseTable HTheseTable {hhereTag, hhere, hthereTag, hthere} =

139− case (fromHMaybeTable mhere, fromHMaybeTable mthere) of

140− (Just a, Nothing) -> This a

141− (Nothing, Just b) -> That b

142− (Just a, Just b) -> These a b

143− _ -> error "fromHTheseTable: mismatch between tags and data"

144− where

145− mhere = HMaybeTable

146− { htag = relabel hhereTag

147− , hjust = hhere

148− }

149− mthere = HMaybeTable

150− { htag = relabel hthereTag

151− , hjust = hthere

152− }

153−{-# INLINABLE fromHTheseTable #-}

154−

155−

156−null :: Col Identity ('Spec labels necessity (Maybe a))

157−null = Result Nothing

158−

159−

160−nullifier :: ()

161− => SSpec ('Spec labels necessity a)

162− -> Col Identity ('Spec labels necessity a)

163− -> Col Identity ('Spec labels necessity (Nullify a))

164−nullifier SSpec {nullity} (Result a) = Result $ case nullity of

165− Null -> a

166− NotNull -> Just a

167−

168−

169−unnullifier :: ()

170− => SSpec ('Spec labels necessity a)

171− -> Col Identity ('Spec labels necessity (Nullify a))

172− -> Maybe (Col Identity ('Spec labels necessity a))

173−unnullifier SSpec {nullity} (Result a) =

174− case nullity of

175− Null -> pure $ Result a

176− NotNull -> Result <$> a

177−

178−

179−vectorizer :: Functor f

180− => SSpec ('Spec labels necessity a)

181− -> f (Col Identity ('Spec labels necessity a))

182− -> Col Identity ('Spec labels necessity (f a))

183−vectorizer _ = Result . fmap (\(Result a) -> a)

184−

185−

186−unvectorizer :: Functor f

187− => SSpec ('Spec labels necessity a)

188− -> Col Identity ('Spec labels necessity (f a))

189− -> f (Col Identity ('Spec labels necessity a))

190−unvectorizer _ (Result results) = Result <$> results

191−

192−

193−relabel :: ()

194− => HIdentity ('Spec labels necessity a) (Col Identity)

195− -> HIdentity ('Spec relabels necessity a) (Col Identity)

196−relabel (HIdentity (Result a)) = HIdentity (Result a)

src/Rel8/Schema/Field.hs+709−18

@@ -1,34 +1,725 @@

1{-# language DataKinds #-}

2+{-# language FlexibleContexts #-}

3+{-# language GADTs #-}

4+{-# language LambdaCase #-}

5+{-# language MultiParamTypeClasses #-}

2{-# language StandaloneKindSignatures #-}

6{-# language StandaloneKindSignatures #-}

3{-# language TypeFamilies #-}

7{-# language TypeFamilies #-}

8+{-# language UndecidableInstances #-}

5module Rel8.Schema.Field

10module Rel8.Schema.Field

6 ( Field

11 ( Field

12+ , HEither, HList, HMaybe, HNonEmpty, HThese

13+ , Reify, hreify, hunreify

14+ , Reifiable

15+ , AField(..)

16+ , AHEither(..), AHList(..), AHMaybe(..), AHNonEmpty(..), AHThese(..)

7 )

17 )

8where

18where

10-- base

20-- base

21+import Data.Bifunctor ( Bifunctor, bimap )

11import Data.Functor.Identity ( Identity )

22import Data.Functor.Identity ( Identity )

12−import Data.Kind ( Type )

23+import Data.Kind ( Constraint, Type )

24+import Data.List.NonEmpty ( NonEmpty )

13import Prelude

25import Prelude

15-- rel8

27-- rel8

16−import Rel8.Aggregate ( Aggregate )

28+import Rel8.Aggregate ( Aggregate, Col(..) )

17−import Rel8.Expr ( Expr )

29+import Rel8.Expr ( Expr, Col(..) )

18−import Rel8.Kind.Labels ( Labels )

30+import Rel8.Kind.Necessity

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

31+ ( Necessity( Required, Optional )

32+ , SNecessity( SRequired, SOptional )

33+ , KnownNecessity, necessitySing

34+ )

20−import Rel8.Schema.Insert ( Insert )

35+import Rel8.Schema.Context ( Interpretation, Col(..) )

36+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )

37+import Rel8.Schema.HTable ( HTable, hfield, htabulate )

38+import Rel8.Schema.HTable.Either ( HEitherTable )

39+import Rel8.Schema.HTable.List ( HListTable )

40+import Rel8.Schema.HTable.Maybe ( HMaybeTable )

41+import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )

42+import Rel8.Schema.HTable.These ( HTheseTable )

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

44+import Rel8.Schema.Insert ( Insert, Col(..) )

21import qualified Rel8.Schema.Kind as K

45import qualified Rel8.Schema.Kind as K

46+import Rel8.Schema.Name ( Name(..), Col(..) )

47+import Rel8.Schema.Null ( Sql )

22import Rel8.Schema.Spec ( Spec( Spec ) )

48import Rel8.Schema.Spec ( Spec( Spec ) )

23−import Rel8.Schema.Structure ( Structure, Shape( Column ), Shape1 )

49+import Rel8.Table

24−

50+ ( Table, Columns, Context, fromColumns, toColumns

25−

51+ , Congruent

26−type Field :: K.Context -> Labels -> Necessity -> Type -> Type

52+ )

27−type family Field labels context necessity a where

53+import Rel8.Table.Either ( EitherTable )

28− Field Identity _labels _necessity a = a

54+import Rel8.Table.List ( ListTable( ListTable ) )

29− Field Expr _labels _necessity a = Expr a

55+import Rel8.Table.Maybe ( MaybeTable )

30− Field Insert _labels 'Required a = Expr a

56+import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) )

31− Field Insert _labels 'Optional a = Maybe (Expr a)

57+import Rel8.Table.Recontextualize ( Recontextualize )

32− Field Aggregate _labels _necessity a = Aggregate (Expr a)

58+import Rel8.Table.These ( TheseTable )

33− Field Structure labels necessity a = Shape1 'Column ('Spec labels necessity a)

59+import Rel8.Type ( DBType )

34− Field context _labels _necessity a = context a

60+

61+-- these

62+import Data.These ( These )

63+

64+

65+type Field :: K.Context -> Necessity -> Type -> Type

66+type family Field context necessity a where

67+ Field (Reify context) necessity a = AField context necessity a

68+ Field Identity _necessity a = a

69+ Field Expr _necessity a = Expr a

70+ Field Insert 'Required a = Expr a

71+ Field Insert 'Optional a = Maybe (Expr a)

72+ Field Aggregate _necessity a = Aggregate (Expr a)

73+ Field context _necessity a = context a

74+

75+

76+type HEither :: K.Context -> Type -> Type -> Type

77+type family HEither context where

78+ HEither (Reify context) = AHEither context

79+ HEither Aggregate = EitherTable

80+ HEither Expr = EitherTable

81+ HEither Identity = Either

82+ HEither Insert = EitherTable

83+ HEither Name = EitherTable

84+ HEither _ = Either

85+

86+

87+type HList :: K.Context -> Type -> Type

88+type family HList context where

89+ HList (Reify context) = AHList context

90+ HList Aggregate = ListTable

91+ HList Expr = ListTable

92+ HList Identity = []

93+ HList Insert = ListTable

94+ HList Name = ListTable

95+ HList _ = []

96+

97+

98+type HMaybe :: K.Context -> Type -> Type

99+type family HMaybe context where

100+ HMaybe (Reify context) = AHMaybe context

101+ HMaybe Aggregate = MaybeTable

102+ HMaybe Expr = MaybeTable

103+ HMaybe Identity = Maybe

104+ HMaybe Insert = MaybeTable

105+ HMaybe Name = MaybeTable

106+ HMaybe _ = Maybe

107+

108+

109+type HNonEmpty :: K.Context -> Type -> Type

110+type family HNonEmpty context where

111+ HNonEmpty (Reify context) = AHNonEmpty context

112+ HNonEmpty Aggregate = NonEmptyTable

113+ HNonEmpty Expr = NonEmptyTable

114+ HNonEmpty Identity = NonEmpty

115+ HNonEmpty Insert = NonEmptyTable

116+ HNonEmpty Name = NonEmptyTable

117+ HNonEmpty _ = NonEmpty

118+

119+

120+type HThese :: K.Context -> Type -> Type -> Type

121+type family HThese context where

122+ HThese (Reify context) = AHThese context

123+ HThese Aggregate = TheseTable

124+ HThese Expr = TheseTable

125+ HThese Identity = These

126+ HThese Insert = TheseTable

127+ HThese Name = TheseTable

128+ HThese _ = These

129+

130+

131+type AField :: K.Context -> Necessity -> Type -> Type

132+newtype AField context necessity a = AField (Field context necessity a)

133+

134+

135+instance (Reifiable context, KnownNecessity necessity, Sql DBType a) =>

136+ Table (Reify context) (AField context necessity a)

137+ where

138+ type Context (AField context necessity a) = Reify context

139+ type Columns (AField context necessity a) = HIdentity ('Spec '[""] necessity a)

140+

141+ fromColumns (HIdentity (Reify a)) = sfromColumn contextSing a

142+ toColumns = HIdentity . Reify . stoColumn contextSing necessitySing

143+

144+

145+instance

146+ ( Reifiable context, Reifiable context'

147+ , KnownNecessity necessity, Sql DBType a

148+ ) =>

149+ Recontextualize

150+ (Reify context)

151+ (Reify context')

152+ (AField context necessity a)

153+ (AField context' necessity a)

154+

155+

156+type AHEither :: K.Context -> Type -> Type -> Type

157+newtype AHEither context a b = AHEither (HEither context a b)

158+

159+

160+instance Reifiable context => Bifunctor (AHEither context) where

161+ bimap = sbimapEither contextSing

162+

163+

164+instance Reifiable context => Functor (AHEither context a) where

165+ fmap = bimap id

166+

167+

168+instance (Reifiable context, Table (Reify context) a, Table (Reify context) b)

169+ => Table (Reify context) (AHEither context a b)

170+ where

171+ type Context (AHEither context a b) = Reify context

172+ type Columns (AHEither context a b) = HEitherTable (Columns a) (Columns b)

173+

174+ fromColumns = sfromColumnsEither contextSing

175+ toColumns = stoColumnsEither contextSing

176+

177+

178+instance

179+ ( Reifiable context, Reifiable context'

180+ , Recontextualize (Reify context) (Reify context') a a'

181+ , Recontextualize (Reify context) (Reify context') b b'

182+ ) =>

183+ Recontextualize

184+ (Reify context)

185+ (Reify context')

186+ (AHEither context a b)

187+ (AHEither context' a' b')

188+

189+

190+type AHList :: K.Context -> Type -> Type

191+newtype AHList context a = AHList (HList context a)

192+

193+

194+instance (Reifiable context, Table (Reify context) a) =>

195+ Table (Reify context) (AHList context a)

196+ where

197+ type Context (AHList context a) = Reify context

198+ type Columns (AHList context a) = HListTable (Columns a)

199+

200+ fromColumns = sfromColumnsList contextSing

201+ toColumns = stoColumnsList contextSing

202+

203+

204+instance

205+ ( Reifiable context, Reifiable context'

206+ , Recontextualize (Reify context) (Reify context') a a'

207+ ) =>

208+ Recontextualize

209+ (Reify context)

210+ (Reify context')

211+ (AHList context a)

212+ (AHList context' a')

213+

214+

215+type AHMaybe :: K.Context -> Type -> Type

216+newtype AHMaybe context a = AHMaybe (HMaybe context a)

217+

218+

219+instance Reifiable context => Functor (AHMaybe context) where

220+ fmap = smapMaybe contextSing

221+

222+

223+instance (Reifiable context, Table (Reify context) a) =>

224+ Table (Reify context) (AHMaybe context a)

225+ where

226+ type Context (AHMaybe context a) = Reify context

227+ type Columns (AHMaybe context a) = HMaybeTable (Columns a)

228+

229+ fromColumns = sfromColumnsMaybe contextSing

230+ toColumns = stoColumnsMaybe contextSing

231+

232+

233+instance

234+ ( Reifiable context, Reifiable context'

235+ , Recontextualize (Reify context) (Reify context') a a'

236+ ) =>

237+ Recontextualize

238+ (Reify context)

239+ (Reify context')

240+ (AHMaybe context a)

241+ (AHMaybe context' a')

242+

243+

244+type AHNonEmpty :: K.Context -> Type -> Type

245+newtype AHNonEmpty context a = AHNonEmpty (HNonEmpty context a)

246+

247+

248+instance (Reifiable context, Table (Reify context) a) =>

249+ Table (Reify context) (AHNonEmpty context a)

250+ where

251+ type Context (AHNonEmpty context a) = Reify context

252+ type Columns (AHNonEmpty context a) = HNonEmptyTable (Columns a)

253+

254+ fromColumns = sfromColumnsNonEmpty contextSing

255+ toColumns = stoColumnsNonEmpty contextSing

256+

257+

258+instance

259+ ( Reifiable context, Reifiable context'

260+ , Recontextualize (Reify context) (Reify context') a a'

261+ ) =>

262+ Recontextualize

263+ (Reify context)

264+ (Reify context')

265+ (AHNonEmpty context a)

266+ (AHNonEmpty context' a')

267+

268+

269+type AHThese :: K.Context -> Type -> Type -> Type

270+newtype AHThese context a b = AHThese (HThese context a b)

271+

272+

273+instance Reifiable context => Bifunctor (AHThese context) where

274+ bimap = sbimapThese contextSing

275+

276+

277+instance Reifiable context => Functor (AHThese context a) where

278+ fmap = bimap id

279+

280+

281+instance (Reifiable context, Table (Reify context) a, Table (Reify context) b)

282+ => Table (Reify context) (AHThese context a b)

283+ where

284+ type Context (AHThese context a b) = Reify context

285+ type Columns (AHThese context a b) = HTheseTable (Columns a) (Columns b)

286+

287+ fromColumns = sfromColumnsThese contextSing

288+ toColumns = stoColumnsThese contextSing

289+

290+

291+instance

292+ ( Reifiable context, Reifiable context'

293+ , Recontextualize (Reify context) (Reify context') a a'

294+ , Recontextualize (Reify context) (Reify context') b b'

295+ ) =>

296+ Recontextualize

297+ (Reify context)

298+ (Reify context')

299+ (AHThese context a b)

300+ (AHThese context' a' b')

301+

302+

303+type SContext :: K.Context -> Type

304+data SContext context where

305+ SAggregate :: SContext Aggregate

306+ SExpr :: SContext Expr

307+ SIdentity :: SContext Identity

308+ SInsert :: SContext Insert

309+ SName :: SContext Name

310+ SReify :: SContext context -> SContext (Reify context)

311+

312+

313+type Reifiable :: K.Context -> Constraint

314+class Interpretation context => Reifiable context where

315+ contextSing :: SContext context

316+

317+

318+instance Reifiable Aggregate where

319+ contextSing = SAggregate

320+

321+

322+instance Reifiable Expr where

323+ contextSing = SExpr

324+

325+

326+instance Reifiable Identity where

327+ contextSing = SIdentity

328+

329+

330+instance Reifiable Insert where

331+ contextSing = SInsert

332+

333+

334+instance Reifiable Name where

335+ contextSing = SName

336+

337+

338+type Reify :: K.Context -> K.Context

339+data Reify context a

340+

341+

342+instance Interpretation (Reify context) where

343+ newtype Col (Reify context) spec = Reify (Col context spec)

344+

345+

346+instance Labelable context => Labelable (Reify context) where

347+ labeler (Reify a) = Reify (labeler a)

348+ unlabeler (Reify a) = Reify (unlabeler a)

349+

350+

351+instance Reifiable context => Reifiable (Reify context) where

352+ contextSing = SReify contextSing

353+

354+

355+sfromColumn :: ()

356+ => SContext context

357+ -> Col context ('Spec labels necessity a)

358+ -> AField context necessity a

359+sfromColumn = \case

360+ SAggregate -> \(Aggregation a) -> AField a

361+ SExpr -> \(DB a) -> AField a

362+ SIdentity -> \(Result a) -> AField a

363+ SInsert -> \case

364+ RequiredInsert a -> AField a

365+ OptionalInsert a -> AField a

366+ SName -> \(NameCol a) -> AField (Name a)

367+ SReify context -> \(Reify a) -> AField (sfromColumn context a)

368+

369+

370+stoColumn :: ()

371+ => SContext context

372+ -> SNecessity necessity

373+ -> AField context necessity a

374+ -> Col context ('Spec labels necessity a)

375+stoColumn = \case

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

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

378+ SIdentity -> \_ (AField a) -> Result a

379+ SInsert -> \case

380+ SRequired -> \(AField a) -> RequiredInsert a

381+ SOptional -> \(AField a) -> OptionalInsert a

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

383+ SReify context ->

384+ \necessity (AField a) -> Reify (stoColumn context necessity a)

385+

386+

387+sbimapEither :: ()

388+ => SContext context

389+ -> (a -> c)

390+ -> (b -> d)

391+ -> AHEither context a b

392+ -> AHEither context c d

393+sbimapEither = \case

394+ SAggregate -> \f g (AHEither a) -> AHEither (bimap f g a)

395+ SExpr -> \f g (AHEither a) -> AHEither (bimap f g a)

396+ SIdentity -> \f g (AHEither a) -> AHEither (bimap f g a)

397+ SInsert -> \f g (AHEither a) -> AHEither (bimap f g a)

398+ SName -> \f g (AHEither a) -> AHEither (bimap f g a)

399+ SReify context -> \f g (AHEither a) -> AHEither (sbimapEither context f g a)

400+

401+

402+sfromColumnsEither :: (Table (Reify context) a, Table (Reify context) b)

403+ => SContext context

404+ -> HEitherTable (Columns a) (Columns b) (Col (Reify context))

405+ -> AHEither context a b

406+sfromColumnsEither = \case

407+ SAggregate ->

408+ AHEither .

409+ bimap (fromColumns . hreify) (fromColumns . hreify) .

410+ fromColumns .

411+ hunreify

412+ SExpr ->

413+ AHEither .

414+ bimap (fromColumns . hreify) (fromColumns . hreify) .

415+ fromColumns .

416+ hunreify

417+ SIdentity ->

418+ AHEither .

419+ bimap (fromColumns . hreify) (fromColumns . hreify) .

420+ fromColumns .

421+ hunreify

422+ SInsert ->

423+ AHEither .

424+ bimap (fromColumns . hreify) (fromColumns . hreify) .

425+ fromColumns .

426+ hunreify

427+ SName ->

428+ AHEither .

429+ bimap (fromColumns . hreify) (fromColumns . hreify) .

430+ fromColumns .

431+ hunreify

432+ SReify context ->

433+ AHEither .

434+ sbimapEither context (fromColumns . hreify) (fromColumns . hreify) .

435+ sfromColumnsEither context .

436+ hunreify

437+

438+

439+stoColumnsEither :: (Table (Reify context) a, Table (Reify context) b)

440+ => SContext context

441+ -> AHEither context a b

442+ -> HEitherTable (Columns a) (Columns b) (Col (Reify context))

443+stoColumnsEither = \case

444+ SAggregate ->

445+ hreify .

446+ toColumns .

447+ bimap (hunreify . toColumns) (hunreify . toColumns) .

448+ (\(AHEither a) -> a)

449+ SExpr ->

450+ hreify .

451+ toColumns .

452+ bimap (hunreify . toColumns) (hunreify . toColumns) .

453+ (\(AHEither a) -> a)

454+ SIdentity ->

455+ hreify .

456+ toColumns .

457+ bimap (hunreify . toColumns) (hunreify . toColumns) .

458+ (\(AHEither a) -> a)

459+ SInsert ->

460+ hreify .

461+ toColumns .

462+ bimap (hunreify . toColumns) (hunreify . toColumns) .

463+ (\(AHEither a) -> a)

464+ SName ->

465+ hreify .

466+ toColumns .

467+ bimap (hunreify . toColumns) (hunreify . toColumns) .

468+ (\(AHEither a) -> a)

469+ SReify context ->

470+ hreify .

471+ stoColumnsEither context .

472+ sbimapEither context (hunreify . toColumns) (hunreify . toColumns) .

473+ (\(AHEither a) -> a)

474+

475+

476+smapList :: Congruent a b

477+ => SContext context

478+ -> (a -> b)

479+ -> (HListTable (Columns a) (Col (Context a)) -> HListTable (Columns b) (Col (Context b)))

480+ -> AHList context a

481+ -> AHList context b

482+smapList = \case

483+ SAggregate -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))

484+ SExpr -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))

485+ SIdentity -> \f _ (AHList as) -> AHList (fmap f as)

486+ SInsert -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))

487+ SName -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))

488+ SReify context -> \f g (AHList as) -> AHList (smapList context f g as)

489+

490+

491+sfromColumnsList :: Table (Reify context) a

492+ => SContext context

493+ -> HListTable (Columns a) (Col (Reify context))

494+ -> AHList context a

495+sfromColumnsList = \case

496+ SAggregate -> AHList . ListTable

497+ SExpr -> AHList . ListTable

498+ SIdentity -> AHList . fmap (fromColumns . hreify) . fromColumns . hunreify

499+ SInsert -> AHList . ListTable

500+ SName -> AHList . ListTable

501+ SReify context ->

502+ AHList .

503+ smapList context (fromColumns . hreify) hreify .

504+ sfromColumnsList context .

505+ hunreify

506+

507+

508+stoColumnsList :: Table (Reify context) a

509+ => SContext context

510+ -> AHList context a

511+ -> HListTable (Columns a) (Col (Reify context))

512+stoColumnsList = \case

513+ SAggregate -> \(AHList (ListTable a)) -> a

514+ SExpr -> \(AHList (ListTable a)) -> a

515+ SIdentity ->

516+ hreify . toColumns . fmap (hunreify . toColumns) . (\(AHList a) -> a)

517+ SInsert -> \(AHList (ListTable a)) -> a

518+ SName -> \(AHList (ListTable a)) -> a

519+ SReify context ->

520+ hreify .

521+ stoColumnsList context .

522+ smapList context (hunreify . toColumns) hunreify .

523+ (\(AHList a) -> a)

524+

525+

526+smapMaybe :: ()

527+ => SContext context

528+ -> (a -> b)

529+ -> AHMaybe context a

530+ -> AHMaybe context b

531+smapMaybe = \case

532+ SAggregate -> \f (AHMaybe a) -> AHMaybe (fmap f a)

533+ SExpr -> \f (AHMaybe a) -> AHMaybe (fmap f a)

534+ SIdentity -> \f (AHMaybe a) -> AHMaybe (fmap f a)

535+ SInsert -> \f (AHMaybe a) -> AHMaybe (fmap f a)

536+ SName -> \f (AHMaybe a) -> AHMaybe (fmap f a)

537+ SReify context -> \f (AHMaybe a) -> AHMaybe (smapMaybe context f a)

538+

539+

540+sfromColumnsMaybe :: Table (Reify context) a

541+ => SContext context

542+ -> HMaybeTable (Columns a) (Col (Reify context))

543+ -> AHMaybe context a

544+sfromColumnsMaybe = \case

545+ SAggregate -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify

546+ SExpr -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify

547+ SIdentity -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify

548+ SInsert -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify

549+ SName -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify

550+ SReify context ->

551+ AHMaybe .

552+ smapMaybe context (fromColumns . hreify) .

553+ sfromColumnsMaybe context .

554+ hunreify

555+

556+

557+stoColumnsMaybe :: Table (Reify context) a

558+ => SContext context

559+ -> AHMaybe context a

560+ -> HMaybeTable (Columns a) (Col (Reify context))

561+stoColumnsMaybe = \case

562+ SAggregate ->

563+ hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)

564+ SExpr ->

565+ hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)

566+ SIdentity ->

567+ hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)

568+ SInsert ->

569+ hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)

570+ SName ->

571+ hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)

572+ SReify context ->

573+ hreify .

574+ stoColumnsMaybe context .

575+ smapMaybe context (hunreify . toColumns) .

576+ (\(AHMaybe a) -> a)

577+

578+

579+smapNonEmpty :: Congruent a b

580+ => SContext context

581+ -> (a -> b)

582+ -> (HNonEmptyTable (Columns a) (Col (Context a)) -> HNonEmptyTable (Columns b) (Col (Context b)))

583+ -> AHNonEmpty context a

584+ -> AHNonEmpty context b

585+smapNonEmpty = \case

586+ SAggregate -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))

587+ SExpr -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))

588+ SIdentity -> \f _ (AHNonEmpty as) -> AHNonEmpty (fmap f as)

589+ SInsert -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))

590+ SName -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))

591+ SReify context -> \f g (AHNonEmpty as) -> AHNonEmpty (smapNonEmpty context f g as)

592+

593+

594+sfromColumnsNonEmpty :: Table (Reify context) a

595+ => SContext context

596+ -> HNonEmptyTable (Columns a) (Col (Reify context))

597+ -> AHNonEmpty context a

598+sfromColumnsNonEmpty = \case

599+ SAggregate -> AHNonEmpty . NonEmptyTable

600+ SExpr -> AHNonEmpty . NonEmptyTable

601+ SIdentity ->

602+ AHNonEmpty . fmap (fromColumns . hreify) . fromColumns . hunreify

603+ SInsert -> AHNonEmpty . NonEmptyTable

604+ SName -> AHNonEmpty . NonEmptyTable

605+ SReify context ->

606+ AHNonEmpty .

607+ smapNonEmpty context (fromColumns . hreify) hreify .

608+ sfromColumnsNonEmpty context .

609+ hunreify

610+

611+

612+stoColumnsNonEmpty :: Table (Reify context) a

613+ => SContext context

614+ -> AHNonEmpty context a

615+ -> HNonEmptyTable (Columns a) (Col (Reify context))

616+stoColumnsNonEmpty = \case

617+ SAggregate -> \(AHNonEmpty (NonEmptyTable a)) -> a

618+ SExpr -> \(AHNonEmpty (NonEmptyTable a)) -> a

619+ SIdentity ->

620+ hreify . toColumns . fmap (hunreify . toColumns) . (\(AHNonEmpty a) -> a)

621+ SInsert -> \(AHNonEmpty (NonEmptyTable a)) -> a

622+ SName -> \(AHNonEmpty (NonEmptyTable a)) -> a

623+ SReify context ->

624+ hreify .

625+ stoColumnsNonEmpty context .

626+ smapNonEmpty context (hunreify . toColumns) hunreify .

627+ (\(AHNonEmpty a) -> a)

628+

629+

630+sbimapThese :: ()

631+ => SContext context

632+ -> (a -> c)

633+ -> (b -> d)

634+ -> AHThese context a b

635+ -> AHThese context c d

636+sbimapThese = \case

637+ SAggregate -> \f g (AHThese a) -> AHThese (bimap f g a)

638+ SExpr -> \f g (AHThese a) -> AHThese (bimap f g a)

639+ SIdentity -> \f g (AHThese a) -> AHThese (bimap f g a)

640+ SInsert -> \f g (AHThese a) -> AHThese (bimap f g a)

641+ SName -> \f g (AHThese a) -> AHThese (bimap f g a)

642+ SReify context -> \f g (AHThese a) -> AHThese (sbimapThese context f g a)

643+

644+

645+sfromColumnsThese :: (Table (Reify context) a, Table (Reify context) b)

646+ => SContext context

647+ -> HTheseTable (Columns a) (Columns b) (Col (Reify context))

648+ -> AHThese context a b

649+sfromColumnsThese = \case

650+ SAggregate ->

651+ AHThese .

652+ bimap (fromColumns . hreify) (fromColumns . hreify) .

653+ fromColumns .

654+ hunreify

655+ SExpr ->

656+ AHThese .

657+ bimap (fromColumns . hreify) (fromColumns . hreify) .

658+ fromColumns .

659+ hunreify

660+ SIdentity ->

661+ AHThese .

662+ bimap (fromColumns . hreify) (fromColumns . hreify) .

663+ fromColumns .

664+ hunreify

665+ SInsert ->

666+ AHThese .

667+ bimap (fromColumns . hreify) (fromColumns . hreify) .

668+ fromColumns .

669+ hunreify

670+ SName ->

671+ AHThese .

672+ bimap (fromColumns . hreify) (fromColumns . hreify) .

673+ fromColumns .

674+ hunreify

675+ SReify context ->

676+ AHThese .

677+ sbimapThese context (fromColumns . hreify) (fromColumns . hreify) .

678+ sfromColumnsThese context .

679+ hunreify

680+

681+

682+stoColumnsThese :: (Table (Reify context) a, Table (Reify context) b)

683+ => SContext context

684+ -> AHThese context a b

685+ -> HTheseTable (Columns a) (Columns b) (Col (Reify context))

686+stoColumnsThese = \case

687+ SAggregate ->

688+ hreify .

689+ toColumns .

690+ bimap (hunreify . toColumns) (hunreify . toColumns) .

691+ (\(AHThese a) -> a)

692+ SExpr ->

693+ hreify .

694+ toColumns .

695+ bimap (hunreify . toColumns) (hunreify . toColumns) .

696+ (\(AHThese a) -> a)

697+ SIdentity ->

698+ hreify .

699+ toColumns .

700+ bimap (hunreify . toColumns) (hunreify . toColumns) .

701+ (\(AHThese a) -> a)

702+ SInsert ->

703+ hreify .

704+ toColumns .

705+ bimap (hunreify . toColumns) (hunreify . toColumns) .

706+ (\(AHThese a) -> a)

707+ SName ->

708+ hreify .

709+ toColumns .

710+ bimap (hunreify . toColumns) (hunreify . toColumns) .

711+ (\(AHThese a) -> a)

712+ SReify context ->

713+ hreify .

714+ stoColumnsThese context .

715+ sbimapThese context (hunreify . toColumns) (hunreify . toColumns) .

716+ (\(AHThese a) -> a)

717+

718+

719+hreify :: HTable t => t (Col context) -> t (Col (Reify context))

720+hreify a = htabulate $ \field -> Reify (hfield a field)

721+

722+

723+hunreify :: HTable t => t (Col (Reify context)) -> t (Col context)

724+hunreify a = htabulate $ \field -> case hfield a field of

725+ Reify x -> x

src/Rel8/Schema/Generic.hs+75−932

@@ -6,13 +6,13 @@

6{-# language FlexibleInstances #-}

7{-# language GADTs #-}

8{-# language MultiParamTypeClasses #-}

9+{-# language QuantifiedConstraints #-}

9{-# language ScopedTypeVariables #-}

10{-# language ScopedTypeVariables #-}

10{-# language StandaloneKindSignatures #-}

11{-# language StandaloneKindSignatures #-}

11{-# language TypeApplications #-}

12{-# language TypeApplications #-}

12{-# language TypeFamilies #-}

13{-# language TypeFamilies #-}

13{-# language TypeOperators #-}

14{-# language TypeOperators #-}

14{-# language UndecidableInstances #-}

15{-# language UndecidableInstances #-}

15−{-# language ViewPatterns #-}

17{-# options_ghc -fno-warn-orphans #-}

@@ -22,113 +22,44 @@ module Rel8.Schema.Generic

22where

24-- base

25−import Data.Bifunctor ( bimap )

26−import Data.Functor.Identity ( Identity )

27import Data.Kind ( Constraint, Type )

25import Data.Kind ( Constraint, Type )

28−import Data.List.NonEmpty ( NonEmpty )

29import GHC.Generics

26import GHC.Generics

30 ( Generic, Rep, from, to

27 ( Generic, Rep, from, to

31 , (:*:)( (:*:) ), K1( K1 ), M1( M1 )

28 , (:*:)( (:*:) ), K1( K1 ), M1( M1 )

32− , D, C, S

29+ , D, S

33 , Meta( MetaSel )

30 , Meta( MetaSel )

34 )

31 )

32+import qualified GHC.Generics as G ( C )

35−import GHC.TypeLits ( Symbol, KnownSymbol )

33+import GHC.TypeLits ( KnownSymbol )

36import Prelude

34import Prelude

35+import Unsafe.Coerce ( unsafeCoerce )

38-- rel8

37-- rel8

39−import Rel8.Aggregate ( Aggregate, Col(..) )

40−import Rel8.Expr ( Expr, Col(..) )

41−import Rel8.Kind.Necessity

42− ( SNecessity( SRequired, SOptional )

43− , KnownNecessity, necessitySing

44− )

45−import Rel8.Schema.Context ( Col(..) )

38+import Rel8.Schema.Context ( Col )

46−import Rel8.Schema.Context.Identity

47− ( fromHEitherTable, toHEitherTable

48− , fromHListTable, toHListTable

49− , fromHMaybeTable, toHMaybeTable

50− , fromHNonEmptyTable, toHNonEmptyTable

51− , fromHTheseTable, toHTheseTable

52− )

53−import Rel8.Schema.Context.Label

39+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )

54− ( Labelable, labeler, unlabeler

55− , hlabeler, hunlabeler

56− )

57−import Rel8.Schema.Field ( Field )

40+import Rel8.Schema.Field ( Reify, Reifiable, hreify, hunreify )

58import Rel8.Schema.HTable ( HTable )

41import Rel8.Schema.HTable ( HTable )

59−import Rel8.Schema.HTable.Either ( HEitherTable )

60−import Rel8.Schema.HTable.Identity ( HIdentity(..) )

61import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )

42import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )

62−import Rel8.Schema.HTable.List ( HListTable )

63−import Rel8.Schema.HTable.Maybe ( HMaybeTable )

64−import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )

65import Rel8.Schema.HTable.Pair ( HPair(..) )

43import Rel8.Schema.HTable.Pair ( HPair(..) )

66−import Rel8.Schema.HTable.Quartet ( HQuartet(..) )

67−import Rel8.Schema.HTable.Quintet ( HQuintet(..) )

68−import Rel8.Schema.HTable.These ( HTheseTable )

69−import Rel8.Schema.HTable.Trio ( HTrio(..) )

70−import Rel8.Schema.HTable.Vectorize ( hrelabel )

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

72import qualified Rel8.Schema.Kind as K

44import qualified Rel8.Schema.Kind as K

73−import Rel8.Schema.Name ( Name( Name ), Col(..) )

45+import Rel8.Schema.Spec ( KTable )

74−import Rel8.Schema.Spec ( Spec( Spec ), KTable )

75−import Rel8.Schema.Structure

76− ( IsStructure, Shape(..), Shape1, Shape2

77− , Structure

78− )

79import Rel8.Table

46import Rel8.Table

80 ( Table, Columns, Context, fromColumns, toColumns

47 ( Table, Columns, Context, fromColumns, toColumns

81 )

48 )

82−import Rel8.Table.Either ( EitherTable )

83−import Rel8.Table.Lifted

84− ( fromColumns1, toColumns1

85− , fromColumns2, toColumns2

86− )

87−import Rel8.Table.List ( ListTable )

88−import Rel8.Table.Maybe ( MaybeTable(..) )

89−import Rel8.Table.NonEmpty ( NonEmptyTable )

90−import Rel8.Table.These ( TheseTable )

91−

92−-- these

93−import Data.These ( These )

51+instance

52+ ( Rel8able t

53+ , Labelable context

54+ , Reifiable context

55+ , HTable (GRep context t)

96−instance (Rel8able t, TableHelper context) => Table context (t context) where

56+ ) => Table context (t context)

57+ where

97− type Columns (t context) = GRep t

58+ type Columns (t context) = GRep context t

98 type Context (t context) = context

59 type Context (t context) = context

99− fromColumns = gfromColumns

100− toColumns = gtoColumns

101−

102−

103−type TableHelper :: K.Context -> Constraint

104−class TableHelper context where

105− gfromColumns :: Rel8able t => GRep t (Col context) -> t context

106− gtoColumns :: Rel8able t => t context -> GRep t (Col context)

107−

108−

109−instance TableHelper Aggregate where

110− gfromColumns = fromAggregateColumns

111− gtoColumns = toAggregateColumns

112−

113−

114−instance TableHelper Expr where

115− gfromColumns = fromExprColumns

116− gtoColumns = toExprColumns

117

118−

61+ fromColumns = unreify . gfromColumns . hreify

119−instance TableHelper Insert where

62+ toColumns = hunreify . gtoColumns . reify

120− gfromColumns = fromInsertColumns

121− gtoColumns = toInsertColumns

122−

123−

124−instance TableHelper Identity where

125− gfromColumns = fromIdentityColumns

126− gtoColumns = toIdentityColumns

127−

128−

129−instance TableHelper Name where

130− gfromColumns = fromNameColumns

131− gtoColumns = toNameColumns

132

133

134-- | This type class allows you to define custom 'Table's using higher-kinded

65-- | This type class allows you to define custom 'Table's using higher-kinded

@@ -174,876 +105,88 @@ instance TableHelper Name where

174-- deriving ( GHC.Generics.Generic, Rel8able )

105-- deriving ( GHC.Generics.Generic, Rel8able )

175-- @

106-- @

176type Rel8able :: KTable -> Constraint

107type Rel8able :: KTable -> Constraint

177−class HTable (GRep t) => Rel8able t where

108+class Rel8able t where

178− type GRep t :: K.HTable

109+ gfromColumns :: (Labelable context, Reifiable context)

179−

110+ => GRep context t (Col (Reify context)) -> t (Reify context)

180− fromAggregateColumns :: GRep t (Col Aggregate) -> t Aggregate

181− toAggregateColumns :: t Aggregate -> GRep t (Col Aggregate)

182−

183− fromExprColumns :: GRep t (Col Expr) -> t Expr

184− toExprColumns :: t Expr -> GRep t (Col Expr)

185−

186− fromInsertColumns :: GRep t (Col Insert) -> t Insert

187− toInsertColumns :: t Insert -> GRep t (Col Insert)

188−

189− fromIdentityColumns :: GRep t (Col Identity) -> t Identity

190− toIdentityColumns :: t Identity -> GRep t (Col Identity)

191−

192− fromNameColumns :: GRep t (Col Name) -> t Name

193− toNameColumns :: t Name -> GRep t (Col Name)

194−

195− type GRep t = GColumns (Rep (t Structure))

196−

197− default fromAggregateColumns ::

198− ( Generic (t Aggregate)

199− , GColumns (Rep (t Structure)) ~ GRep t

200− , GRel8able Aggregate (Rep (t Structure)) (Rep (t Aggregate))

201− ) => GRep t (Col Aggregate) -> t Aggregate

202− fromAggregateColumns = to . fromGColumns @_ @(Rep (t Structure))

203−

204− default toAggregateColumns ::

205− ( Generic (t Aggregate)

206− , GColumns (Rep (t Structure)) ~ GRep t

207− , GRel8able Aggregate (Rep (t Structure)) (Rep (t Aggregate))

208− ) => t Aggregate -> GRep t (Col Aggregate)

209− toAggregateColumns = toGColumns @_ @(Rep (t Structure)) . from

210−

211− default fromExprColumns ::

212− ( Generic (t Expr)

213− , GColumns (Rep (t Structure)) ~ GRep t

214− , GRel8able Expr (Rep (t Structure)) (Rep (t Expr))

215− ) => GRep t (Col Expr) -> t Expr

216− fromExprColumns = to . fromGColumns @_ @(Rep (t Structure))

217

111

218− default toExprColumns ::

112+ gtoColumns :: (Labelable context, Reifiable context)

219− ( Generic (t Expr)

113+ => t (Reify context) -> GRep context t (Col (Reify context))

220− , GColumns (Rep (t Structure)) ~ GRep t

221− , GRel8able Expr (Rep (t Structure)) (Rep (t Expr))

222− ) => t Expr -> GRep t (Col Expr)

223− toExprColumns = toGColumns @_ @(Rep (t Structure)) . from

224

114

225− default fromInsertColumns ::

115+ default gfromColumns :: forall context.

226− ( Generic (t Insert)

116+ ( Generic (t (Reify context))

227− , GColumns (Rep (t Structure)) ~ GRep t

117+ , GRel8able context (Rep (t (Reify context)))

228− , GRel8able Insert (Rep (t Structure)) (Rep (t Insert))

118+ ) => GRep context t (Col (Reify context)) -> t (Reify context)

229− ) => GRep t (Col Insert) -> t Insert

230− fromInsertColumns = to . fromGColumns @_ @(Rep (t Structure))

119+ gfromColumns = to . fromGColumns @_ @(Rep (t (Reify context)))

231

120

232− default toInsertColumns ::

121+ default gtoColumns :: forall context.

233− ( Generic (t Insert)

122+ ( Generic (t (Reify context))

234− , GColumns (Rep (t Structure)) ~ GRep t

123+ , GRel8able context (Rep (t (Reify context)))

235− , GRel8able Insert (Rep (t Structure)) (Rep (t Insert))

124+ ) => t (Reify context) -> GRep context t (Col (Reify context))

236− ) => t Insert -> GRep t (Col Insert)

237− toInsertColumns = toGColumns @_ @(Rep (t Structure)) . from

125+ gtoColumns = toGColumns @_ @(Rep (t (Reify context))) . from

238

126

239− default fromIdentityColumns ::

240− ( Generic (t Identity)

241− , GColumns (Rep (t Structure)) ~ GRep t

242− , GRel8able Identity (Rep (t Structure)) (Rep (t Identity))

243− ) => GRep t (Col Identity) -> t Identity

244− fromIdentityColumns = to . fromGColumns @_ @(Rep (t Structure))

245

127

246− default toIdentityColumns ::

128+type GRep :: K.Context -> K.Table -> K.HTable

247− ( Generic (t Identity)

129+type GRep context t = GColumns (Rep (t (Reify context)))

248− , GColumns (Rep (t Structure)) ~ GRep t

249− , GRel8able Identity (Rep (t Structure)) (Rep (t Identity))

250− ) => t Identity -> GRep t (Col Identity)

251− toIdentityColumns = toGColumns @_ @(Rep (t Structure)) . from

252−

253− default fromNameColumns ::

254− ( Generic (t Name)

255− , GColumns (Rep (t Structure)) ~ GRep t

256− , GRel8able Name (Rep (t Structure)) (Rep (t Name))

257− ) => GRep t (Col Name) -> t Name

258− fromNameColumns = to . fromGColumns @_ @(Rep (t Structure))

259−

260− default toNameColumns ::

261− ( Generic (t Name)

262− , GColumns (Rep (t Structure)) ~ GRep t

263− , GRel8able Name (Rep (t Structure)) (Rep (t Name))

264− ) => t Name -> GRep t (Col Name)

265− toNameColumns = toGColumns @_ @(Rep (t Structure)) . from

266

130

267

131

268type GColumns :: (Type -> Type) -> K.HTable

132type GColumns :: (Type -> Type) -> K.HTable

269−type family GColumns structure where

133+type family GColumns rep where

270− GColumns (M1 D _ structure) = GColumns structure

134+ GColumns (M1 D _ rep) = GColumns rep

271− GColumns (M1 C _ structure) = GColumns structure

135+ GColumns (M1 G.C _ rep) = GColumns rep

272− GColumns (a :*: b) = HPair (GColumns a) (GColumns b)

136+ GColumns (rep1 :*: rep2) = HPair (GColumns rep1) (GColumns rep2)

273− GColumns (M1 S ('MetaSel ('Just label) _ _ _) (K1 _ structure)) =

137+ GColumns (M1 S ('MetaSel ('Just label) _ _ _) (K1 _ a)) =

274− K1Columns label structure

138+ HLabel label (Columns a)

275

139

276

140

277−type GRel8able :: K.Context -> (Type -> Type) -> (Type -> Type) -> Constraint

141+type GRel8able :: K.Context -> (Type -> Type) -> Constraint

278−class GRel8able context structure rep where

142+class GRel8able context rep where

279− fromGColumns :: GColumns structure (Col context) -> rep x

143+ fromGColumns :: GColumns rep (Col (Reify context)) -> rep x

280− toGColumns :: rep x -> GColumns structure (Col context)

144+ toGColumns :: rep x -> GColumns rep (Col (Reify context))

281

145

282

146

283−instance GRel8able context structure rep => GRel8able context (M1 D c structure) (M1 D c rep) where

147+instance GRel8able context rep => GRel8able context (M1 D c rep) where

284− fromGColumns = M1 . fromGColumns @context @structure @rep

148+ fromGColumns = M1 . fromGColumns @context @rep

285− toGColumns (M1 a) = toGColumns @context @structure @rep a

149+ toGColumns (M1 a) = toGColumns @context @rep a

286

150

287

151

288−instance GRel8able context structure rep => GRel8able context (M1 C c structure) (M1 C c rep) where

152+instance GRel8able context rep => GRel8able context (M1 G.C c rep) where

289− fromGColumns = M1 . fromGColumns @context @structure @rep

153+ fromGColumns = M1 . fromGColumns @context @rep

290− toGColumns (M1 a) = toGColumns @context @structure @rep a

154+ toGColumns (M1 a) = toGColumns @context @rep a

291

155

292

156

293−instance (GRel8able context structure1 rep1, GRel8able context structure2 rep2) =>

157+instance (GRel8able context rep1, GRel8able context rep2) =>

294− GRel8able context (structure1 :*: structure2) (rep1 :*: rep2)

158+ GRel8able context (rep1 :*: rep2)

295 where

159 where

296 fromGColumns (HPair a b) =

160 fromGColumns (HPair a b) =

297− fromGColumns @context @structure1 @rep1 a :*:

161+ fromGColumns @context @rep1 a :*: fromGColumns @context @rep2 b

298− fromGColumns @context @structure2 @rep2 b

299 toGColumns (a :*: b) =

162 toGColumns (a :*: b) =

300− HPair

301− (toGColumns @context @structure1 @rep1 a)

163+ HPair (toGColumns @context @rep1 a) (toGColumns @context @rep2 b)

302− (toGColumns @context @structure2 @rep2 b)

303−

304−

305−instance

306− ( K1Table label context isStructure structure a

307− , meta ~ 'MetaSel ('Just label) _su _ss _ds

308− , structureK1 ~ K1 i structure

309− , k1 ~ K1 i a

310− ) => GRel8able context (M1 S meta structureK1) (M1 S meta k1)

311− where

312− fromGColumns = M1 . K1 . fromK1Columns @label @_ @_ @structure

313− toGColumns (M1 (K1 a)) = toK1Columns @label @_ @_ @structure a

314−

315−

316−type K1Columns :: Symbol -> Type -> K.HTable

317−type family K1Columns label structure where

318− K1Columns label (Shape1 'Column ('Spec '[] necessity a)) =

319− HIdentity ('Spec '[label] necessity a)

320− K1Columns _label (Shape1 'Column ('Spec (label ': labels) necessity a)) =

321− HIdentity ('Spec (label ': labels) necessity a)

322− K1Columns label (Shape2 'Either a b) =

323− HLabel label (HEitherTable (K1Columns "Left" a) (K1Columns "Right" b))

324− K1Columns label (Shape1 'List a) = HListTable (K1Columns label a)

325− K1Columns label (Shape1 'Maybe a) = HLabel label (HMaybeTable (K1Columns "Just" a))

326− K1Columns label (Shape1 'NonEmpty a) = HNonEmptyTable (K1Columns label a)

327− K1Columns label (Shape2 'These a b) =

328− HLabel label (HTheseTable (K1Columns "Here" a) (K1Columns "There" b))

329− K1Columns label (a, b) =

330− HLabel label

331− (HPair

332− (K1Columns "fst" a)

333− (K1Columns "snd" b))

334− K1Columns label (a, b, c) =

335− HLabel label

336− (HTrio

337− (K1Columns "fst" a)

338− (K1Columns "snd" b)

339− (K1Columns "trd" c))

340− K1Columns label (a, b, c, d) =

341− HLabel label

342− (HQuartet

343− (K1Columns "fst" a)

344− (K1Columns "snd" b)

345− (K1Columns "trd" c)

346− (K1Columns "frt" d))

347− K1Columns label (a, b, c, d, e) =

348− HLabel label

349− (HQuintet

350− (K1Columns "fst" a)

351− (K1Columns "snd" b)

352− (K1Columns "trd" c)

353− (K1Columns "frt" d)

354− (K1Columns "fft" e))

355− K1Columns label a = HLabel label (Columns a)

356−

357−

358−type K1Table :: Symbol -> K.Context -> Bool -> Type -> Type -> Constraint

359−class isStructure ~ IsStructure structure =>

360− K1Table label context isStructure structure a

361− where

362− fromK1Columns :: K1Columns label structure (Col context) -> a

363− toK1Columns :: a -> K1Columns label structure (Col context)

364−

365−

366−instance

367− ( x ~ Field Aggregate '[] necessity a

368− ) => K1Table label Aggregate 'True (Shape1 'Column ('Spec '[] necessity a)) x

369− where

370− fromK1Columns (HIdentity (Aggregation a)) = a

371− toK1Columns = HIdentity . Aggregation

372− {-# INLINABLE fromK1Columns #-}

373− {-# INLINABLE toK1Columns #-}

374−

375−

376−instance

377− ( x ~ Field Aggregate (label ': labels) necessity a

378− ) => K1Table _label Aggregate 'True (Shape1 'Column ('Spec (label ': labels) necessity a)) x

379− where

380− fromK1Columns (HIdentity (Aggregation a)) = a

381− toK1Columns = HIdentity . Aggregation

382− {-# INLINABLE fromK1Columns #-}

383− {-# INLINABLE toK1Columns #-}

384−

385−

386−instance

387− ( x ~ Field Expr '[] necessity a

388− ) => K1Table label Expr 'True (Shape1 'Column ('Spec '[] necessity a)) x

389− where

390− fromK1Columns (HIdentity (DB a)) = a

391− toK1Columns = HIdentity . DB

392− {-# INLINABLE fromK1Columns #-}

393− {-# INLINABLE toK1Columns #-}

394−

395−

396−instance

397− ( x ~ Field Expr (label ': labels) necessity a

398− ) => K1Table _label Expr 'True (Shape1 'Column ('Spec (label ': labels) necessity a)) x

399− where

400− fromK1Columns (HIdentity (DB a)) = a

401− toK1Columns = HIdentity . DB

402− {-# INLINABLE fromK1Columns #-}

403− {-# INLINABLE toK1Columns #-}

404

164

405

165

406instance

166instance

407− ( x ~ Field Insert '[] necessity a

167+ ( Table (Reify context) a

408− , KnownNecessity necessity

409− ) => K1Table label Insert 'True (Shape1 'Column ('Spec '[] necessity a)) x

410− where

411− fromK1Columns (HIdentity insert) = case insert of

412− RequiredInsert a -> a

413− OptionalInsert ma -> ma

414− toK1Columns a = HIdentity $ case necessitySing @necessity of

415− SRequired -> RequiredInsert a

416− SOptional -> OptionalInsert a

417− {-# INLINABLE fromK1Columns #-}

418− {-# INLINABLE toK1Columns #-}

419−

420−

421−instance

422− ( x ~ Field Insert (label ': labels) necessity a

423− , KnownNecessity necessity

424− ) => K1Table _label Insert 'True (Shape1 'Column ('Spec (label ': labels) necessity a)) x

425− where

426− fromK1Columns (HIdentity insert) = case insert of

427− RequiredInsert a -> a

428− OptionalInsert ma -> ma

429− toK1Columns a = HIdentity $ case necessitySing @necessity of

430− SRequired -> RequiredInsert a

431− SOptional -> OptionalInsert a

432− {-# INLINABLE fromK1Columns #-}

433− {-# INLINABLE toK1Columns #-}

434−

435−

436−instance

437− ( x ~ Field Identity '[] necessity a

438− ) => K1Table label Identity 'True (Shape1 'Column ('Spec '[] necessity a)) x

439− where

440− fromK1Columns (HIdentity (Result a)) = a

441− toK1Columns = HIdentity . Result

442− {-# INLINABLE fromK1Columns #-}

443− {-# INLINABLE toK1Columns #-}

444−

445−

446−instance

447− ( x ~ Field Identity (label ': labels) necessity a

448− ) => K1Table _label Identity 'True (Shape1 'Column ('Spec (label ': labels) necessity a)) x

449− where

450− fromK1Columns (HIdentity (Result a)) = a

451− toK1Columns = HIdentity . Result

452− {-# INLINABLE fromK1Columns #-}

453− {-# INLINABLE toK1Columns #-}

454−

455−

456−instance

457− ( x ~ Field Name '[] necessity a

458− ) => K1Table _label Name 'True (Shape1 'Column ('Spec (label ': labels) necessity a)) x

459− where

460− fromK1Columns (HIdentity (NameCol a)) = Name a

461− toK1Columns (Name a) = HIdentity (NameCol a)

462− {-# INLINABLE fromK1Columns #-}

463− {-# INLINABLE toK1Columns #-}

464−

465−

466−instance

467− ( x ~ Field Name (label ': labels) necessity a

468− ) => K1Table label Name 'True (Shape1 'Column ('Spec '[] necessity a)) x

469− where

470− fromK1Columns = Name . (\(NameCol a) -> a) . unlabeler . unHIdentity

471− toK1Columns = HIdentity . labeler . NameCol . (\(Name a) -> a)

472− {-# INLINABLE fromK1Columns #-}

473− {-# INLINABLE toK1Columns #-}

474−

475−

476−instance

477− ( HTable (K1Columns "Left" structure1)

478− , HTable (K1Columns "Right" structure2)

479− , K1Table "Left" Aggregate (IsStructure structure1) structure1 a

480− , K1Table "Right" Aggregate (IsStructure structure2) structure2 b

481− , e ~ EitherTable a b

482− , KnownSymbol label

483− ) => K1Table label Aggregate 'True (Shape2 'Either structure1 structure2) e

484− where

485− fromK1Columns =

486− fromColumns2

487− (fromK1Columns @"Left" @_ @_ @structure1)

488− (fromK1Columns @"Right" @_ @_ @structure2) .

489− hunlabel unlabeler

490− toK1Columns =

491− hlabel labeler .

492− toColumns2

493− (toK1Columns @"Left" @_ @_ @structure1)

494− (toK1Columns @"Right" @_ @_ @structure2)

495− {-# INLINABLE fromK1Columns #-}

496− {-# INLINABLE toK1Columns #-}

497−

498−

499−instance

500− ( HTable (K1Columns "Left" structure1)

501− , HTable (K1Columns "Right" structure2)

502− , K1Table "Left" Expr (IsStructure structure1) structure1 a

503− , K1Table "Right" Expr (IsStructure structure2) structure2 b

504− , e ~ EitherTable a b

505− , KnownSymbol label

506− ) => K1Table label Expr 'True (Shape2 'Either structure1 structure2) e

507− where

508− fromK1Columns =

509− fromColumns2

510− (fromK1Columns @"Left" @_ @_ @structure1)

511− (fromK1Columns @"Right" @_ @_ @structure2) .

512− hunlabel unlabeler

513− toK1Columns =

514− hlabel labeler .

515− toColumns2

516− (toK1Columns @"Left" @_ @_ @structure1)

517− (toK1Columns @"Right" @_ @_ @structure2)

518− {-# INLINABLE fromK1Columns #-}

519− {-# INLINABLE toK1Columns #-}

520−

521−

522−instance

523− ( HTable (K1Columns "Left" structure1)

524− , HTable (K1Columns "Right" structure2)

525− , K1Table "Left" Insert (IsStructure structure1) structure1 a

526− , K1Table "Right" Insert (IsStructure structure2) structure2 b

527− , e ~ EitherTable a b

528− , KnownSymbol label

529− ) => K1Table label Insert 'True (Shape2 'Either structure1 structure2) e

530− where

531− fromK1Columns =

532− fromColumns2

533− (fromK1Columns @"Left" @_ @_ @structure1)

534− (fromK1Columns @"Right" @_ @_ @structure2) .

535− hunlabel unlabeler

536− toK1Columns =

537− hlabel labeler .

538− toColumns2

539− (toK1Columns @"Left" @_ @_ @structure1)

540− (toK1Columns @"Right" @_ @_ @structure2)

541− {-# INLINABLE fromK1Columns #-}

542− {-# INLINABLE toK1Columns #-}

543−

544−

545−instance

546− ( HTable (K1Columns "Left" structure1)

547− , HTable (K1Columns "Right" structure2)

548− , K1Table "Left" Identity (IsStructure structure1) structure1 a

549− , K1Table "Right" Identity (IsStructure structure2) structure2 b

550− , e ~ Either a b

551− , KnownSymbol label

552− ) => K1Table label Identity 'True (Shape2 'Either structure1 structure2) e

553− where

554− fromK1Columns

555− = bimap

556− (fromK1Columns @"Left" @_ @_ @structure1)

557− (fromK1Columns @"Right" @_ @_ @structure2)

558− . fromHEitherTable

559− . hunlabel unlabeler

560− toK1Columns

561− = hlabel labeler

562− . toHEitherTable

563− . bimap

564− (toK1Columns @"Left" @_ @_ @structure1)

565− (toK1Columns @"Right" @_ @_ @structure2)

566− {-# INLINABLE fromK1Columns #-}

567− {-# INLINABLE toK1Columns #-}

568−

569−

570−instance

571− ( HTable (K1Columns "Left" structure1)

572− , HTable (K1Columns "Right" structure2)

573− , K1Table "Left" Name (IsStructure structure1) structure1 a

574− , K1Table "Right" Name (IsStructure structure2) structure2 b

575− , e ~ EitherTable a b

576− , KnownSymbol label

577− ) => K1Table label Name 'True (Shape2 'Either structure1 structure2) e

578− where

579− fromK1Columns =

580− fromColumns2

581− (fromK1Columns @"Left" @_ @_ @structure1)

582− (fromK1Columns @"Right" @_ @_ @structure2) .

583− hunlabel unlabeler

584− toK1Columns =

585− hlabel labeler .

586− toColumns2

587− (toK1Columns @"Left" @_ @_ @structure1)

588− (toK1Columns @"Right" @_ @_ @structure2)

589− {-# INLINABLE fromK1Columns #-}

590− {-# INLINABLE toK1Columns #-}

591−

592−

593−instance

594− ( Table Aggregate a

595− , K1Columns label structure ~ HLabel label (Columns a)

596− , as ~ ListTable a

597− , KnownSymbol label

598− ) => K1Table label Aggregate 'True (Shape1 'List structure) as

599− where

600− fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)

601− toK1Columns = hrelabel (hlabel hlabeler) . toColumns

602− {-# INLINABLE fromK1Columns #-}

603− {-# INLINABLE toK1Columns #-}

604−

605−

606−instance

607− ( Table Expr a

608− , K1Columns label structure ~ HLabel label (Columns a)

609− , as ~ ListTable a

610− , KnownSymbol label

611− ) => K1Table label Expr 'True (Shape1 'List structure) as

612− where

613− fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)

614− toK1Columns = hrelabel (hlabel hlabeler) . toColumns

615− {-# INLINABLE fromK1Columns #-}

616− {-# INLINABLE toK1Columns #-}

617−

618−

619−instance

620− ( Table Insert a

621− , K1Columns label structure ~ HLabel label (Columns a)

622− , as ~ ListTable a

623− , KnownSymbol label

624− ) => K1Table label Insert 'True (Shape1 'List structure) as

625− where

626− fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)

627− toK1Columns = hrelabel (hlabel hlabeler) . toColumns

628− {-# INLINABLE fromK1Columns #-}

629− {-# INLINABLE toK1Columns #-}

630−

631−

632−instance

633− ( K1Table label Identity (IsStructure structure) structure a

634− , HTable (K1Columns label structure)

635− , as ~ [a]

636− ) => K1Table label Identity 'True (Shape1 'List structure) as

637− where

638− fromK1Columns = fmap (fromK1Columns @label @_ @_ @structure) . fromHListTable

639− toK1Columns = toHListTable . fmap (toK1Columns @label @_ @_ @structure)

640− {-# INLINABLE fromK1Columns #-}

641− {-# INLINABLE toK1Columns #-}

642−

643−

644−instance

645− ( Table Name a

646− , K1Columns label structure ~ HLabel label (Columns a)

647− , as ~ ListTable a

648− , KnownSymbol label

649− ) => K1Table label Name 'True (Shape1 'List structure) as

650− where

651− fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)

652− toK1Columns = hrelabel (hlabel hlabeler) . toColumns

653− {-# INLINABLE fromK1Columns #-}

654− {-# INLINABLE toK1Columns #-}

655−

656−

657−instance

658− ( HTable (K1Columns "Just" structure)

659− , K1Table "Just" Aggregate (IsStructure structure) structure a

660− , ma ~ MaybeTable a

661− , KnownSymbol label

662− ) => K1Table label Aggregate 'True (Shape1 'Maybe structure) ma

663− where

664− fromK1Columns =

665− fromColumns1 (fromK1Columns @"Just" @_ @_ @structure) .

666− hunlabel unlabeler

667− toK1Columns =

668− hlabel labeler .

669− toColumns1 (toK1Columns @"Just" @_ @_ @structure)

670− {-# INLINABLE fromK1Columns #-}

671− {-# INLINABLE toK1Columns #-}

672−

673−

674−instance

675− ( HTable (K1Columns "Just" structure)

676− , K1Table "Just" Expr (IsStructure structure) structure a

677− , ma ~ MaybeTable a

678− , KnownSymbol label

679− ) => K1Table label Expr 'True (Shape1 'Maybe structure) ma

680− where

681− fromK1Columns =

682− fromColumns1 (fromK1Columns @"Just" @_ @_ @structure) .

683− hunlabel unlabeler

684− toK1Columns =

685− hlabel labeler .

686− toColumns1 (toK1Columns @"Just" @_ @_ @structure)

687− {-# INLINABLE fromK1Columns #-}

688− {-# INLINABLE toK1Columns #-}

689−

690−

691−instance

692− ( HTable (K1Columns "Just" structure)

693− , K1Table "Just" Insert (IsStructure structure) structure a

694− , ma ~ MaybeTable a

695− , KnownSymbol label

696− ) => K1Table label Insert 'True (Shape1 'Maybe structure) ma

697− where

698− fromK1Columns =

699− fromColumns1 (fromK1Columns @"Just" @_ @_ @structure) .

700− hunlabel unlabeler

701− toK1Columns =

702− hlabel labeler .

703− toColumns1 (toK1Columns @"Just" @_ @_ @structure)

704− {-# INLINABLE fromK1Columns #-}

705− {-# INLINABLE toK1Columns #-}

706−

707−

708−instance

709− ( HTable (K1Columns "Just" structure)

710− , K1Table "Just" Identity (IsStructure structure) structure a

711− , ma ~ Maybe a

712− , KnownSymbol label

713− ) => K1Table label Identity 'True (Shape1 'Maybe structure) ma

714− where

715− fromK1Columns

716− = fmap (fromK1Columns @"Just" @_ @_ @structure)

717− . fromHMaybeTable

718− . hunlabel unlabeler

719− toK1Columns

720− = hlabel labeler

721− . toHMaybeTable

722− . fmap (toK1Columns @"Just" @_ @_ @structure)

723− {-# INLINABLE fromK1Columns #-}

724− {-# INLINABLE toK1Columns #-}

725−

726−

727−instance

728− ( HTable (K1Columns "Just" structure)

729− , K1Table "Just" Name (IsStructure structure) structure a

730− , ma ~ MaybeTable a

731− , KnownSymbol label

732− ) => K1Table label Name 'True (Shape1 'Maybe structure) ma

733− where

734− fromK1Columns =

735− fromColumns1 (fromK1Columns @"Just" @_ @_ @structure) .

736− hunlabel unlabeler

737− toK1Columns =

738− hlabel labeler .

739− toColumns1 (toK1Columns @"Just" @_ @_ @structure)

740− {-# INLINABLE fromK1Columns #-}

741− {-# INLINABLE toK1Columns #-}

742−

743−

744−instance

745− ( Table Aggregate a

746− , K1Columns label structure ~ HLabel label (Columns a)

747− , as ~ NonEmptyTable a

748− , KnownSymbol label

749− ) => K1Table label Aggregate 'True (Shape1 'NonEmpty structure) as

750− where

751− fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)

752− toK1Columns = hrelabel (hlabel hlabeler) . toColumns

753− {-# INLINABLE fromK1Columns #-}

754− {-# INLINABLE toK1Columns #-}

755−

756−

757−instance

758− ( Table Expr a

759− , K1Columns label structure ~ HLabel label (Columns a)

760− , as ~ NonEmptyTable a

761− , KnownSymbol label

762− ) => K1Table label Expr 'True (Shape1 'NonEmpty structure) as

763− where

764− fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)

765− toK1Columns = hrelabel (hlabel hlabeler) . toColumns

766− {-# INLINABLE fromK1Columns #-}

767− {-# INLINABLE toK1Columns #-}

768−

769−

770−instance

771− ( Table Insert a

772− , K1Columns label structure ~ HLabel label (Columns a)

773− , as ~ NonEmptyTable a

774− , KnownSymbol label

775− ) => K1Table label Insert 'True (Shape1 'NonEmpty structure) as

776− where

777− fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)

778− toK1Columns = hrelabel (hlabel hlabeler) . toColumns

779− {-# INLINABLE fromK1Columns #-}

780− {-# INLINABLE toK1Columns #-}

781−

782−

783−instance

784− ( K1Table label Identity (IsStructure structure) structure a

785− , HTable (K1Columns label structure)

786− , as ~ NonEmpty a

787− ) => K1Table label Identity 'True (Shape1 'NonEmpty structure) as

788− where

789− fromK1Columns = fmap (fromK1Columns @label @_ @_ @structure) . fromHNonEmptyTable

790− toK1Columns = toHNonEmptyTable . fmap (toK1Columns @label @_ @_ @structure)

791− {-# INLINABLE fromK1Columns #-}

792− {-# INLINABLE toK1Columns #-}

793−

794−

795−instance

796− ( Table Name a

797− , K1Columns label structure ~ HLabel label (Columns a)

798− , as ~ NonEmptyTable a

799− , KnownSymbol label

800− ) => K1Table label Name 'True (Shape1 'NonEmpty structure) as

801− where

802− fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)

803− toK1Columns = hrelabel (hlabel hlabeler) . toColumns

804− {-# INLINABLE fromK1Columns #-}

805− {-# INLINABLE toK1Columns #-}

806−

807−

808−instance

809− ( HTable (K1Columns "Here" structure1)

810− , HTable (K1Columns "There" structure2)

811− , K1Table "Here" Aggregate (IsStructure structure1) structure1 a

812− , K1Table "There" Aggregate (IsStructure structure2) structure2 b

813− , e ~ TheseTable a b

814− , KnownSymbol label

815− ) => K1Table label Aggregate 'True (Shape2 'These structure1 structure2) e

816− where

817− fromK1Columns =

818− fromColumns2

819− (fromK1Columns @"Here" @_ @_ @structure1)

820− (fromK1Columns @"There" @_ @_ @structure2) .

821− hunlabel unlabeler

822− toK1Columns =

823− hlabel labeler .

824− toColumns2

825− (toK1Columns @"Here" @_ @_ @structure1)

826− (toK1Columns @"There" @_ @_ @structure2)

827− {-# INLINABLE fromK1Columns #-}

828− {-# INLINABLE toK1Columns #-}

829−

830−

831−instance

832− ( HTable (K1Columns "Here" structure1)

833− , HTable (K1Columns "There" structure2)

834− , K1Table "Here" Expr (IsStructure structure1) structure1 a

835− , K1Table "There" Expr (IsStructure structure2) structure2 b

836− , e ~ TheseTable a b

837− , KnownSymbol label

838− ) => K1Table label Expr 'True (Shape2 'These structure1 structure2) e

839− where

840− fromK1Columns =

841− fromColumns2

842− (fromK1Columns @"Here" @_ @_ @structure1)

843− (fromK1Columns @"There" @_ @_ @structure2) .

844− hunlabel unlabeler

845− toK1Columns =

846− hlabel labeler .

847− toColumns2

848− (toK1Columns @"Here" @_ @_ @structure1)

849− (toK1Columns @"There" @_ @_ @structure2)

850− {-# INLINABLE fromK1Columns #-}

851− {-# INLINABLE toK1Columns #-}

852−

853−

854−instance

855− ( HTable (K1Columns "Here" structure1)

856− , HTable (K1Columns "There" structure2)

857− , K1Table "Here" Insert (IsStructure structure1) structure1 a

858− , K1Table "There" Insert (IsStructure structure2) structure2 b

859− , e ~ TheseTable a b

860− , KnownSymbol label

861− ) => K1Table label Insert 'True (Shape2 'These structure1 structure2) e

862− where

863− fromK1Columns =

864− fromColumns2

865− (fromK1Columns @"Here" @_ @_ @structure1)

866− (fromK1Columns @"There" @_ @_ @structure2) .

867− hunlabel unlabeler

868− toK1Columns =

869− hlabel labeler .

870− toColumns2

871− (toK1Columns @"Here" @_ @_ @structure1)

872− (toK1Columns @"There" @_ @_ @structure2)

873− {-# INLINABLE fromK1Columns #-}

874− {-# INLINABLE toK1Columns #-}

875−

876−

877−instance

878− ( HTable (K1Columns "Here" structure1)

879− , HTable (K1Columns "There" structure2)

880− , K1Table "Here" Identity (IsStructure structure1) structure1 a

881− , K1Table "There" Identity (IsStructure structure2) structure2 b

882− , e ~ These a b

883− , KnownSymbol label

884− ) => K1Table label Identity 'True (Shape2 'These structure1 structure2) e

885− where

886− fromK1Columns

887− = bimap

888− (fromK1Columns @"Here" @_ @_ @structure1)

889− (fromK1Columns @"There" @_ @_ @structure2)

890− . fromHTheseTable

891− . hunlabel unlabeler

892− toK1Columns

893− = hlabel labeler

894− . toHTheseTable

895− . bimap

896− (toK1Columns @"Here" @_ @_ @structure1)

897− (toK1Columns @"There" @_ @_ @structure2)

898− {-# INLINABLE fromK1Columns #-}

899− {-# INLINABLE toK1Columns #-}

900−

901−

902−instance

903− ( HTable (K1Columns "Here" structure1)

904− , HTable (K1Columns "There" structure2)

905− , K1Table "Here" Name (IsStructure structure1) structure1 a

906− , K1Table "There" Name (IsStructure structure2) structure2 b

907− , e ~ TheseTable a b

908− , KnownSymbol label

909− ) => K1Table label Name 'True (Shape2 'These structure1 structure2) e

910− where

911− fromK1Columns =

912− fromColumns2

913− (fromK1Columns @"Here" @_ @_ @structure1)

914− (fromK1Columns @"There" @_ @_ @structure2) .

915− hunlabel unlabeler

916− toK1Columns =

917− hlabel labeler .

918− toColumns2

919− (toK1Columns @"Here" @_ @_ @structure1)

920− (toK1Columns @"There" @_ @_ @structure2)

921− {-# INLINABLE fromK1Columns #-}

922− {-# INLINABLE toK1Columns #-}

923−

924−

925−instance

926− ( K1Table "fst" context (IsStructure structure1) structure1 a1

927− , K1Table "snd" context (IsStructure structure2) structure2 a2

928− , HTable (K1Columns "fst" structure1)

929− , HTable (K1Columns "snd" structure2)

930− , Labelable context

931− , a ~ (a1, a2)

932− , KnownSymbol label

933− ) => K1Table label context 'True (structure1, structure2) a

934− where

935− fromK1Columns (hunlabel unlabeler -> (HPair a b)) =

936− ( fromK1Columns @"fst" @_ @_ @structure1 a

937− , fromK1Columns @"snd" @_ @_ @structure2 b

938− )

939− toK1Columns (a, b) = hlabel labeler $ HPair

940− { hfst = toK1Columns @"fst" @_ @_ @structure1 a

941− , hsnd = toK1Columns @"snd" @_ @_ @structure2 b

942− }

943− {-# INLINABLE fromK1Columns #-}

944− {-# INLINABLE toK1Columns #-}

945−

946−

947−instance

948− ( K1Table "fst" context (IsStructure structure1) structure1 a1

949− , K1Table "snd" context (IsStructure structure2) structure2 a2

950− , K1Table "trd" context (IsStructure structure3) structure3 a3

951− , HTable (K1Columns "fst" structure1)

952− , HTable (K1Columns "snd" structure2)

953− , HTable (K1Columns "trd" structure3)

954− , Labelable context

955− , a ~ (a1, a2, a3)

956− , KnownSymbol label

957− ) => K1Table label context 'True (structure1, structure2, structure3) a

958− where

959− fromK1Columns (hunlabel unlabeler -> (HTrio a b c)) =

960− ( fromK1Columns @"fst" @_ @_ @structure1 a

961− , fromK1Columns @"snd" @_ @_ @structure2 b

962− , fromK1Columns @"trd" @_ @_ @structure3 c

963− )

964− toK1Columns (a, b, c) = hlabel labeler $ HTrio

965− { hfst = toK1Columns @"fst" @_ @_ @structure1 a

966− , hsnd = toK1Columns @"snd" @_ @_ @structure2 b

967− , htrd = toK1Columns @"trd" @_ @_ @structure3 c

968− }

969− {-# INLINABLE fromK1Columns #-}

970− {-# INLINABLE toK1Columns #-}

971−

972−

973−instance

974− ( K1Table "fst" context (IsStructure structure1) structure1 a1

975− , K1Table "snd" context (IsStructure structure2) structure2 a2

976− , K1Table "trd" context (IsStructure structure3) structure3 a3

977− , K1Table "frt" context (IsStructure structure3) structure4 a4

978− , HTable (K1Columns "fst" structure1)

979− , HTable (K1Columns "snd" structure2)

980− , HTable (K1Columns "trd" structure3)

981− , HTable (K1Columns "frt" structure4)

982 , Labelable context

168 , Labelable context

983− , a ~ (a1, a2, a3, a4)

984 , KnownSymbol label

169 , KnownSymbol label

985− ) => K1Table label context 'True (structure1, structure2, structure3, structure4) a

170+ , GColumns (M1 S meta k1) ~ HLabel label (Columns a)

171+ , meta ~ 'MetaSel ('Just label) _su _ss _ds

172+ , k1 ~ K1 i a

173+ ) => GRel8able context (M1 S meta k1)

986 where

174 where

987− fromK1Columns (hunlabel unlabeler -> (HQuartet a b c d)) =

175+ fromGColumns = M1 . K1 . fromColumns . hunlabel unlabeler

988− ( fromK1Columns @"fst" @_ @_ @structure1 a

176+ toGColumns (M1 (K1 a)) = hlabel labeler (toColumns a)

989− , fromK1Columns @"snd" @_ @_ @structure2 b

990− , fromK1Columns @"trd" @_ @_ @structure3 c

991− , fromK1Columns @"frt" @_ @_ @structure4 d

992− )

993− toK1Columns (a, b, c, d) = hlabel labeler $ HQuartet

994− { hfst = toK1Columns @"fst" @_ @_ @structure1 a

995− , hsnd = toK1Columns @"snd" @_ @_ @structure2 b

996− , htrd = toK1Columns @"trd" @_ @_ @structure3 c

997− , hfrt = toK1Columns @"frt" @_ @_ @structure4 d

998− }

999− {-# INLINABLE fromK1Columns #-}

1000− {-# INLINABLE toK1Columns #-}

1001

177

1002

178

1003−instance

179+reify ::

1004− ( K1Table "fst" context (IsStructure structure1) structure1 a1

180+ (-- Rel8able t

1005− , K1Table "snd" context (IsStructure structure2) structure2 a2

181+ --, forall necessity a. Coercible (Field context necessity a) (AField context necessity a) => Coercible (t context) (t (Reify context))

1006− , K1Table "trd" context (IsStructure structure3) structure3 a3

182+ )

1007− , K1Table "frt" context (IsStructure structure3) structure4 a4

183+ => t context -> t (Reify context)

1008− , K1Table "fft" context (IsStructure structure3) structure5 a5

184+reify = unsafeCoerce

1009− , HTable (K1Columns "fst" structure1)

1010− , HTable (K1Columns "snd" structure2)

1011− , HTable (K1Columns "trd" structure3)

1012− , HTable (K1Columns "frt" structure4)

1013− , HTable (K1Columns "fft" structure5)

1014− , Labelable context

1015− , a ~ (a1, a2, a3, a4, a5)

1016− , KnownSymbol label

1017− ) => K1Table label context 'True (structure1, structure2, structure3, structure4, structure5) a

1018− where

1019− fromK1Columns (hunlabel unlabeler -> (HQuintet a b c d e)) =

1020− ( fromK1Columns @"fst" @_ @_ @structure1 a

1021− , fromK1Columns @"snd" @_ @_ @structure2 b

1022− , fromK1Columns @"trd" @_ @_ @structure3 c

1023− , fromK1Columns @"frt" @_ @_ @structure4 d

1024− , fromK1Columns @"fft" @_ @_ @structure5 e

1025− )

1026− toK1Columns (a, b, c, d, e) = hlabel labeler $ HQuintet

1027− { hfst = toK1Columns @"fst" @_ @_ @structure1 a

1028− , hsnd = toK1Columns @"snd" @_ @_ @structure2 b

1029− , htrd = toK1Columns @"trd" @_ @_ @structure3 c

1030− , hfrt = toK1Columns @"frt" @_ @_ @structure4 d

1031− , hfft = toK1Columns @"fft" @_ @_ @structure5 e

1032− }

1033− {-# INLINABLE fromK1Columns #-}

1034− {-# INLINABLE toK1Columns #-}

1035

185

1036

186

1037−instance

187+unreify ::

1038− ( IsStructure structure ~ 'False

188+ (-- Rel8able t

1039− , K1Columns label structure ~ HLabel label (Columns structure)

189+ --, forall necessity a. Coercible (AField context necessity a) (Field context necessity a) => Coercible (t (Reify context)) (t context)

1040− , Columns structure ~ Columns a

190+ )

1041− , Labelable context

191+ => t (Reify context) -> t context

1042− , Table context a

192+unreify = unsafeCoerce

1043− , KnownSymbol label

1044− ) => K1Table label context 'False structure a

1045− where

1046− fromK1Columns = fromColumns . hunlabel unlabeler

1047− toK1Columns = hlabel labeler . toColumns

1048− {-# INLINABLE fromK1Columns #-}

1049− {-# INLINABLE toK1Columns #-}

src/Rel8/Schema/Generic/Test.hs+4−5

@@ -4,8 +4,6 @@

4{-# language DerivingStrategies #-}

5{-# language DuplicateRecordFields #-}

7−{-# options_ghc -O0 #-}

8−

9module Rel8.Schema.Generic.Test

7module Rel8.Schema.Generic.Test

10 ( module Rel8.Schema.Generic.Test

8 ( module Rel8.Schema.Generic.Test

11 )

9 )

@@ -17,6 +15,7 @@ import Prelude

18-- rel8

16-- rel8

19import Rel8.Schema.Column

17import Rel8.Schema.Column

18+import Rel8.Schema.Field

20import Rel8.Schema.Generic

19import Rel8.Schema.Generic

22-- text

21-- text

@@ -24,7 +23,7 @@ import Data.Text ( Text )

26data Table f = Table

25data Table f = Table

27− { foo :: Column f (Label "blah" Bool)

26+ { foo :: Column f Bool

28 , bar :: Column f (Maybe Bool)

27 , bar :: Column f (Maybe Bool)

29 }

28 }

30 deriving stock Generic

29 deriving stock Generic

@@ -40,7 +39,7 @@ data TablePair f = TablePair

42data TableMaybe f = TableMaybe

41data TableMaybe f = TableMaybe

43− { foo :: Column f (Label "ABC" [Maybe Bool])

42+ { foo :: Column f [Maybe Bool]

44 , bars :: HMaybe f (TablePair f, TablePair f)

43 , bars :: HMaybe f (TablePair f, TablePair f)

45 }

44 }

46 deriving stock Generic

45 deriving stock Generic

@@ -49,7 +48,7 @@ data TableMaybe f = TableMaybe

50data TableEither f = TableEither

49data TableEither f = TableEither

51 { foo :: Column f Bool

50 { foo :: Column f Bool

52− , bars :: HEither f (HMaybe f (TablePair f, TablePair f)) (Column f (Label "XYZ" Char))

51+ , bars :: HEither f (HMaybe f (TablePair f, TablePair f)) (Column f Char)

53 }

52 }

54 deriving stock Generic

53 deriving stock Generic

55 deriving anyclass Rel8able

54 deriving anyclass Rel8able

src/Rel8/Schema/HTable/Either.hs+3−13

@@ -2,27 +2,22 @@

2{-# language DeriveAnyClass #-}

3{-# language DeriveGeneric #-}

4{-# language DerivingStrategies #-}

5−{-# language FlexibleInstances #-}

6{-# language StandaloneKindSignatures #-}

5{-# language StandaloneKindSignatures #-}

7−{-# language UndecidableInstances #-}

8−{-# language UndecidableSuperClasses #-}

10module Rel8.Schema.HTable.Either

7module Rel8.Schema.HTable.Either

11 ( HEitherTable(..)

8 ( HEitherTable(..)

12− , HEitherNullifiable

13 )

9 )

14where

10where

16-- base

12-- base

17−import Data.Kind ( Constraint )

18import GHC.Generics ( Generic )

13import GHC.Generics ( Generic )

19import Prelude ()

14import Prelude ()

21-- rel8

16-- rel8

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

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

23−import Rel8.Schema.Context.Nullify ( HNullifiable, HConstrainTag )

24import Rel8.Schema.HTable ( HTable )

18import Rel8.Schema.HTable ( HTable )

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

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

20+import Rel8.Schema.HTable.Label ( HLabel )

26import Rel8.Schema.HTable.Nullify ( HNullify )

21import Rel8.Schema.HTable.Nullify ( HNullify )

27import qualified Rel8.Schema.Kind as K

22import qualified Rel8.Schema.Kind as K

28import Rel8.Schema.Spec ( Spec( Spec ) )

23import Rel8.Schema.Spec ( Spec( Spec ) )

@@ -32,13 +27,8 @@ import Rel8.Type.Tag ( EitherTag )

32type HEitherTable :: K.HTable -> K.HTable -> K.HTable

27type HEitherTable :: K.HTable -> K.HTable -> K.HTable

33data HEitherTable left right context = HEitherTable

28data HEitherTable left right context = HEitherTable

34 { htag :: HIdentity ('Spec '["isRight"] 'Required EitherTag) context

29 { htag :: HIdentity ('Spec '["isRight"] 'Required EitherTag) context

35− , hleft :: HNullify left context

30+ , hleft :: HLabel "Left" (HNullify left) context

36− , hright :: HNullify right context

31+ , hright :: HLabel "Right" (HNullify right) context

37 }

32 }

38 deriving stock Generic

33 deriving stock Generic

39 deriving anyclass HTable

34 deriving anyclass HTable

40−

41−

42−type HEitherNullifiable :: K.HContext -> Constraint

43−class (HNullifiable context, HConstrainTag context EitherTag) => HEitherNullifiable context

44−instance (HNullifiable context, HConstrainTag context EitherTag) => HEitherNullifiable context

src/Rel8/Schema/HTable/MapTable.hs+8−4

@@ -35,13 +35,15 @@ import Rel8.Schema.Dict ( Dict( Dict ) )

37type HMapTable :: (a -> Exp b) -> ((a -> Type) -> Type) -> (b -> Type) -> Type

38−data HMapTable f t g where

38+newtype HMapTable f t g = HMapTable

39− HMapTable :: { unHMapTable :: t (Precompose f g) } -> HMapTable f t g

39+ { unHMapTable :: t (Precompose f g)

40+ }

42type Precompose :: (a -> Exp b) -> (b -> Type) -> a -> Type

43type Precompose :: (a -> Exp b) -> (b -> Type) -> a -> Type

43−newtype Precompose f g x where

44+newtype Precompose f g x = Precompose

44− Precompose :: { precomposed :: g (Eval (f x)) } -> Precompose f g x

45+ { precomposed :: g (Eval (f x))

46+ }

47type HMapTableField :: (Spec -> Exp a) -> K.HTable -> a -> Type

49type HMapTableField :: (Spec -> Exp a) -> K.HTable -> a -> Type

@@ -64,6 +66,7 @@ instance (HTable t, MapSpec f) => HTable (HMapTable f t) where

65 htraverse f (HMapTable x) =

67 htraverse f (HMapTable x) =

66 HMapTable <$> htraverse (fmap Precompose . f . precomposed) x

68 HMapTable <$> htraverse (fmap Precompose . f . precomposed) x

69+ {-# INLINABLE htraverse #-}

68 hdicts :: forall c. HConstrainTable (HMapTable f t) c => HMapTable f t (Dict c)

71 hdicts :: forall c. HConstrainTable (HMapTable f t) c => HMapTable f t (Dict c)

69 hdicts =

72 hdicts =

@@ -73,6 +76,7 @@ instance (HTable t, MapSpec f) => HTable (HMapTable f t) where

74 hspecs =

77 hspecs =

75 HMapTable $ htabulate $ Precompose . mapInfo @f . hfield hspecs

78 HMapTable $ htabulate $ Precompose . mapInfo @f . hfield hspecs

79+ {-# INLINABLE hspecs #-}

78type MapSpec :: (Spec -> Exp Spec) -> Constraint

82type MapSpec :: (Spec -> Exp Spec) -> Constraint

src/Rel8/Schema/HTable/Maybe.hs+3−13

@@ -2,42 +2,32 @@

2{-# language DeriveAnyClass #-}

3{-# language DeriveGeneric #-}

4{-# language DerivingStrategies #-}

5−{-# language FlexibleInstances #-}

6{-# language StandaloneKindSignatures #-}

5{-# language StandaloneKindSignatures #-}

7−{-# language UndecidableInstances #-}

8−{-# language UndecidableSuperClasses #-}

10module Rel8.Schema.HTable.Maybe

7module Rel8.Schema.HTable.Maybe

11 ( HMaybeTable(..)

8 ( HMaybeTable(..)

12− , HMaybeNullifiable

13 )

9 )

14where

10where

16-- base

12-- base

17−import Data.Kind ( Constraint )

18import GHC.Generics ( Generic )

13import GHC.Generics ( Generic )

19import Prelude

14import Prelude

21-- rel8

16-- rel8

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

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

23−import Rel8.Schema.Context.Nullify ( HConstrainTag, HNullifiable )

24import Rel8.Schema.HTable ( HTable )

18import Rel8.Schema.HTable ( HTable )

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

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

20+import Rel8.Schema.HTable.Label ( HLabel )

21+import Rel8.Schema.HTable.Nullify ( HNullify )

26import qualified Rel8.Schema.Kind as K

22import qualified Rel8.Schema.Kind as K

27import Rel8.Schema.Spec ( Spec( Spec ) )

23import Rel8.Schema.Spec ( Spec( Spec ) )

28import Rel8.Type.Tag ( MaybeTag )

24import Rel8.Type.Tag ( MaybeTag )

29−import Rel8.Schema.HTable.Nullify ( HNullify )

32type HMaybeTable :: K.HTable -> K.HTable

27type HMaybeTable :: K.HTable -> K.HTable

33data HMaybeTable table context = HMaybeTable

28data HMaybeTable table context = HMaybeTable

34 { htag :: HIdentity ('Spec '["isJust"] 'Required (Maybe MaybeTag)) context

29 { htag :: HIdentity ('Spec '["isJust"] 'Required (Maybe MaybeTag)) context

35− , hjust :: HNullify table context

30+ , hjust :: HLabel "Just" (HNullify table) context

36 }

31 }

37 deriving stock Generic

32 deriving stock Generic

38 deriving anyclass HTable

33 deriving anyclass HTable

39−

40−

41−type HMaybeNullifiable :: K.HContext -> Constraint

42−class (HNullifiable context, HConstrainTag context MaybeTag) => HMaybeNullifiable context

43−instance (HNullifiable context, HConstrainTag context MaybeTag) => HMaybeNullifiable context

src/Rel8/Schema/HTable/These.hs+3−2

@@ -17,6 +17,7 @@ import Prelude

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

18import Rel8.Schema.HTable ( HTable )

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

20+import Rel8.Schema.HTable.Label ( HLabel )

20import Rel8.Schema.HTable.Nullify ( HNullify )

21import Rel8.Schema.HTable.Nullify ( HNullify )

21import qualified Rel8.Schema.Kind as K

22import qualified Rel8.Schema.Kind as K

22import Rel8.Schema.Spec ( Spec( Spec ) )

23import Rel8.Schema.Spec ( Spec( Spec ) )

@@ -26,9 +27,9 @@ import Rel8.Type.Tag ( MaybeTag )

26type HTheseTable :: K.HTable -> K.HTable -> K.HTable

27type HTheseTable :: K.HTable -> K.HTable -> K.HTable

27data HTheseTable here there context = HTheseTable

28data HTheseTable here there context = HTheseTable

28 { hhereTag :: HIdentity ('Spec '["hasHere"] 'Required (Maybe MaybeTag)) context

29 { hhereTag :: HIdentity ('Spec '["hasHere"] 'Required (Maybe MaybeTag)) context

29− , hhere :: HNullify here context

30+ , hhere :: HLabel "Here" (HNullify here) context

30 , hthereTag :: HIdentity ('Spec '["hasThere"] 'Required (Maybe MaybeTag)) context

31 , hthereTag :: HIdentity ('Spec '["hasThere"] 'Required (Maybe MaybeTag)) context

31− , hthere :: HNullify there context

32+ , hthere :: HLabel "There" (HNullify there) context

32 }

33 }

33 deriving stock Generic

34 deriving stock Generic

34 deriving anyclass HTable

35 deriving anyclass HTable

src/Rel8/Schema/HTable/Vectorize.hs−8

@@ -23,7 +23,6 @@ module Rel8.Schema.HTable.Vectorize

23 ( HVectorize

24 , hvectorize, hunvectorize

25 , happend, hempty

26− , hrelabel

27 )

26 )

28where

27where

@@ -150,10 +149,3 @@ hempty empty = HVectorize $ htabulate $ \(HMapTableField field) -> case hfield h

150instance HLabelable g => HLabelable (Precompose (Vectorize list) g) where

149instance HLabelable g => HLabelable (Precompose (Vectorize list) g) where

151 hlabeler = Precompose . hlabeler . precomposed

150 hlabeler = Precompose . hlabeler . precomposed

152 hunlabeler = Precompose . hunlabeler . precomposed

151 hunlabeler = Precompose . hunlabeler . precomposed

153−

154−

155−hrelabel :: HLabelable context

156− => (forall ctx. HLabelable ctx => t ctx -> u ctx)

157− -> HVectorize list t context

158− -> HVectorize list u context

159−hrelabel f (HVectorize (HMapTable table)) = HVectorize (HMapTable (f table))

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

@@ -15,8 +15,8 @@ module Rel8.Schema.Insert

15 ( Insert(..)

16 , OnConflict(..)

17 , Col( RequiredInsert, OptionalInsert )

18− , Insertion(..)

19 , Inserts

18 , Inserts

19+ , Insertion(..)

20 )

21where

@@ -35,7 +35,7 @@ import Rel8.Schema.Context.Nullify

35 ( Nullifiable, encodeTag, decodeTag, nullifier, unnullifier

36 , runTag, unnull

37 )

38−import Rel8.Schema.HTable.Type ( HType(HType) )

38+import Rel8.Schema.HTable.Type ( HType( HType ) )

39import qualified Rel8.Schema.Kind as K

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

41import Rel8.Schema.Null ( Sql )

src/Rel8/Schema/Structure.hs+3−40

@@ -1,54 +1,17 @@

1{-# language DataKinds #-}

2{-# language StandaloneKindSignatures #-}

3−{-# language PolyKinds #-}

4−{-# language TypeFamilies #-}

6module Rel8.Schema.Structure

4module Rel8.Schema.Structure

7 ( Structure

5 ( Structure

8− , Shape( Column, Either, List, Maybe, NonEmpty, These )

9− , Shape1

10− , Shape2

11− , IsStructure

12 )

6 )

13where

7where

15-- base

9-- base

16−import Data.Kind ( Type )

10+import Prelude ()

17−import Prelude

19-- rel8

12-- rel8

20−import qualified Rel8.Schema.Kind as K

13+import Rel8.Schema.Kind ( Context )

21−import Rel8.Schema.Spec ( Spec )

24−type Structure :: K.Context

16+type Structure :: Context

25data Structure a

17data Structure a

26−

27−

28−type Shape :: Type

29−data Shape

30− = Column Spec

31− | Either Type Type

32− | List Type

33− | Maybe Type

34− | NonEmpty Type

35− | These Type Type

36−

37−

38−type Shape1 :: (a -> Shape) -> a -> Type

39−data Shape1 shape a

40−

41−

42−type Shape2 :: (a -> b -> Shape) -> a -> b -> Type

43−data Shape2 shape a b

44−

45−

46−type IsStructure :: Type -> Bool

47−type family IsStructure a where

48− IsStructure (Shape1 _ _) = 'True

49− IsStructure (Shape2 _ _ _) = 'True

50− IsStructure (_, _) = 'True

51− IsStructure (_, _, _) = 'True

52− IsStructure (_, _, _, _) = 'True

53− IsStructure (_, _, _, _, _) = 'True

54− IsStructure _ = 'False

src/Rel8/Table.hs+163−3

@@ -3,8 +3,11 @@

3{-# language FlexibleContexts #-}

4{-# language FlexibleInstances #-}

5{-# language FunctionalDependencies #-}

6+{-# language LambdaCase #-}

7+{-# language NamedFieldPuns #-}

6{-# language StandaloneKindSignatures #-}

8{-# language StandaloneKindSignatures #-}

7{-# language TypeFamilies #-}

9{-# language TypeFamilies #-}

10+{-# language TypeOperators #-}

8{-# language UndecidableInstances #-}

11{-# language UndecidableInstances #-}

10module Rel8.Table

13module Rel8.Table

@@ -15,25 +18,39 @@ module Rel8.Table

15where

18where

17-- base

20-- base

21+import Data.Functor ( ($>) )

18import Data.Functor.Identity ( Identity( Identity ) )

22import Data.Functor.Identity ( Identity( Identity ) )

19import Data.Kind ( Constraint, Type )

23import Data.Kind ( Constraint, Type )

20−import Prelude

24+import Data.List.NonEmpty ( NonEmpty )

25+import Prelude hiding ( null )

22-- rel8

27-- rel8

23import Rel8.Schema.Context ( Col(..) )

28import Rel8.Schema.Context ( Col(..) )

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

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

25import Rel8.Schema.HTable ( HTable )

30import Rel8.Schema.HTable ( HTable )

31+import Rel8.Schema.HTable.Either ( HEitherTable(..) )

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

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

27import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )

33import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )

34+import Rel8.Schema.HTable.List ( HListTable )

35+import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )

36+import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )

37+import Rel8.Schema.HTable.Nullify ( hnulls, hnullify, hunnullify )

28import Rel8.Schema.HTable.Pair ( HPair(..) )

38import Rel8.Schema.HTable.Pair ( HPair(..) )

29import Rel8.Schema.HTable.Quartet ( HQuartet(..) )

39import Rel8.Schema.HTable.Quartet ( HQuartet(..) )

30import Rel8.Schema.HTable.Quintet ( HQuintet(..) )

40import Rel8.Schema.HTable.Quintet ( HQuintet(..) )

41+import Rel8.Schema.HTable.These ( HTheseTable(..) )

31import Rel8.Schema.HTable.Trio ( HTrio(..) )

42import Rel8.Schema.HTable.Trio ( HTrio(..) )

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

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

44+import Rel8.Schema.HTable.Vectorize ( hvectorize, hunvectorize )

33import qualified Rel8.Schema.Kind as K

45import qualified Rel8.Schema.Kind as K

34−import Rel8.Schema.Null ( Sql )

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

35−import Rel8.Schema.Spec ( KnownSpec )

47+import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..), KnownSpec )

36import Rel8.Type ( DBType )

48import Rel8.Type ( DBType )

49+import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), MaybeTag( IsJust ) )

50+

51+-- these

52+import Data.These ( These( This, That, These ) )

53+import Data.These.Combinators ( justHere, justThere )

39-- | @Table@s are one of the foundational elements of Rel8, and describe data

56-- | @Table@s are one of the foundational elements of Rel8, and describe data

@@ -85,6 +102,106 @@ instance Sql DBType a => Table Identity (Identity a) where

85 fromColumns (HType (Result a)) = Identity a

102 fromColumns (HType (Result a)) = Identity a

103

104

105+instance (Table Identity a, Table Identity b) => Table Identity (Either a b)

106+ where

107+ type Columns (Either a b) = HEitherTable (Columns a) (Columns b)

108+ type Context (Either a b) = Identity

109+

110+ toColumns = \case

111+ Left table -> HEitherTable

112+ { htag = HIdentity (Result IsLeft)

113+ , hleft = hlabel labeler (hnullify nullifier (toColumns table))

114+ , hright = hlabel labeler (hnulls null)

115+ }

116+ Right table -> HEitherTable

117+ { htag = HIdentity (Result IsRight)

118+ , hleft = hlabel labeler (hnulls null)

119+ , hright = hlabel labeler (hnullify nullifier (toColumns table))

120+ }

121+

122+ fromColumns HEitherTable {htag, hleft, hright} = case htag of

123+ HIdentity (Result tag) -> case tag of

124+ IsLeft -> maybe err (Left . fromColumns) $ hunnullify unnullifier (hunlabel unlabeler hleft)

125+ IsRight -> maybe err (Right . fromColumns) $ hunnullify unnullifier (hunlabel unlabeler hright)

126+ where

127+ err = error "Either.fromColumns: mismatch between tag and data"

128+

129+

130+instance Table Identity a => Table Identity [a] where

131+ type Columns [a] = HListTable (Columns a)

132+ type Context [a] = Identity

133+

134+ toColumns = hvectorize vectorizer . fmap toColumns

135+ fromColumns = fmap fromColumns . hunvectorize unvectorizer

136+

137+

138+instance Table Identity a => Table Identity (Maybe a) where

139+ type Columns (Maybe a) = HMaybeTable (Columns a)

140+ type Context (Maybe a) = Identity

141+

142+ toColumns = \case

143+ Nothing -> HMaybeTable

144+ { htag = HIdentity (Result Nothing)

145+ , hjust = hlabel labeler (hnulls null)

146+ }

147+ Just table -> HMaybeTable

148+ { htag = HIdentity (Result (Just IsJust))

149+ , hjust = hlabel labeler (hnullify nullifier (toColumns table))

150+ }

151+

152+ fromColumns HMaybeTable {htag, hjust} = case htag of

153+ HIdentity (Result tag) -> tag $>

154+ case hunnullify unnullifier (hunlabel unlabeler hjust) of

155+ Nothing -> error "Maybe.fromColumns: mismatch between tag and data"

156+ Just just -> fromColumns just

157+

158+

159+instance Table Identity a => Table Identity (NonEmpty a) where

160+ type Columns (NonEmpty a) = HNonEmptyTable (Columns a)

161+ type Context (NonEmpty a) = Identity

162+

163+ toColumns = hvectorize vectorizer . fmap toColumns

164+ fromColumns = fmap fromColumns . hunvectorize unvectorizer

165+

166+

167+instance (Table Identity a, Table Identity b) => Table Identity (These a b)

168+ where

169+ type Columns (These a b) = HTheseTable (Columns a) (Columns b)

170+ type Context (These a b) = Identity

171+

172+ toColumns tables = HTheseTable

173+ { hhereTag = relabel hhereTag

174+ , hhere = hlabel labeler (hunlabel unlabeler (toColumns hhere))

175+ , hthereTag = relabel hthereTag

176+ , hthere = hlabel labeler (hunlabel unlabeler (toColumns hthere))

177+ }

178+ where

179+ HMaybeTable

180+ { htag = hhereTag

181+ , hjust = hhere

182+ } = toColumns (justHere tables)

183+ HMaybeTable

184+ { htag = hthereTag

185+ , hjust = hthere

186+ } = toColumns (justThere tables)

187+

188+ fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} =

189+ case (fromColumns mhere, fromColumns mthere) of

190+ (Just a, Nothing) -> This (fromColumns a)

191+ (Nothing, Just b) -> That (fromColumns b)

192+ (Just a, Just b) -> These (fromColumns a) (fromColumns b)

193+ _ -> error "These.fromColumns: mismatch between tags and data"

194+ where

195+ mhere = HMaybeTable

196+ { htag = relabel hhereTag

197+ , hjust = hlabel labeler (hunlabel unlabeler hhere)

198+ }

199+ mthere = HMaybeTable

200+ { htag = relabel hthereTag

201+ , hjust = hlabel labeler (hunlabel unlabeler hthere)

202+ }

203+

204+

88instance

205instance

89 ( Table context a, Table context b

206 ( Table context a, Table context b

90 , Labelable context

207 , Labelable context

@@ -192,3 +309,46 @@ instance

192type Congruent :: Type -> Type -> Constraint

309type Congruent :: Type -> Type -> Constraint

193class Columns a ~ Columns b => Congruent a b

310class Columns a ~ Columns b => Congruent a b

194instance Columns a ~ Columns b => Congruent a b

311instance Columns a ~ Columns b => Congruent a b

312+

313+

314+null :: Col Identity ('Spec labels necessity (Maybe a))

315+null = Result Nothing

316+

317+

318+nullifier :: ()

319+ => SSpec ('Spec labels necessity a)

320+ -> Col Identity ('Spec labels necessity a)

321+ -> Col Identity ('Spec labels necessity (Nullify a))

322+nullifier SSpec {nullity} (Result a) = Result $ case nullity of

323+ Null -> a

324+ NotNull -> Just a

325+

326+

327+unnullifier :: ()

328+ => SSpec ('Spec labels necessity a)

329+ -> Col Identity ('Spec labels necessity (Nullify a))

330+ -> Maybe (Col Identity ('Spec labels necessity a))

331+unnullifier SSpec {nullity} (Result a) =

332+ case nullity of

333+ Null -> pure $ Result a

334+ NotNull -> Result <$> a

335+

336+

337+vectorizer :: Functor f

338+ => SSpec ('Spec labels necessity a)

339+ -> f (Col Identity ('Spec labels necessity a))

340+ -> Col Identity ('Spec labels necessity (f a))

341+vectorizer _ = Result . fmap (\(Result a) -> a)

342+

343+

344+unvectorizer :: Functor f

345+ => SSpec ('Spec labels necessity a)

346+ -> Col Identity ('Spec labels necessity (f a))

347+ -> f (Col Identity ('Spec labels necessity a))

348+unvectorizer _ (Result results) = Result <$> results

349+

350+

351+relabel :: ()

352+ => HIdentity ('Spec labels necessity a) (Col Identity)

353+ -> HIdentity ('Spec relabels necessity a) (Col Identity)

354+relabel (HIdentity (Result a)) = HIdentity (Result a)

src/Rel8/Table/Either.hs+59−49

@@ -30,23 +30,25 @@ import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )

30import Rel8.Expr ( Expr )

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

32import Rel8.Expr.Serialize ( litExpr )

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

33+import Rel8.Schema.Context.Label

34+ ( Labelable

35+ , HLabelable, hlabeler, hunlabeler

36+ )

34import Rel8.Schema.Context.Nullify

37import Rel8.Schema.Context.Nullify

35 ( Nullifiable, ConstrainTag

38 ( Nullifiable, ConstrainTag

39+ , HNullifiable, HConstrainTag

36 , hencodeTag, hdecodeTag

40 , hencodeTag, hdecodeTag

37 , hnullifier, hunnullifier

41 , hnullifier, hunnullifier

38 )

42 )

39−import Rel8.Schema.HTable.Either ( HEitherTable(..), HEitherNullifiable )

43+import Rel8.Schema.HTable ( HTable )

44+import Rel8.Schema.HTable.Either ( HEitherTable(..) )

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

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

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

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

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

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

43import Rel8.Schema.Name ( Name )

48import Rel8.Schema.Name ( Name )

44import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )

49import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )

45import Rel8.Table.Bool ( bool )

50import Rel8.Table.Bool ( bool )

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

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

47−import Rel8.Table.Lifted

48− ( Table2, Columns2, ConstrainHContext2, fromColumns2, toColumns2

49− )

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

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

51import Rel8.Table.Recontextualize ( Recontextualize )

53import Rel8.Table.Recontextualize ( Recontextualize )

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

54import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )

@@ -95,51 +97,17 @@ instance (Table Expr a, Table Expr b) => Semigroup (EitherTable a b) where

95 a <> b = bool a b (isRightTable a)

97 a <> b = bool a b (isRightTable a)

98−instance Table2 EitherTable where

99− type Columns2 EitherTable = HEitherTable

100− type ConstrainHContext2 EitherTable = HEitherNullifiable

101−

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

103− { htag

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

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

106− }

107− where

108− htag = HIdentity (hencodeTag tag)

109−

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

111− EitherTable

112− { tag

113− , left = f $ runIdentity $

114− hunnullify (\a -> pure . hunnullifier a) hleft

115− , right = g $ runIdentity $

116− hunnullify (\a -> pure . hunnullifier a) hright

117− }

118− where

119− tag = hdecodeTag $ unHIdentity htag

120−

121− {-# INLINABLE fromColumns2 #-}

122− {-# INLINABLE toColumns2 #-}

123−

124−

125instance

100instance

126 ( Table context a, Table context b

101 ( Table context a, Table context b

127 , Labelable context, Nullifiable context, ConstrainTag context EitherTag

102 , Labelable context, Nullifiable context, ConstrainTag context EitherTag

128 ) =>

103 ) =>

129 Table context (EitherTable a b)

104 Table context (EitherTable a b)

130 where

105 where

131− type Columns (EitherTable a b) =

106+ type Columns (EitherTable a b) = HEitherTable (Columns a) (Columns b)

132− HEitherTable (HLabel "Left" (Columns a)) (HLabel "Right" (Columns b))

133 type Context (EitherTable a b) = Context a

107 type Context (EitherTable a b) = Context a

134

108

135− toColumns =

136− toColumns2

109+ toColumns = toColumns2 toColumns toColumns

137− (hlabel labeler . toColumns)

138− (hlabel labeler . toColumns)

139− fromColumns =

140− fromColumns2

110+ fromColumns = fromColumns2 fromColumns fromColumns

141− (fromColumns . hunlabel unlabeler)

142− (fromColumns . hunlabel unlabeler)

143

111

144

112

145instance

113instance

@@ -152,15 +120,11 @@ instance

152

120

153

121

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

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

155− eqTable =

156− toColumns2 (hlabel hlabeler) (hlabel hlabeler)

157− (rightTableWith (eqTable @a) (eqTable @b))

123+ eqTable = toColumns2 id id (rightTableWith (eqTable @a) (eqTable @b))

158

124

159

125

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

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

161− ordTable =

162− toColumns2 (hlabel hlabeler) (hlabel hlabeler)

163− (rightTableWith (ordTable @a) (ordTable @b))

127+ ordTable = toColumns2 id id (rightTableWith (ordTable @a) (ordTable @b))

164

128

165

129

166isLeftTable :: EitherTable a b -> Expr Bool

130isLeftTable :: EitherTable a b -> Expr Bool

@@ -203,3 +167,49 @@ aggregateEitherTable f g EitherTable {tag, left, right} =

203

167

204nameEitherTable :: Name EitherTag -> a -> b -> EitherTable a b

168nameEitherTable :: Name EitherTag -> a -> b -> EitherTable a b

205nameEitherTable = EitherTable . fromName

169nameEitherTable = EitherTable . fromName

170+

171+

172+toColumns2 ::

173+ ( HTable t

174+ , HTable u

175+ , HConstrainTag context EitherTag

176+ , HLabelable context

177+ , HNullifiable context

178+ )

179+ => (a -> t context)

180+ -> (b -> u context)

181+ -> EitherTable a b

182+ -> HEitherTable t u context

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

184+ { htag

185+ , hleft = hlabel hlabeler $ hnullify (hnullifier tag isLeft) $ f left

186+ , hright = hlabel hlabeler $ hnullify (hnullifier tag isRight) $ g right

187+ }

188+ where

189+ htag = HIdentity (hencodeTag tag)

190+

191+

192+fromColumns2 ::

193+ ( HTable t

194+ , HTable u

195+ , HConstrainTag context EitherTag

196+ , HLabelable context

197+ , HNullifiable context

198+ )

199+ => (t context -> a)

200+ -> (u context -> b)

201+ -> HEitherTable t u context

202+ -> EitherTable a b

203+fromColumns2 f g HEitherTable {htag, hleft, hright} = EitherTable

204+ { tag

205+ , left = f $ runIdentity $

206+ hunnullify (\a -> pure . hunnullifier a) $

207+ hunlabel hunlabeler

208+ hleft

209+ , right = g $ runIdentity $

210+ hunnullify (\a -> pure . hunnullifier a) $

211+ hunlabel hunlabeler

212+ hright

213+ }

214+ where

215+ tag = hdecodeTag $ unHIdentity htag

src/Rel8/Table/Lifted.hsdeleted−81

@@ -1,81 +0,0 @@

1−{-# language ConstraintKinds #-}

2−{-# language DataKinds #-}

3−{-# language FlexibleContexts #-}

4−{-# language FlexibleInstances #-}

5−{-# language MultiParamTypeClasses #-}

6−{-# language QuantifiedConstraints #-}

7−{-# language StandaloneKindSignatures #-}

8−{-# language TypeFamilies #-}

9−{-# language UndecidableInstances #-}

10−

11−module Rel8.Table.Lifted

12− ( Table1( Columns1, ConstrainHContext1, toColumns1, fromColumns1 )

13− , Table2( Columns2, ConstrainHContext2, toColumns2, fromColumns2 )

14− , ConstrainContext

15− )

16−where

17−

18−-- base

19−import Data.Kind ( Constraint, Type )

20−import Prelude ()

21−

22−-- rel8

23−import Rel8.Schema.Context ( Col )

24−import Rel8.Schema.HTable ( HTable )

25−import Rel8.Schema.HTable.Pair

26−import qualified Rel8.Schema.Kind as K

27−

28−

29−type Table1 :: (Type -> Type) -> Constraint

30−class Table1 f where

31− type Columns1 f :: K.HTable -> K.HTable

32− type ConstrainHContext1 f :: K.HContext -> Constraint

33− type ConstrainHContext1 _ = DefaultConstrainContext

34−

35− toColumns1 :: (ConstrainHContext1 f context, HTable t)

36− => (a -> t context)

37− -> f a

38− -> Columns1 f t context

39−

40− fromColumns1 :: (ConstrainHContext1 f context, HTable t)

41− => (t context -> a)

42− -> Columns1 f t context

43− -> f a

44−

45−

46−type Table2 :: (Type -> Type -> Type) -> Constraint

47−class Table2 p where

48− type Columns2 p :: K.HTable -> K.HTable -> K.HTable

49− type ConstrainHContext2 p :: K.HContext -> Constraint

50− type ConstrainHContext2 _ = DefaultConstrainContext

51−

52− toColumns2 :: (ConstrainHContext2 p context, HTable t, HTable u)

53− => (a -> t context)

54− -> (b -> u context)

55− -> p a b

56− -> Columns2 p t u context

57−

58− fromColumns2 :: (ConstrainHContext2 p context, HTable t, HTable u)

59− => (t context -> a)

60− -> (u context -> b)

61− -> Columns2 p t u context

62− -> p a b

63−

64−

65−instance Table2 (,) where

66− type Columns2 (,) = HPair

67−

68− toColumns2 f g (a, b) = HPair (f a) (g b)

69− fromColumns2 f g (HPair a b) = (f a, g b)

70−

71−

72−type DefaultConstrainContext :: K.HContext -> Constraint

73−class DefaultConstrainContext context

74−instance DefaultConstrainContext context

75−

76−

77−type ConstrainContext :: (K.Context -> Constraint) -> K.HContext -> Constraint

78−class (forall context. hcontext ~ Col context => constraint context)

79− => ConstrainContext constraint hcontext

80−instance (hcontext ~ Col context, constraint context) =>

81− ConstrainContext constraint hcontext

src/Rel8/Table/Maybe.hs+48−35

@@ -24,7 +24,7 @@ where

24-- base

25import Data.Functor.Identity ( runIdentity )

26import Data.Kind ( Type )

27−import Prelude hiding ( null, repeat, undefined, zipWith )

27+import Prelude hiding ( null, undefined )

29-- rel8

30import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )

@@ -32,15 +32,19 @@ import Rel8.Expr ( Expr )

32import Rel8.Expr.Bool ( boolExpr )

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

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

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

35+import Rel8.Schema.Context.Label

36+ ( Labelable, HLabelable, hlabeler, hunlabeler

37+ )

36import Rel8.Schema.Context.Nullify

38import Rel8.Schema.Context.Nullify

37 ( Nullifiable, ConstrainTag

39 ( Nullifiable, ConstrainTag

40+ , HNullifiable, HConstrainTag

38 , hencodeTag, hdecodeTag

41 , hencodeTag, hdecodeTag

39 , hnullifier, hunnullifier

42 , hnullifier, hunnullifier

40 )

43 )

44+import Rel8.Schema.HTable ( HTable )

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

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

42−import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )

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

43−import Rel8.Schema.HTable.Maybe ( HMaybeTable(..), HMaybeNullifiable )

47+import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )

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

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

45import Rel8.Schema.Name ( Name )

49import Rel8.Schema.Name ( Name )

46import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql, nullable )

50import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql, nullable )

@@ -51,9 +55,6 @@ import Rel8.Table.Alternative

51 )

55 )

52import Rel8.Table.Bool ( bool )

56import Rel8.Table.Bool ( bool )

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

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

54−import Rel8.Table.Lifted

55− ( Table1, Columns1, ConstrainHContext1, fromColumns1, toColumns1

56− )

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

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

58import Rel8.Table.Recontextualize ( Recontextualize )

59import Rel8.Table.Recontextualize ( Recontextualize )

59import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )

60import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )

@@ -127,40 +128,17 @@ instance (Table Expr a, Semigroup a) => Monoid (MaybeTable a) where

127 mempty = nothingTable

128 mempty = nothingTable

128

129

130

130−instance Table1 MaybeTable where

131− type Columns1 MaybeTable = HMaybeTable

132− type ConstrainHContext1 MaybeTable = HMaybeNullifiable

133−

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

135− { htag

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

137− }

138− where

139− htag = HIdentity (hencodeTag tag)

140−

141− fromColumns1 f HMaybeTable {htag = HIdentity htag, hjust} = MaybeTable

142− { tag

143− , just = f $ runIdentity $

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

145− }

146− where

147− tag = hdecodeTag htag

148−

149− {-# INLINABLE fromColumns1 #-}

150− {-# INLINABLE toColumns1 #-}

151−

152−

153instance

131instance

154 ( Table context a

132 ( Table context a

155 , Labelable context, Nullifiable context

133 , Labelable context, Nullifiable context

156 , ConstrainTag context MaybeTag

134 , ConstrainTag context MaybeTag

157 ) => Table context (MaybeTable a)

135 ) => Table context (MaybeTable a)

158 where

136 where

159− type Columns (MaybeTable a) = HMaybeTable (HLabel "Just" (Columns a))

137+ type Columns (MaybeTable a) = HMaybeTable (Columns a)

160 type Context (MaybeTable a) = Context a

138 type Context (MaybeTable a) = Context a

161

139

162− toColumns = toColumns1 (hlabel labeler . toColumns)

140+ toColumns = toColumns1 toColumns

163− fromColumns = fromColumns1 (fromColumns . hunlabel unlabeler)

141+ fromColumns = fromColumns1 fromColumns

164

142

165

143

166instance

144instance

@@ -171,11 +149,11 @@ instance

171

149

172

150

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

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

174− eqTable = toColumns1 (hlabel hlabeler) (justTable (eqTable @a))

152+ eqTable = toColumns1 id (justTable (eqTable @a))

175

153

176

154

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

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

178− ordTable = toColumns1 (hlabel hlabeler) (justTable (ordTable @a))

156+ ordTable = toColumns1 id (justTable (ordTable @a))

179

157

180

158

181-- | Check if a @MaybeTable@ is absent of any row. Like 'Data.Maybe.isNothing'.

159-- | Check if a @MaybeTable@ is absent of any row. Like 'Data.Maybe.isNothing'.

@@ -226,3 +204,38 @@ aggregateMaybeTable f MaybeTable {tag = tag@Tag {aggregator, expr}, just} =

226

204

227nameMaybeTable :: Name (Maybe MaybeTag) -> a -> MaybeTable a

205nameMaybeTable :: Name (Maybe MaybeTag) -> a -> MaybeTable a

228nameMaybeTable = MaybeTable . fromName

206nameMaybeTable = MaybeTable . fromName

207+

208+

209+toColumns1 ::

210+ ( HTable t

211+ , HConstrainTag context MaybeTag

212+ , HLabelable context

213+ , HNullifiable context

214+ )

215+ => (a -> t context)

216+ -> MaybeTable a

217+ -> HMaybeTable t context

218+toColumns1 f MaybeTable {tag, just} = HMaybeTable

219+ { htag

220+ , hjust = hlabel hlabeler $ hnullify (hnullifier tag isNonNull) $ f just

221+ }

222+ where

223+ htag = HIdentity (hencodeTag tag)

224+

225+

226+fromColumns1 ::

227+ ( HTable t

228+ , HConstrainTag context MaybeTag

229+ , HLabelable context

230+ , HNullifiable context

231+ )

232+ => (t context -> a)

233+ -> HMaybeTable t context

234+ -> MaybeTable a

235+fromColumns1 f HMaybeTable {htag = HIdentity htag, hjust} = MaybeTable

236+ { tag

237+ , just = f $ runIdentity $

238+ hunnullify (\a -> pure . hunnullifier a) (hunlabel hunlabeler hjust)

239+ }

240+ where

241+ tag = hdecodeTag htag

src/Rel8/Table/Serialize.hs+30−49

@@ -31,13 +31,6 @@ import qualified Hasql.Decoders as Hasql

31import Rel8.Expr ( Expr, Col(..) )

32import Rel8.Expr.Serialize ( slitExpr, sparseValue )

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

34−import Rel8.Schema.Context.Identity

35− ( fromHEitherTable, toHEitherTable

36− , fromHListTable, toHListTable

37− , fromHMaybeTable, toHMaybeTable

38− , fromHNonEmptyTable, toHNonEmptyTable

39− , fromHTheseTable, toHTheseTable

40− )

41import Rel8.Schema.Context.Label ( labeler, unlabeler )

34import Rel8.Schema.Context.Label ( labeler, unlabeler )

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

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

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

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

@@ -104,50 +97,38 @@ instance (ToExprs a exprs1, ToExprs b exprs2, x ~ EitherTable exprs1 exprs2) =>

104 ToExprs (Either a b) x

97 ToExprs (Either a b) x

105 where

98 where

106 fromIdentity =

99 fromIdentity =

107− bimap

108− (fromIdentity' @exprs1 . hunlabel unlabeler)

100+ bimap (fromIdentity' @exprs1) (fromIdentity' @exprs2) .

109− (fromIdentity' @exprs2 . hunlabel unlabeler) .

101+ fromColumns

110− fromHEitherTable

111 toIdentity =

102 toIdentity =

112− toHEitherTable .

103+ toColumns .

113− bimap

114− (hlabel labeler . toIdentity' @exprs1)

104+ bimap (toIdentity' @exprs1) (toIdentity' @exprs2)

115− (hlabel labeler . toIdentity' @exprs2)

116

105

117

106

118instance ToExprs a exprs => ToExprs [a] (ListTable exprs) where

107instance ToExprs a exprs => ToExprs [a] (ListTable exprs) where

119− fromIdentity = fmap (fromIdentity' @exprs) . fromHListTable

108+ fromIdentity = fmap (fromIdentity' @exprs) . fromColumns

120− toIdentity = toHListTable . fmap (toIdentity' @exprs)

109+ toIdentity = toColumns . fmap (toIdentity' @exprs)

121

110

122

111

123instance ToExprs a exprs => ToExprs (Maybe a) (MaybeTable exprs) where

112instance ToExprs a exprs => ToExprs (Maybe a) (MaybeTable exprs) where

124− fromIdentity =

125− fmap (fromIdentity' @exprs . hunlabel unlabeler) .

113+ fromIdentity = fmap (fromIdentity' @exprs) . fromColumns

126− fromHMaybeTable

127− toIdentity =

128− toHMaybeTable .

129− fmap (hlabel labeler . toIdentity' @exprs)

114+ toIdentity = toColumns . fmap (toIdentity' @exprs)

130

115

131

116

132instance ToExprs a exprs => ToExprs (NonEmpty a) (NonEmptyTable exprs)

117instance ToExprs a exprs => ToExprs (NonEmpty a) (NonEmptyTable exprs)

133 where

118 where

134− fromIdentity = fmap (fromIdentity' @exprs) . fromHNonEmptyTable

119+ fromIdentity = fmap (fromIdentity' @exprs) . fromColumns

135− toIdentity = toHNonEmptyTable . fmap (toIdentity' @exprs)

120+ toIdentity = toColumns . fmap (toIdentity' @exprs)

136

121

137

122

138instance (ToExprs a exprs1, ToExprs b exprs2, x ~ TheseTable exprs1 exprs2) =>

123instance (ToExprs a exprs1, ToExprs b exprs2, x ~ TheseTable exprs1 exprs2) =>

139 ToExprs (These a b) x

124 ToExprs (These a b) x

140 where

125 where

141 fromIdentity =

126 fromIdentity =

142− bimap

143− (fromIdentity' @exprs1 . hunlabel unlabeler)

127+ bimap (fromIdentity' @exprs1) (fromIdentity' @exprs2) .

144− (fromIdentity' @exprs2 . hunlabel unlabeler) .

128+ fromColumns

145− fromHTheseTable

146 toIdentity =

129 toIdentity =

147− toHTheseTable .

130+ toColumns .

148− bimap

149− (hlabel labeler . toIdentity' @exprs1)

131+ bimap (toIdentity' @exprs1) (toIdentity' @exprs2)

150− (hlabel labeler . toIdentity' @exprs2)

151

132

152

133

153instance (ToExprs a exprs1, ToExprs b exprs2, x ~ (exprs1, exprs2)) =>

134instance (ToExprs a exprs1, ToExprs b exprs2, x ~ (exprs1, exprs2)) =>

@@ -251,22 +232,22 @@ instance (KnownSpec spec, x ~ Col Expr spec) =>

251

232

252

233

253type FromExprs :: Type -> Type

234type FromExprs :: Type -> Type

254−type family FromExprs a where

235+type family FromExprs a

255− FromExprs (Expr a) = a

236+type instance FromExprs (Expr a) = a

256− FromExprs (Col Expr spec) = Col Identity spec

237+type instance FromExprs (Col Expr spec) = Col Identity spec

257− FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)

238+type instance FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)

258− FromExprs (ListTable a) = [FromExprs a]

239+type instance FromExprs (ListTable a) = [FromExprs a]

259− FromExprs (MaybeTable a) = Maybe (FromExprs a)

240+type instance FromExprs (MaybeTable a) = Maybe (FromExprs a)

260− FromExprs (NonEmptyTable a) = NonEmpty (FromExprs a)

241+type instance FromExprs (NonEmptyTable a) = NonEmpty (FromExprs a)

261− FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)

242+type instance FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)

262− FromExprs (a, b) = (FromExprs a, FromExprs b)

243+type instance FromExprs (a, b) = (FromExprs a, FromExprs b)

263− FromExprs (a, b, c) = (FromExprs a, FromExprs b, FromExprs c)

244+type instance FromExprs (a, b, c) = (FromExprs a, FromExprs b, FromExprs c)

264− FromExprs (a, b, c, d) =

245+type instance FromExprs (a, b, c, d) =

265− (FromExprs a, FromExprs b, FromExprs c, FromExprs d)

246+ (FromExprs a, FromExprs b, FromExprs c, FromExprs d)

266− FromExprs (a, b, c, d, e) =

247+type instance FromExprs (a, b, c, d, e) =

267− (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e)

248+ (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e)

268− FromExprs (t Expr) = t Identity

249+type instance FromExprs (t Expr) = t Identity

269− FromExprs (t (Col Expr)) = t (Col Identity)

250+type instance FromExprs (t (Col Expr)) = t (Col Identity)

270

251

271

252

272-- | @Serializable@ witnesses the one-to-one correspondence between the type

253-- | @Serializable@ witnesses the one-to-one correspondence between the type

src/Rel8/Table/These.hs+72−65

@@ -34,23 +34,24 @@ import Rel8.Aggregate ( Aggregate )

34import Rel8.Expr ( Expr )

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

36import Rel8.Expr.Null ( isNonNull )

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

37+import Rel8.Schema.Context.Label

38+ ( Labelable

39+ , HLabelable, hlabeler, hunlabeler

40+ )

38import Rel8.Schema.Context.Nullify

41import Rel8.Schema.Context.Nullify

39 ( Nullifiable, ConstrainTag

42 ( Nullifiable, ConstrainTag

43+ , HNullifiable, HConstrainTag

40 , hencodeTag, hdecodeTag

44 , hencodeTag, hdecodeTag

41 , hnullifier, hunnullifier

45 , hnullifier, hunnullifier

42 )

46 )

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

47+import Rel8.Schema.HTable ( HTable )

48+import Rel8.Schema.HTable.Label ( hlabel, hunlabel )

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

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

45−import Rel8.Schema.HTable.Maybe ( HMaybeNullifiable )

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

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

47import Rel8.Schema.HTable.These ( HTheseTable(..) )

51import Rel8.Schema.HTable.These ( HTheseTable(..) )

48import Rel8.Schema.Name ( Name )

52import Rel8.Schema.Name ( Name )

49import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )

53import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )

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

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

51−import Rel8.Table.Lifted

52− ( Table2, Columns2, ConstrainHContext2, fromColumns2, toColumns2

53− )

54import Rel8.Table.Maybe

55import Rel8.Table.Maybe

55 ( MaybeTable(..)

56 ( MaybeTable(..)

56 , maybeTable, justTable, nothingTable

57 , maybeTable, justTable, nothingTable

@@ -117,66 +118,16 @@ instance (Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>

117 }

118 }

118

119

120

120−instance Table2 TheseTable where

121− type Columns2 TheseTable = HTheseTable

122− type ConstrainHContext2 TheseTable = HMaybeNullifiable

123−

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

125− { hhereTag = HIdentity $ hencodeTag (toHereTag (tag here))

126− , hhere =

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

128− , hthereTag = HIdentity $ hencodeTag (toThereTag (tag there))

129− , hthere =

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

131− }

132−

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

134− TheseTable

135− { here =

136− let

137− tag = hdecodeTag $ unHIdentity hhereTag

138− in

139− MaybeTable

140− { tag

141− , just = f $

142− runIdentity $

143− hunnullify (\a -> pure . hunnullifier a)

144− hhere

145− }

146− , there =

147− let

148− tag = hdecodeTag $ unHIdentity hthereTag

149− in

150− MaybeTable

151− { tag

152− , just = g $

153− runIdentity $

154− hunnullify (\a -> pure . hunnullifier a)

155− hthere

156− }

157− }

158−

159− {-# INLINABLE fromColumns2 #-}

160− {-# INLINABLE toColumns2 #-}

161−

162−

163instance

121instance

164 ( Table context a, Table context b

122 ( Table context a, Table context b

165 , Labelable context, Nullifiable context, ConstrainTag context MaybeTag

123 , Labelable context, Nullifiable context, ConstrainTag context MaybeTag

166 ) => Table context (TheseTable a b)

124 ) => Table context (TheseTable a b)

167 where

125 where

168− type Columns (TheseTable a b) =

126+ type Columns (TheseTable a b) = HTheseTable (Columns a) (Columns b)

169− HTheseTable (HLabel "Here" (Columns a)) (HLabel "There" (Columns b))

170 type Context (TheseTable a b) = Context a

127 type Context (TheseTable a b) = Context a

171

128

172− toColumns =

173− toColumns2

129+ toColumns = toColumns2 toColumns toColumns

174− (hlabel labeler . toColumns)

175− (hlabel labeler . toColumns)

176− fromColumns =

177− fromColumns2

130+ fromColumns = fromColumns2 fromColumns fromColumns

178− (fromColumns . hunlabel unlabeler)

179− (fromColumns . hunlabel unlabeler)

180

131

181

132

182instance

133instance

@@ -189,15 +140,11 @@ instance

189

140

190

141

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

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

192− eqTable =

193− toColumns2 (hlabel hlabeler) (hlabel hlabeler)

194− (thoseTable (eqTable @a) (eqTable @b))

143+ eqTable = toColumns2 id id (thoseTable (eqTable @a) (eqTable @b))

195

144

196

145

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

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

198− ordTable =

199− toColumns2 (hlabel hlabeler) (hlabel hlabeler)

200− (thoseTable (ordTable @a) (ordTable @b))

147+ ordTable = toColumns2 id id (thoseTable (ordTable @a) (ordTable @b))

201

148

202

149

203toHereTag :: Tag "isJust" a -> Tag "hasHere" a

150toHereTag :: Tag "isJust" a -> Tag "hasHere" a

@@ -277,3 +224,63 @@ nameTheseTable here there a b =

277 { here = nameMaybeTable here a

224 { here = nameMaybeTable here a

278 , there = nameMaybeTable there b

225 , there = nameMaybeTable there b

279 }

226 }

227+

228+

229+toColumns2 ::

230+ ( HTable t

231+ , HTable u

232+ , HConstrainTag context MaybeTag

233+ , HLabelable context

234+ , HNullifiable context

235+ )

236+ => (a -> t context)

237+ -> (b -> u context)

238+ -> TheseTable a b

239+ -> HTheseTable t u context

240+toColumns2 f g TheseTable {here, there} = HTheseTable

241+ { hhereTag = HIdentity $ hencodeTag (toHereTag (tag here))

242+ , hhere =

243+ hlabel hlabeler $ hnullify (hnullifier (tag here) isNonNull) $ f (just here)

244+ , hthereTag = HIdentity $ hencodeTag (toThereTag (tag there))

245+ , hthere =

246+ hlabel hlabeler $ hnullify (hnullifier (tag there) isNonNull) $ g (just there)

247+ }

248+

249+

250+fromColumns2 ::

251+ ( HTable t

252+ , HTable u

253+ , HConstrainTag context MaybeTag

254+ , HLabelable context

255+ , HNullifiable context

256+ )

257+ => (t context -> a)

258+ -> (u context -> b)

259+ -> HTheseTable t u context

260+ -> TheseTable a b

261+fromColumns2 f g HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable

262+ { here =

263+ let

264+ tag = hdecodeTag $ unHIdentity hhereTag

265+ in

266+ MaybeTable

267+ { tag

268+ , just = f $

269+ runIdentity $

270+ hunnullify (\a -> pure . hunnullifier a) $

271+ hunlabel hunlabeler

272+ hhere

273+ }

274+ , there =

275+ let

276+ tag = hdecodeTag $ unHIdentity hthereTag

277+ in

278+ MaybeTable

279+ { tag

280+ , just = g $

281+ runIdentity $

282+ hunnullify (\a -> pure . hunnullifier a) $

283+ hunlabel hunlabeler

284+ hthere

285+ }

286+ }

src/Rel8/Type/Array.hs+1

@@ -32,6 +32,7 @@ array TypeInformation {typeName} =

32 fromPrimArray .

33 Opaleye.CastExpr (typeName <> "[]") .

34 Opaleye.ArrayExpr . toList

35+{-# INLINABLE array #-}

37listTypeInformation :: ()

38listTypeInformation :: ()

src/Rel8/Type/Tag.hs+1−1

@@ -19,7 +19,7 @@ import Prelude

19import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

21-- rel8

22−import Rel8.Expr ( Expr )

22+import {-# SOURCE #-} Rel8.Expr ( Expr )

23import Rel8.Expr.Eq ( (==.) )

24import Rel8.Expr.Opaleye ( zipPrimExprsWith )

25import Rel8.Expr.Serialize ( litExpr )