9b5abf2 · rel8 · git.iko.soy

git.iko.soy/rel8

on master help sign in

Use data family for HTable contexts

9b5abf2Shane O'Brien6 years ago

rel8.cabal+2−3

compare with master

unifiedsplit

@@ -87,15 +87,14 @@ library

88 Rel8.Schema.Column

89 Rel8.Schema.Context

90+ Rel8.Schema.Context.Identity

90 Rel8.Schema.Context.Label

91 Rel8.Schema.Context.Label

91 Rel8.Schema.Context.Nullify

92 Rel8.Schema.Context.Nullify

92− Rel8.Schema.Context.Result

93 Rel8.Schema.Dict

94 Rel8.Schema.Field

95 Rel8.Schema.Generic

96 Rel8.Schema.Generic.Test

97 Rel8.Schema.HTable

98− Rel8.Schema.HTable.Context

99 Rel8.Schema.HTable.Either

98 Rel8.Schema.HTable.Either

100 Rel8.Schema.HTable.Identity

99 Rel8.Schema.HTable.Identity

101 Rel8.Schema.HTable.Label

100 Rel8.Schema.HTable.Label

@@ -110,9 +109,9 @@ library

110 Rel8.Schema.HTable.Trio

109 Rel8.Schema.HTable.Trio

111 Rel8.Schema.HTable.Type

110 Rel8.Schema.HTable.Type

112 Rel8.Schema.HTable.Vectorize

111 Rel8.Schema.HTable.Vectorize

112+ Rel8.Schema.Kind

113 Rel8.Schema.Nullability

114 Rel8.Schema.Spec

115− Rel8.Schema.Spec.ConstrainContext

116 Rel8.Schema.Spec.ConstrainDBType

115 Rel8.Schema.Spec.ConstrainDBType

117 Rel8.Schema.Spec.ConstrainType

116 Rel8.Schema.Spec.ConstrainType

118 Rel8.Schema.Table

117 Rel8.Schema.Table

src/Rel8/Query/Either.hs+3−3

@@ -12,12 +12,12 @@ where

12import Prelude

14-- rel8

15+import Rel8.Expr ( Expr )

15import Rel8.Expr.Eq ( (==.) )

16import Rel8.Expr.Eq ( (==.) )

16import Rel8.Query ( Query )

17import Rel8.Query ( Query )

17import Rel8.Query.Filter ( where_ )

18import Rel8.Query.Filter ( where_ )

18import Rel8.Query.Maybe ( optional )

19import Rel8.Query.Maybe ( optional )

19import Rel8.Query.Set ( unionAll )

20import Rel8.Query.Set ( unionAll )

20−import Rel8.Schema.Context ( DB )

21import Rel8.Table ( Table )

22import Rel8.Table.Bool ( bool )

23import Rel8.Table.Either

@@ -40,14 +40,14 @@ keepRightTable e@(EitherTable _ _ b) = do

40 pure b

43−bindEitherTable :: (Table DB a, Monad m)

43+bindEitherTable :: (Table Expr a, Monad m)

44 => (i -> m (EitherTable a b)) -> EitherTable a i -> m (EitherTable a b)

45bindEitherTable query e@(EitherTable input a i) = do

46 EitherTable output a' b <- query i

47 pure $ EitherTable (input <> output) (bool a a' (isRightTable e)) b

50−bitraverseEitherTable :: (Table DB c, Table DB d)

50+bitraverseEitherTable :: (Table Expr c, Table Expr d)

51 => (a -> Query c)

52 -> (b -> Query d)

53 -> EitherTable a b

src/Rel8/Query/List.hs+3−3

@@ -9,10 +9,10 @@ where

9import Prelude

11-- rel8

12+import Rel8.Expr ( Expr )

12import Rel8.Query ( Query )

13import Rel8.Query ( Query )

13import Rel8.Query.Aggregate ( aggregate )

14import Rel8.Query.Aggregate ( aggregate )

14import Rel8.Query.Maybe ( optional )

15import Rel8.Query.Maybe ( optional )

15−import Rel8.Schema.Context ( DB )

16import Rel8.Table ( Table )

17import Rel8.Table.Aggregate ( listAgg, nonEmptyAgg )

18import Rel8.Table.List ( ListTable )

@@ -28,7 +28,7 @@ import Rel8.Table.NonEmpty ( NonEmptyTable )

28--

29-- @some@ is analogous to 'Control.Applicative.some' from

30-- @Control.Applicative@.

31−some :: Table DB a => Query a -> Query (NonEmptyTable a)

31+some :: Table Expr a => Query a -> Query (NonEmptyTable a)

32some = aggregate . fmap nonEmptyAgg

@@ -39,5 +39,5 @@ some = aggregate . fmap nonEmptyAgg

39--

40-- @many@ is analogous to 'Control.Applicative.many' from

41-- @Control.Applicative@.

42−many :: Table DB a => Query a -> Query (ListTable a)

42+many :: Table Expr a => Query a -> Query (ListTable a)

43many = fmap (maybeTable mempty id) . optional . aggregate . fmap listAgg

src/Rel8/Query/SQL.hs+5−4

@@ -23,11 +23,12 @@ import qualified Opaleye.Internal.QueryArr as Opaleye hiding ( Select )

23import qualified Opaleye.Internal.Sql as Opaleye

25-- rel8

26+import Rel8.Expr ( Expr )

26import Rel8.Expr.Opaleye ( toPrimExpr )

27import Rel8.Expr.Opaleye ( toPrimExpr )

27import Rel8.Query ( Query )

28import Rel8.Query ( Query )

28import Rel8.Query.Opaleye ( toOpaleye )

29import Rel8.Query.Opaleye ( toOpaleye )

29import qualified Rel8.Query.Optimize as Rel8 ( optimize )

30import qualified Rel8.Query.Optimize as Rel8 ( optimize )

30−import Rel8.Schema.Context ( DB( DB ), Name( Name ) )

31+import Rel8.Schema.Context ( Col'(..), Name( Name ) )

31import Rel8.Schema.HTable ( htabulateA, hfield )

32import Rel8.Schema.HTable ( htabulateA, hfield )

32import Rel8.Table ( Table, toColumns )

33import Rel8.Table ( Table, toColumns )

33import Rel8.Table.Name ( namesFromLabels )

34import Rel8.Table.Name ( namesFromLabels )

@@ -36,11 +37,11 @@ import Rel8.Table.Recontextualize ( Selects )

37-- | Convert a query to a 'String' containing the query as a @SELECT@

38-- | Convert a query to a 'String' containing the query as a @SELECT@

38-- statement.

39-- statement.

39−showQuery :: Table DB a => Query a -> String

40+showQuery :: Table Expr a => Query a -> String

40showQuery = fold . sqlForQuery

41showQuery = fold . sqlForQuery

43−sqlForQuery :: Table DB a

44+sqlForQuery :: Table Expr a

44 => Query a -> Maybe String

45 => Query a -> Maybe String

45sqlForQuery = sqlForQueryWithNames namesFromLabels . fmap toColumns

46sqlForQuery = sqlForQueryWithNames namesFromLabels . fmap toColumns

@@ -68,7 +69,7 @@ selectFrom (toColumns -> names) (toColumns -> exprs) query =

68 where

69 where

69 select = Opaleye.foldPrimQuery Opaleye.sqlQueryGenerator query

70 select = Opaleye.foldPrimQuery Opaleye.sqlQueryGenerator query

70 attributes = getConst $ htabulateA $ \field -> case hfield names field of

71 attributes = getConst $ htabulateA $ \field -> case hfield names field of

71− Name name -> case hfield exprs field of

72+ Col (Name name) -> case hfield exprs field of

72 DB (toPrimExpr -> expr) -> Const (pure (makeAttr name expr))

73 DB (toPrimExpr -> expr) -> Const (pure (makeAttr name expr))

73 makeAttr label expr =

74 makeAttr label expr =

74 (Opaleye.sqlExpr expr, Just (Opaleye.SqlColumn label))

75 (Opaleye.sqlExpr expr, Just (Opaleye.SqlColumn label))

src/Rel8/Query/Set.hs+4−4

@@ -14,12 +14,12 @@ import Prelude ()

14import qualified Opaleye.Binary as Opaleye

16-- rel8

17+import Rel8.Expr ( Expr )

17import {-# SOURCE #-} Rel8.Query ( Query )

18import {-# SOURCE #-} Rel8.Query ( Query )

18import Rel8.Query.Opaleye ( zipOpaleyeWith )

19import Rel8.Query.Opaleye ( zipOpaleyeWith )

19import Rel8.Table ( Table )

20import Rel8.Table ( Table )

20import Rel8.Table.Eq ( EqTable )

21import Rel8.Table.Eq ( EqTable )

21import Rel8.Table.Opaleye ( binaryspec )

22import Rel8.Table.Opaleye ( binaryspec )

22−import Rel8.Schema.Context ( DB )

25-- | Combine the results of two queries of the same type, collapsing

@@ -36,7 +36,7 @@ union = zipOpaleyeWith (Opaleye.unionExplicit binaryspec)

36--

37-- >>> select c $ values [lit True, lit True, lit False] `unionAll` values [lit True]

38-- [True,True,False,True]

39−unionAll :: Table DB a => Query a -> Query a -> Query a

39+unionAll :: Table Expr a => Query a -> Query a -> Query a

40unionAll = zipOpaleyeWith (Opaleye.unionAllExplicit binaryspec)

@@ -54,7 +54,7 @@ intersect = zipOpaleyeWith (Opaleye.intersectExplicit binaryspec)

54--

55-- >>> select c $ values [lit True, lit True, lit False] `intersectAll` values [lit True, lit True]

56-- [True,True]

57−intersectAll :: Table DB a => Query a -> Query a -> Query a

57+intersectAll :: Table Expr a => Query a -> Query a -> Query a

58intersectAll = zipOpaleyeWith (Opaleye.intersectAllExplicit binaryspec)

@@ -72,5 +72,5 @@ except = zipOpaleyeWith (Opaleye.exceptExplicit binaryspec)

72--

73-- >>> select c $ values [lit True, lit False, lit False] `exceptAll` values [lit True]

74-- [False,False]

75−exceptAll :: Table DB a => Query a -> Query a -> Query a

75+exceptAll :: Table Expr a => Query a -> Query a -> Query a

76exceptAll = zipOpaleyeWith (Opaleye.exceptAllExplicit binaryspec)

src/Rel8/Query/These.hs+3−4

@@ -29,7 +29,6 @@ import Rel8.Query ( Query )

29import Rel8.Query.Filter ( where_ )

30import Rel8.Query.Maybe ( traverseMaybeTable )

31import Rel8.Query.Opaleye ( zipOpaleyeWith )

32−import Rel8.Schema.Context ( DB )

33import Rel8.Table ( Table )

32import Rel8.Table ( Table )

34import Rel8.Table.Either ( EitherTable( EitherTable ) )

33import Rel8.Table.Either ( EitherTable( EitherTable ) )

35import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )

34import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )

@@ -41,7 +40,7 @@ import Rel8.Table.These

41import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ) )

40import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ) )

44−alignBy :: (Table DB a, Table DB b)

43+alignBy :: (Table Expr a, Table Expr b)

45 => (a -> b -> Expr Bool)

44 => (a -> b -> Expr Bool)

46 -> Query a -> Query b -> Query (TheseTable a b)

45 -> Query a -> Query b -> Query (TheseTable a b)

47alignBy condition as bs =

46alignBy condition as bs =

@@ -108,14 +107,14 @@ loseThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do

108 tag = boolExpr (litExpr IsLeft) (litExpr IsRight) (isThatTable t)

107 tag = boolExpr (litExpr IsLeft) (litExpr IsRight) (isThatTable t)

109

108

110

109

111−bindTheseTable :: (Table DB a, Semigroup a, Monad m)

110+bindTheseTable :: (Table Expr a, Semigroup a, Monad m)

112 => (i -> m (TheseTable a b)) -> TheseTable a i -> m (TheseTable a b)

111 => (i -> m (TheseTable a b)) -> TheseTable a i -> m (TheseTable a b)

113bindTheseTable query (TheseTable here (MaybeTable input i)) = do

112bindTheseTable query (TheseTable here (MaybeTable input i)) = do

114 TheseTable here' (MaybeTable output b) <- query i

113 TheseTable here' (MaybeTable output b) <- query i

115 pure $ TheseTable (here <> here') (MaybeTable (input <> output) b)

114 pure $ TheseTable (here <> here') (MaybeTable (input <> output) b)

116

115

117

116

118−bitraverseTheseTable :: (Table DB c, Table DB d)

117+bitraverseTheseTable :: (Table Expr c, Table Expr d)

119 => (a -> Query c)

118 => (a -> Query c)

120 -> (b -> Query d)

119 -> (b -> Query d)

121 -> TheseTable a b

120 -> TheseTable a b

src/Rel8/Query/Values.hs+2−2

@@ -13,11 +13,11 @@ import Prelude

13import qualified Opaleye.Values as Opaleye

15-- rel8

16+import Rel8.Expr ( Expr )

16import {-# SOURCE #-} Rel8.Query ( Query )

17import {-# SOURCE #-} Rel8.Query ( Query )

17import Rel8.Query.Opaleye ( fromOpaleye )

18import Rel8.Query.Opaleye ( fromOpaleye )

18import Rel8.Table ( Table )

19import Rel8.Table ( Table )

19import Rel8.Table.Opaleye ( valuesspec )

20import Rel8.Table.Opaleye ( valuesspec )

20−import Rel8.Schema.Context ( DB )

23-- | Construct a query that returns the given input list of rows. This is like

@@ -29,5 +29,5 @@ import Rel8.Schema.Context ( DB )

29-- >>> mapM_ Data.Text.IO.putStrLn =<< select c (values [ lit "Hello", lit "World!" ])

30-- Hello

31-- World!

32−values :: (Table DB a, Foldable f) => f a -> Query a

32+values :: (Table Expr a, Foldable f) => f a -> Query a

33values = fromOpaleye . Opaleye.valuesExplicit valuesspec . toList

src/Rel8/Schema/Column.hs+19−18

@@ -13,6 +13,7 @@ module Rel8.Schema.Column

13where

15-- base

16+import Data.Functor.Identity ( Identity )

16import Data.Kind ( Type )

17import Data.Kind ( Type )

17import Data.List.NonEmpty ( NonEmpty )

18import Data.List.NonEmpty ( NonEmpty )

18import GHC.TypeLits ( Symbol )

19import GHC.TypeLits ( Symbol )

@@ -21,10 +22,10 @@ import Prelude

21-- rel8

22-- rel8

22import Rel8.Kind.Labels ( Labels )

23import Rel8.Kind.Labels ( Labels )

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

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

24−import Rel8.Schema.Context ( Result, IsSpecialContext )

25+import Rel8.Schema.Context ( IsSpecialContext )

25import Rel8.Schema.Field ( Field )

26import Rel8.Schema.Field ( Field )

27+import qualified Rel8.Schema.Kind as K

26import Rel8.Schema.Nullability ( Unnullify )

28import Rel8.Schema.Nullability ( Unnullify )

27−import Rel8.Schema.Spec ( Context )

28import Rel8.Schema.Structure

29import Rel8.Schema.Structure

29 ( Structure

30 ( Structure

30 , Shape( Either, List, Maybe, NonEmpty, These )

31 , Shape( Either, List, Maybe, NonEmpty, These )

@@ -73,7 +74,7 @@ type family UnwrapDefault a where

73 UnwrapDefault a = a

74 UnwrapDefault a = a

76−type Column :: Context -> Type -> Type

77+type Column :: K.Context -> Type -> Type

77type Column context a =

78type Column context a =

78 Field context (GetLabel a)

79 Field context (GetLabel a)

79 (GetNecessity (UnwrapLabel a))

80 (GetNecessity (UnwrapLabel a))

@@ -81,61 +82,61 @@ type Column context a =

81 (UnwrapDefault (UnwrapLabel a))

82 (UnwrapDefault (UnwrapLabel a))

84−type IHEither :: Bool -> Context -> Type -> Type -> Type

85+type IHEither :: Bool -> K.Context -> Type -> Type -> Type

85type family IHEither isSpecialContext context where

86type family IHEither isSpecialContext context where

86 IHEither 'False _ = EitherTable

87 IHEither 'False _ = EitherTable

87− IHEither 'True Result = Either

88+ IHEither 'True Identity = Either

88 IHEither 'True Structure = Shape2 'Either

89 IHEither 'True Structure = Shape2 'Either

89 IHEither 'True _ = EitherTable

90 IHEither 'True _ = EitherTable

92−type IHList :: Bool -> Context -> Type -> Type

93+type IHList :: Bool -> K.Context -> Type -> Type

93type family IHList isSpecialContext context where

94type family IHList isSpecialContext context where

94 IHList 'False _ = ListTable

95 IHList 'False _ = ListTable

95− IHList 'True Result = []

96+ IHList 'True Identity = []

96 IHList 'True Structure = Shape1 'List

97 IHList 'True Structure = Shape1 'List

97 IHList 'True _ = ListTable

98 IHList 'True _ = ListTable

100

100−type IHMaybe :: Bool -> Context -> Type -> Type

101+type IHMaybe :: Bool -> K.Context -> Type -> Type

101type family IHMaybe isSpecialContext context where

102type family IHMaybe isSpecialContext context where

102 IHMaybe 'False _ = MaybeTable

103 IHMaybe 'False _ = MaybeTable

103− IHMaybe 'True Result = Maybe

104+ IHMaybe 'True Identity = Maybe

104 IHMaybe 'True Structure = Shape1 'Maybe

105 IHMaybe 'True Structure = Shape1 'Maybe

105 IHMaybe 'True _ = MaybeTable

106 IHMaybe 'True _ = MaybeTable

106

107

108

108−type IHNonEmpty :: Bool -> Context -> Type -> Type

109+type IHNonEmpty :: Bool -> K.Context -> Type -> Type

109type family IHNonEmpty isSpecialContext context where

110type family IHNonEmpty isSpecialContext context where

110 IHNonEmpty 'False _ = NonEmptyTable

111 IHNonEmpty 'False _ = NonEmptyTable

111− IHNonEmpty 'True Result = NonEmpty

112+ IHNonEmpty 'True Identity = NonEmpty

112 IHNonEmpty 'True Structure = Shape1 'NonEmpty

113 IHNonEmpty 'True Structure = Shape1 'NonEmpty

113 IHNonEmpty 'True _ = NonEmptyTable

114 IHNonEmpty 'True _ = NonEmptyTable

114

115

116

116−type IHThese :: Bool -> Context -> Type -> Type -> Type

117+type IHThese :: Bool -> K.Context -> Type -> Type -> Type

117type family IHThese isSpecialContext context where

118type family IHThese isSpecialContext context where

118 IHThese 'False _ = TheseTable

119 IHThese 'False _ = TheseTable

119− IHThese 'True Result = These

120+ IHThese 'True Identity = These

120 IHThese 'True Structure = Shape2 'These

121 IHThese 'True Structure = Shape2 'These

121 IHThese 'True _ = TheseTable

122 IHThese 'True _ = TheseTable

122

123

124

124−type HEither :: Context -> Type -> Type -> Type

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

125type HEither context = IHEither (IsSpecialContext context) context

126type HEither context = IHEither (IsSpecialContext context) context

126

127

128

128−type HList :: Context -> Type -> Type

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

129type HList context = IHList (IsSpecialContext context) context

130type HList context = IHList (IsSpecialContext context) context

130

131

132

132−type HMaybe :: Context -> Type -> Type

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

133type HMaybe context = IHMaybe (IsSpecialContext context) context

134type HMaybe context = IHMaybe (IsSpecialContext context) context

134

135

136

136−type HNonEmpty :: Context -> Type -> Type

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

137type HNonEmpty context = IHNonEmpty (IsSpecialContext context) context

138type HNonEmpty context = IHNonEmpty (IsSpecialContext context) context

138

139

140

140−type HThese :: Context -> Type -> Type -> Type

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

141type HThese context = IHThese (IsSpecialContext context) context

142type HThese context = IHThese (IsSpecialContext context) context

src/Rel8/Schema/Context.hs+49−80

@@ -1,8 +1,10 @@

1{-# language DataKinds #-}

2{-# language DerivingStrategies #-}

3+{-# language FlexibleContexts #-}

3{-# language FlexibleInstances #-}

4{-# language FlexibleInstances #-}

4{-# language GADTs #-}

5{-# language GADTs #-}

5{-# language GeneralizedNewtypeDeriving #-}

6{-# language GeneralizedNewtypeDeriving #-}

7+{-# language MultiParamTypeClasses #-}

6{-# language ScopedTypeVariables #-}

8{-# language ScopedTypeVariables #-}

7{-# language StandaloneDeriving #-}

9{-# language StandaloneDeriving #-}

8{-# language StandaloneKindSignatures #-}

10{-# language StandaloneKindSignatures #-}

@@ -11,121 +13,88 @@

11{-# language UndecidableInstances #-}

13{-# language UndecidableInstances #-}

13module Rel8.Schema.Context

15module Rel8.Schema.Context

14− ( Aggregation( Aggregation )

16+ ( Col'( .. )

15− , DB( DB, unDB )

17+ , Interpretation, Col

16− , Insertion( RequiredInsert, OptionalInsert )

18+ , Insertion(..)

17− , Name( Name )

19+ , Name(..)

18− , Result( Result )

19 , IsSpecialContext

20 , IsSpecialContext

20 )

21 )

21where

22where

23-- base

24-- base

24−import Control.Applicative ( liftA2 )

25+import Data.Functor.Identity ( Identity )

26+import Data.Kind ( Constraint )

25import Data.String ( IsString )

27import Data.String ( IsString )

26import Prelude

28import Prelude

28-- rel8

30-- rel8

29import Rel8.Aggregate ( Aggregate )

31import Rel8.Aggregate ( Aggregate )

30import Rel8.Expr ( Expr )

32import Rel8.Expr ( Expr )

31−import Rel8.Kind.Necessity

32− ( Necessity( Optional, Required )

33+import Rel8.Kind.Necessity ( Necessity( Optional, Required ) )

33− , SNecessity( SOptional, SRequired )

34− , KnownNecessity, necessitySing

35− )

36−import Rel8.Schema.Nullability ( Sql )

34+import qualified Rel8.Schema.Kind as K

37−import Rel8.Schema.Spec ( Context, Spec( Spec ) )

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

38import Rel8.Schema.Structure ( Structure )

36import Rel8.Schema.Structure ( Structure )

39−import Rel8.Type.Monoid ( DBMonoid )

40−import Rel8.Type.Semigroup ( DBSemigroup )

41−

43−type Aggregation :: Context

44−data Aggregation spec where

45− Aggregation :: ()

46− => Aggregate (Expr a)

47− -> Aggregation ('Spec labels necessity dbType a)

39+type Interpretation' :: Bool -> K.Context -> Constraint

40+class IsSpecialContext f ~ isSpecial => Interpretation' isSpecial f where

41+ data Col' isSpecial f :: K.HContext

50−type DB :: Context

51−data DB spec where

52− DB :: ()

53− => { unDB :: Expr a }

54− -> DB ('Spec labels necessity dbType a)

55−deriving stock instance Show (DB spec)

44+instance Interpretation' 'True Aggregate where

45+ data Col' 'True Aggregate _spec where

46+ Aggregation :: ()

47+ => Aggregate (Expr a)

48+ -> Col' 'True Aggregate ('Spec labels necessity db a)

58−instance (spec ~ 'Spec labels necessity dbType a, Sql DBSemigroup a) =>

59− Semigroup (DB spec)

60− where

61− DB a <> DB b = DB (a <> b)

51+instance Interpretation' 'True Expr where

52+ data Col' 'True Expr _spec where

53+ DB :: ()

54+ => { unDB :: Expr a }

55+ -> Col' 'True Expr ('Spec labels necessity db a)

64−instance (spec ~ 'Spec labels necessity dbType a, Sql DBMonoid a) =>

65− Monoid (DB spec)

66− where

67− mempty = DB mempty

58+instance Interpretation' 'True Identity where

59+ data Col' 'True Identity _spec where

60+ Result :: a -> Col' 'True Identity ('Spec labels necessity db a)

70−type Insertion :: Context

71−data Insertion spec where

72− RequiredInsert :: ()

73− => Expr a

74− -> Insertion ('Spec labels 'Required dbType a)

75− OptionalInsert :: ()

76− => Maybe (Expr a)

77− -> Insertion ('Spec labels 'Optional dbType a)

78−deriving stock instance Show (Insertion spec)

63+instance Interpretation' 'True Insertion where

64+ data Col' 'True Insertion _spec where

65+ RequiredInsert :: Expr a -> Col' 'True Insertion ('Spec labels 'Required db a)

66+ OptionalInsert :: Maybe (Expr a) -> Col' 'True Insertion ('Spec labels 'Optional db a)

81−instance (spec ~ 'Spec labels necessity dbType a, Sql DBSemigroup a) =>

82− Semigroup (Insertion spec)

83− where

84− RequiredInsert a <> RequiredInsert b = RequiredInsert (a <> b)

85− OptionalInsert ma <> OptionalInsert mb = OptionalInsert (liftA2 (<>) ma mb)

69+instance IsSpecialContext f ~ 'False => Interpretation' 'False f where

70+ data Col' 'False f _spec where

71+ Col :: f a -> Col' 'False f ('Spec labels necessity db a)

88−instance

89− ( spec ~ 'Spec labels necessity dbType a

90− , KnownNecessity necessity

91− , Sql DBMonoid a

92− ) => Monoid (Insertion spec)

93− where

94− mempty = case necessitySing @necessity of

95− SRequired -> RequiredInsert mempty

96− SOptional -> OptionalInsert (Just mempty)

74+type Interpretation :: K.Context -> Constraint

75+class Interpretation' (IsSpecialContext context) context => Interpretation context

76+instance Interpretation' (IsSpecialContext context) context => Interpretation context

99−type Name :: Context

100−newtype Name spec = Name String

101− deriving stock Show

102− deriving newtype (IsString, Monoid, Semigroup)

103

79+type Col :: K.Context -> K.HContext

80+type Col context = Col' (IsSpecialContext context) context

104

105−type Result :: Context

106−data Result spec where

107− Result :: a -> Result ('Spec labels necessity dbType a)

108−deriving stock instance Show a =>

109− Show (Result ('Spec labels necessity dbType a))

110

83+type Insertion :: K.Context

84+newtype Insertion a = Insertion (Expr a)

111

112−instance (spec ~ 'Spec labels necessity dbType a, Semigroup a) =>

113− Semigroup (Result spec)

114− where

115− Result a <> Result b = Result (a <> b)

116

117−

87+type Name :: K.Context

118−instance (spec ~ 'Spec labels necessity dbType a, Monoid a) =>

88+newtype Name a = Name String

119− Monoid (Result spec)

89+ deriving stock Show

120− where

90+ deriving newtype (IsString, Monoid, Semigroup)

121− mempty = Result mempty

122

123

124−type IsSpecialContext :: Context -> Bool

93+type IsSpecialContext :: K.Context -> Bool

125type family IsSpecialContext context where

94type family IsSpecialContext context where

126− IsSpecialContext Aggregation = 'True

95+ IsSpecialContext Aggregate = 'True

127− IsSpecialContext DB = 'True

96+ IsSpecialContext Expr = 'True

128 IsSpecialContext Insertion = 'True

97 IsSpecialContext Insertion = 'True

129− IsSpecialContext Result = 'True

98+ IsSpecialContext Identity = 'True

130 IsSpecialContext Structure = 'True

99 IsSpecialContext Structure = 'True

131 IsSpecialContext _ = 'False

100 IsSpecialContext _ = 'False

src/Rel8/Schema/Context/Result.hs → src/Rel8/Schema/Context/Identity.hsrenamed+28−28

@@ -3,7 +3,7 @@

3{-# language NamedFieldPuns #-}

4{-# language TypeFamilies #-}

6−module Rel8.Schema.Context.Result

6+module Rel8.Schema.Context.Identity

7 ( fromHEitherTable, toHEitherTable

8 , fromHListTable, toHListTable

9 , fromHMaybeTable, toHMaybeTable

@@ -14,13 +14,13 @@ where

15-- base

16import Data.Functor ( ($>) )

17+import Data.Functor.Identity ( Identity )

17import Data.List.NonEmpty ( NonEmpty )

18import Data.List.NonEmpty ( NonEmpty )

18import Prelude hiding ( null )

19import Prelude hiding ( null )

20-- rel8

21-- rel8

21−import Rel8.Schema.Context ( Result( Result ) )

22+import Rel8.Schema.Context ( Col, Col'( Result ) )

22import Rel8.Schema.HTable ( HTable )

23import Rel8.Schema.HTable ( HTable )

23−import Rel8.Schema.HTable.Context ( H )

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

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

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

@@ -41,8 +41,8 @@ import Data.These.Combinators ( justHere, justThere )

43toHEitherTable :: (HTable t, HTable u)

44− => Either (t (H Result)) (u (H Result))

44+ => Either (t (Col Identity)) (u (Col Identity))

45− -> HEitherTable t u (H Result)

45+ -> HEitherTable t u (Col Identity)

46toHEitherTable = either hleft hright

47 where

48 hleft table = HEitherTable

@@ -59,8 +59,8 @@ toHEitherTable = either hleft hright

61fromHEitherTable :: (HTable t, HTable u)

62− => HEitherTable t u (H Result)

62+ => HEitherTable t u (Col Identity)

63− -> Either (t (H Result)) (u (H Result))

63+ -> Either (t (Col Identity)) (u (Col Identity))

64fromHEitherTable HEitherTable {htag, hleft, hright} = case htag of

65 HIdentity (Result tag) -> case tag of

66 IsLeft -> maybe err Left $ hunnullify unnullifier hleft

@@ -70,17 +70,17 @@ fromHEitherTable HEitherTable {htag, hleft, hright} = case htag of

70{-# INLINABLE fromHEitherTable #-}

73−toHListTable :: HTable t => [t (H Result)] -> HListTable t (H Result)

73+toHListTable :: HTable t => [t (Col Identity)] -> HListTable t (Col Identity)

74toHListTable = hvectorize vectorizer

75{-# INLINABLE toHListTable #-}

78−fromHListTable :: HTable t => HListTable t (H Result) -> [t (H Result)]

78+fromHListTable :: HTable t => HListTable t (Col Identity) -> [t (Col Identity)]

79fromHListTable = hunvectorize unvectorizer

80{-# INLINABLE fromHListTable #-}

83−toHMaybeTable :: HTable t => Maybe (t (H Result)) -> HMaybeTable t (H Result)

83+toHMaybeTable :: HTable t => Maybe (t (Col Identity)) -> HMaybeTable t (Col Identity)

84toHMaybeTable = maybe hnothing hjust

85 where

86 hnothing = HMaybeTable

@@ -94,7 +94,7 @@ toHMaybeTable = maybe hnothing hjust

94{-# INLINABLE toHMaybeTable #-}

97−fromHMaybeTable :: HTable t => HMaybeTable t (H Result) -> Maybe (t (H Result))

97+fromHMaybeTable :: HTable t => HMaybeTable t (Col Identity) -> Maybe (t (Col Identity))

98fromHMaybeTable HMaybeTable {htag, hjust} = case htag of

99 HIdentity (Result tag) -> tag $>

100 case hunnullify unnullifier hjust of

@@ -103,19 +103,19 @@ fromHMaybeTable HMaybeTable {htag, hjust} = case htag of

103{-# INLINABLE fromHMaybeTable #-}

104

105

106−toHNonEmptyTable :: HTable t => NonEmpty (t (H Result)) -> HNonEmptyTable t (H Result)

106+toHNonEmptyTable :: HTable t => NonEmpty (t (Col Identity)) -> HNonEmptyTable t (Col Identity)

107toHNonEmptyTable = hvectorize vectorizer

108{-# INLINABLE toHNonEmptyTable #-}

109

110

111−fromHNonEmptyTable :: HTable t => HNonEmptyTable t (H Result) -> NonEmpty (t (H Result))

111+fromHNonEmptyTable :: HTable t => HNonEmptyTable t (Col Identity) -> NonEmpty (t (Col Identity))

112fromHNonEmptyTable = hunvectorize unvectorizer

113{-# INLINABLE fromHNonEmptyTable #-}

114

115

116toHTheseTable :: (HTable t, HTable u)

117− => These (t (H Result)) (u (H Result))

117+ => These (t (Col Identity)) (u (Col Identity))

118− -> HTheseTable t u (H Result)

118+ -> HTheseTable t u (Col Identity)

119toHTheseTable tables = HTheseTable

120 { hhereTag = relabel hhereTag

121 , hhere

@@ -135,8 +135,8 @@ toHTheseTable tables = HTheseTable

135

136

137fromHTheseTable :: (HTable t, HTable u)

138− => HTheseTable t u (H Result)

138+ => HTheseTable t u (Col Identity)

139− -> These (t (H Result)) (u (H Result))

139+ -> These (t (Col Identity)) (u (Col Identity))

140fromHTheseTable HTheseTable {hhereTag, hhere, hthereTag, hthere} =

141 case (fromHMaybeTable mhere, fromHMaybeTable mthere) of

142 (Just a, Nothing) -> This a

@@ -155,14 +155,14 @@ fromHTheseTable HTheseTable {hhereTag, hhere, hthereTag, hthere} =

155{-# INLINABLE fromHTheseTable #-}

156

157

158−null :: Result ('Spec labels necessity db (Maybe db))

158+null :: Col Identity ('Spec labels necessity db (Maybe db))

159null = Result Nothing

160

161

162nullifier :: ()

163 => SSpec ('Spec labels necessity db a)

164− -> Result ('Spec labels necessity db a)

164+ -> Col Identity ('Spec labels necessity db a)

165− -> Result ('Spec labels necessity db (Maybe db))

165+ -> Col Identity ('Spec labels necessity db (Maybe db))

166nullifier SSpec {nullability} (Result a) = Result $ case nullability of

167 Nullable -> a

168 NonNullable -> Just a

@@ -170,8 +170,8 @@ nullifier SSpec {nullability} (Result a) = Result $ case nullability of

170

171unnullifier :: ()

172 => SSpec ('Spec labels necessity db a)

173− -> Result ('Spec labels necessity db (Maybe db))

173+ -> Col Identity ('Spec labels necessity db (Maybe db))

174− -> Maybe (Result ('Spec labels necessity db a))

174+ -> Maybe (Col Identity ('Spec labels necessity db a))

175unnullifier SSpec {nullability} (Result a) =

176 case nullability of

177 Nullable -> pure $ Result a

@@ -180,19 +180,19 @@ unnullifier SSpec {nullability} (Result a) =

180

181vectorizer :: Functor f

182 => SSpec ('Spec labels necessity db a)

183− -> f (Result ('Spec labels necessity db a))

183+ -> f (Col Identity ('Spec labels necessity db a))

184− -> Result ('Spec labels necessity (f a) (f a))

184+ -> Col Identity ('Spec labels necessity (f a) (f a))

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

186

187

188unvectorizer :: Functor f

189 => SSpec ('Spec labels necessity db a)

190− -> Result ('Spec labels necessity (f a) (f a))

190+ -> Col Identity ('Spec labels necessity (f a) (f a))

191− -> f (Result ('Spec labels necessity db a))

191+ -> f (Col Identity ('Spec labels necessity db a))

192unvectorizer _ (Result results) = Result <$> results

193

194

195relabel :: ()

196− => HIdentity ('Spec labels necessity db a) (H Result)

196+ => HIdentity ('Spec labels necessity db a) (Col Identity)

197− -> HIdentity ('Spec relabels necessity db a) (H Result)

197+ -> HIdentity ('Spec relabels necessity db a) (Col Identity)

198relabel (HIdentity (Result a)) = HIdentity (Result a)

src/Rel8/Schema/Context/Label.hs+42−20

@@ -8,41 +8,43 @@

9module Rel8.Schema.Context.Label

10 ( Labelable( labeler, unlabeler )

11+ , HLabelable( hlabeler, hunlabeler )

11 )

12 )

12where

13where

14-- base

15-- base

16+import Data.Functor.Identity ( Identity )

15import Data.Kind ( Constraint )

17import Data.Kind ( Constraint )

16import Prelude hiding ( null )

18import Prelude hiding ( null )

18-- rel8

20-- rel8

21+import Rel8.Aggregate ( Aggregate )

22+import Rel8.Expr ( Expr )

19import Rel8.Schema.Context

23import Rel8.Schema.Context

20− ( Aggregation( Aggregation )

24+ ( Interpretation, Col, Col'(..), IsSpecialContext

21− , DB( DB )

25+ , Insertion

22− , Insertion( RequiredInsert, OptionalInsert )

23− , Name( Name )

24− , Result( Result )

25 )

26 )

26−import Rel8.Schema.Spec ( Context, Spec( Spec ) )

27+import qualified Rel8.Schema.Kind as K

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

29−type Labelable :: Context -> Constraint

31+type Labelable :: K.Context -> Constraint

30−class Labelable context where

32+class Interpretation context => Labelable context where

31 labeler :: ()

33 labeler :: ()

32− => context ('Spec labels necessity db a)

34+ => Col context ('Spec labels necessity db a)

33− -> context ('Spec (label ': labels) necessity db a)

35+ -> Col context ('Spec (label ': labels) necessity db a)

35 unlabeler :: ()

37 unlabeler :: ()

36− => context ('Spec (label ': labels) necessity db a)

38+ => Col context ('Spec (label ': labels) necessity db a)

37− -> context ('Spec labels necessity db a)

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

40−instance Labelable Aggregation where

42+instance Labelable Aggregate where

41 labeler (Aggregation aggregate) = Aggregation aggregate

43 labeler (Aggregation aggregate) = Aggregation aggregate

42 unlabeler (Aggregation aggregate) = Aggregation aggregate

44 unlabeler (Aggregation aggregate) = Aggregation aggregate

45−instance Labelable DB where

47+instance Labelable Expr where

46 labeler (DB a) = DB a

48 labeler (DB a) = DB a

47 unlabeler (DB a) = DB a

49 unlabeler (DB a) = DB a

@@ -57,11 +59,31 @@ instance Labelable Insertion where

57 OptionalInsert ma -> OptionalInsert ma

59 OptionalInsert ma -> OptionalInsert ma

60−instance Labelable Name where

62+instance Labelable Identity where

61− labeler (Name name) = Name name

62− unlabeler (Name name) = Name name

63−

64−

65−instance Labelable Result where

66 labeler (Result a) = Result a

63 labeler (Result a) = Result a

67 unlabeler (Result a) = Result a

64 unlabeler (Result a) = Result a

65+

66+

67+instance {-# OVERLAPPABLE #-} IsSpecialContext context ~ 'False =>

68+ Labelable context

69+ where

70+ labeler (Col a) = Col a

71+ unlabeler (Col a) = Col a

72+

73+

74+type HLabelable :: K.HContext -> Constraint

75+class HLabelable context where

76+ hlabeler :: ()

77+ => context ('Spec labels necessity db a)

78+ -> context ('Spec (label ': labels) necessity db a)

79+

80+ hunlabeler :: ()

81+ => context ('Spec (label ': labels) necessity db a)

82+ -> context ('Spec labels necessity db a)

83+

84+

85+instance (Labelable context, x ~ IsSpecialContext context) =>

86+ HLabelable (Col' x context)

87+ where

88+ hlabeler = labeler

89+ hunlabeler = hunlabeler

src/Rel8/Schema/Context/Nullify.hs+20−19

@@ -36,41 +36,42 @@ import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )

36import Rel8.Kind.Labels ( KnownLabels, labelsSing, renderLabels )

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

38import Rel8.Schema.Context

39− ( Aggregation( Aggregation )

39+ ( Interpretation

40− , DB( DB )

40+ , Col, Col'(..)

41− , Insertion( RequiredInsert, OptionalInsert )

41+ , Insertion

42 , Name( Name )

43 )

44+import qualified Rel8.Schema.Kind as K

44import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ), Sql )

45import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ), Sql )

45−import Rel8.Schema.Spec ( Context, Spec( Spec ), SSpec(..) )

46+import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )

46import Rel8.Type.Eq ( DBEq )

47import Rel8.Type.Eq ( DBEq )

47import Rel8.Type.Monoid ( DBMonoid )

48import Rel8.Type.Monoid ( DBMonoid )

50−type Nullifiable :: Context -> Constraint

51+type Nullifiable :: K.Context -> Constraint

51−class Nullifiable context where

52+class Interpretation context => Nullifiable context where

52 encodeTag :: (Sql DBEq a, KnownLabels labels)

53 encodeTag :: (Sql DBEq a, KnownLabels labels)

53 => Expr a

54 => Expr a

54− -> context ('Spec labels 'Required db a)

55+ -> Col context ('Spec labels 'Required db a)

56 decodeTag :: Sql DBMonoid a

57 decodeTag :: Sql DBMonoid a

57− => context ('Spec labels 'Required db a)

58+ => Col context ('Spec labels 'Required db a)

58 -> Expr a

59 -> Expr a

60 nullifier :: ()

61 nullifier :: ()

61 => Expr Bool

62 => Expr Bool

62 -> SSpec ('Spec labels necessity db a)

63 -> SSpec ('Spec labels necessity db a)

63− -> context ('Spec labels necessity db a)

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

64− -> context ('Spec labels necessity db (Maybe db))

65+ -> Col context ('Spec labels necessity db (Maybe db))

66 unnullifier :: ()

67 unnullifier :: ()

67 => Expr Bool

68 => Expr Bool

68 -> SSpec ('Spec labels necessity db a)

69 -> SSpec ('Spec labels necessity db a)

69− -> context ('Spec labels necessity db (Maybe db))

70+ -> Col context ('Spec labels necessity db (Maybe db))

70− -> context ('Spec labels necessity db a)

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

73−instance Nullifiable Aggregation where

74+instance Nullifiable Aggregate where

74 encodeTag = Aggregation . groupByExpr

75 encodeTag = Aggregation . groupByExpr

75 decodeTag (Aggregation aggregate) = fold $ undoGroupBy aggregate

76 decodeTag (Aggregation aggregate) = fold $ undoGroupBy aggregate

@@ -87,7 +88,7 @@ instance Nullifiable Aggregation where

87 {-# INLINABLE unnullifier #-}

88 {-# INLINABLE unnullifier #-}

90−instance Nullifiable DB where

91+instance Nullifiable Expr where

91 encodeTag = DB

92 encodeTag = DB

92 decodeTag (DB a) = a

93 decodeTag (DB a) = a

93 nullifier tag SSpec {nullability} (DB a) = DB $ runTag nullability tag a

94 nullifier tag SSpec {nullability} (DB a) = DB $ runTag nullability tag a

@@ -120,8 +121,8 @@ instance Nullifiable Insertion where

120instance Nullifiable Name where

121instance Nullifiable Name where

121 encodeTag _ = nameFromLabel

122 encodeTag _ = nameFromLabel

122 decodeTag _ = mempty

123 decodeTag _ = mempty

123− nullifier _ _ (Name name) = Name name

124+ nullifier _ _ (Col (Name name)) = Col (Name name)

124− unnullifier _ _ (Name name) = Name name

125+ unnullifier _ _ (Col (Name name)) = Col (Name name)

125

126

126 {-# INLINABLE encodeTag #-}

127 {-# INLINABLE encodeTag #-}

127 {-# INLINABLE decodeTag #-}

128 {-# INLINABLE decodeTag #-}

@@ -129,7 +130,7 @@ instance Nullifiable Name where

129 {-# INLINABLE unnullifier #-}

130 {-# INLINABLE unnullifier #-}

130

131

132

132−type NullifiableEq :: Context -> Context -> Constraint

133+type NullifiableEq :: K.Context -> K.Context -> Constraint

133class (a ~ b, Nullifiable b) => NullifiableEq a b

134class (a ~ b, Nullifiable b) => NullifiableEq a b

134instance (a ~ b, Nullifiable b) => NullifiableEq a b

135instance (a ~ b, Nullifiable b) => NullifiableEq a b

135

136

@@ -157,6 +158,6 @@ undoGroupBy = getFirst . foldInputs go

157

158

159

159nameFromLabel :: forall labels necessity db a.

160nameFromLabel :: forall labels necessity db a.

160− KnownLabels labels => Name ('Spec labels necessity db a)

161+ KnownLabels labels => Col Name ('Spec labels necessity db a)

161nameFromLabel = case labelsSing @labels of

162nameFromLabel = case labelsSing @labels of

162− labels -> Name (NonEmpty.last (renderLabels labels))

163+ labels -> Col (Name (NonEmpty.last (renderLabels labels)))

src/Rel8/Schema/Field.hs+10−11

@@ -9,6 +9,7 @@ module Rel8.Schema.Field

9where

11-- base

12+import Data.Functor.Identity ( Identity )

12import Data.Kind ( Type )

13import Data.Kind ( Type )

13import Prelude

14import Prelude

@@ -17,25 +18,23 @@ import Rel8.Aggregate ( Aggregate )

17import Rel8.Expr ( Expr )

18import Rel8.Expr ( Expr )

18import Rel8.Kind.Labels ( Labels )

19import Rel8.Kind.Labels ( Labels )

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

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

20−import Rel8.Schema.Context

21+import Rel8.Schema.Context ( Insertion, IsSpecialContext )

21− ( Aggregation, DB, Insertion, Result

22+import qualified Rel8.Schema.Kind as K

22− , IsSpecialContext

23− )

24−import Rel8.Schema.Spec ( Context, Spec( Spec ) )

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

25import Rel8.Schema.Structure ( Structure, Shape( Column ), Shape1 )

24import Rel8.Schema.Structure ( Structure, Shape( Column ), Shape1 )

28−type IField :: Bool -> Context -> Labels -> Necessity -> Type -> Type -> Type

27+type IField :: Bool -> K.Context -> Labels -> Necessity -> Type -> Type -> Type

29type family IField isSpecialContext labels context necessity db a where

28type family IField isSpecialContext labels context necessity db a where

30− IField 'False context labels necessity db a = context ('Spec labels necessity db a)

29+ IField 'False context _labels _necessity _db a = context a

31− IField 'True Result _labels _necessity _db a = a

30+ IField 'True Identity _labels _necessity _db a = a

32− IField 'True DB _labels _necessity _db a = Expr a

31+ IField 'True Expr _labels _necessity _db a = Expr a

33 IField 'True Insertion _labels 'Required _db a = Expr a

32 IField 'True Insertion _labels 'Required _db a = Expr a

34 IField 'True Insertion _labels 'Optional _db a = Maybe (Expr a)

33 IField 'True Insertion _labels 'Optional _db a = Maybe (Expr a)

35− IField 'True Aggregation _labels _necessity _db a = Aggregate (Expr a)

34+ IField 'True Aggregate _labels _necessity _db a = Aggregate (Expr a)

36 IField 'True Structure labels necessity db a = Shape1 'Column ('Spec labels necessity db a)

35 IField 'True Structure labels necessity db a = Shape1 'Column ('Spec labels necessity db a)

39−type Field :: Context -> Labels -> Necessity -> Type -> Type -> Type

38+type Field :: K.Context -> Labels -> Necessity -> Type -> Type -> Type

40type Field context labels necessity db a =

39type Field context labels necessity db a =

41 IField (IsSpecialContext context) context labels necessity db a

40 IField (IsSpecialContext context) context labels necessity db a

src/Rel8/Schema/Generic.hs+159−160

@@ -23,6 +23,7 @@ where

24-- base

25import Data.Bifunctor ( bimap )

26+import Data.Functor.Identity ( Identity )

26import Data.Kind ( Constraint, Type )

27import Data.Kind ( Constraint, Type )

27import Data.List.NonEmpty ( NonEmpty )

28import Data.List.NonEmpty ( NonEmpty )

28import GHC.Generics

29import GHC.Generics

@@ -35,29 +36,27 @@ import GHC.TypeLits ( Symbol )

35import Prelude

36import Prelude

37-- rel8

38-- rel8

39+import Rel8.Aggregate ( Aggregate )

40+import Rel8.Expr ( Expr )

38import Rel8.Kind.Necessity

41import Rel8.Kind.Necessity

39 ( SNecessity( SRequired, SOptional )

42 ( SNecessity( SRequired, SOptional )

40 , KnownNecessity, necessitySing

43 , KnownNecessity, necessitySing

41 )

44 )

42import Rel8.Schema.Context

45import Rel8.Schema.Context

43− ( Aggregation( Aggregation )

44− , DB( DB )

45− , Insertion( RequiredInsert, OptionalInsert )

46− , Result( Result )

47− , IsSpecialContext

48− )

49−import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )

46+import Rel8.Schema.Context.Identity

50−import Rel8.Schema.Context.Nullify ( Nullifiable )

51−import Rel8.Schema.Context.Result

52 ( fromHEitherTable, toHEitherTable

47 ( fromHEitherTable, toHEitherTable

53 , fromHListTable, toHListTable

48 , fromHListTable, toHListTable

54 , fromHMaybeTable, toHMaybeTable

49 , fromHMaybeTable, toHMaybeTable

55 , fromHNonEmptyTable, toHNonEmptyTable

50 , fromHNonEmptyTable, toHNonEmptyTable

56 , fromHTheseTable, toHTheseTable

51 , fromHTheseTable, toHTheseTable

57 )

52 )

53+import Rel8.Schema.Context.Label

54+ ( Labelable, labeler, unlabeler

55+ , hlabeler, hunlabeler

56+ )

57+import Rel8.Schema.Context.Nullify ( Nullifiable )

58import Rel8.Schema.Field ( Field )

59import Rel8.Schema.HTable ( HTable )

60−import Rel8.Schema.HTable.Context ( H, HKTable )

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

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

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

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

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

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

@@ -70,8 +69,8 @@ import Rel8.Schema.HTable.Quintet ( HQuintet(..) )

70import Rel8.Schema.HTable.These ( HTheseTable )

69import Rel8.Schema.HTable.These ( HTheseTable )

71import Rel8.Schema.HTable.Trio ( HTrio(..) )

70import Rel8.Schema.HTable.Trio ( HTrio(..) )

72import Rel8.Schema.HTable.Vectorize ( hrelabel )

71import Rel8.Schema.HTable.Vectorize ( hrelabel )

72+import qualified Rel8.Schema.Kind as K

73import Rel8.Schema.Spec ( Spec( Spec ), KTable )

74−import qualified Rel8.Schema.Spec as Kind ( Context )

75import Rel8.Schema.Structure

74import Rel8.Schema.Structure

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

75 ( IsStructure, Shape(..), Shape1, Shape2

77 , Structure

76 , Structure

@@ -102,22 +101,22 @@ instance (Rel8able t, TableHelper (IsSpecialContext context) context) =>

102 toColumns = gtoColumns

101 toColumns = gtoColumns

103

102

104

103

105−type TableHelper :: Bool -> Kind.Context -> Constraint

104+type TableHelper :: Bool -> K.Context -> Constraint

106class IsSpecialContext context ~ isSpecialContext =>

105class IsSpecialContext context ~ isSpecialContext =>

107 TableHelper isSpecialContext context

106 TableHelper isSpecialContext context

108 where

107 where

109− gfromColumns :: Rel8able t => GRep t (H context) -> t context

108+ gfromColumns :: Rel8able t => GRep t (Col context) -> t context

110− gtoColumns :: Rel8able t => t context -> GRep t (H context)

109+ gtoColumns :: Rel8able t => t context -> GRep t (Col context)

111

110

112

111

113−instance TableHelper 'True Aggregation where

112+instance TableHelper 'True Aggregate where

114− gfromColumns = fromAggregationColumns

113+ gfromColumns = fromAggregateColumns

115− gtoColumns = toAggregationColumns

114+ gtoColumns = toAggregateColumns

116

115

117

116

118−instance TableHelper 'True DB where

117+instance TableHelper 'True Expr where

119− gfromColumns = fromDBColumns

118+ gfromColumns = fromExprColumns

120− gtoColumns = toDBColumns

119+ gtoColumns = toExprColumns

121

120

122

121

123instance TableHelper 'True Insertion where

122instance TableHelper 'True Insertion where

@@ -125,9 +124,9 @@ instance TableHelper 'True Insertion where

125 gtoColumns = toInsertionColumns

124 gtoColumns = toInsertionColumns

126

125

127

126

128−instance TableHelper 'True Result where

127+instance TableHelper 'True Identity where

129− gfromColumns = fromResultColumns

128+ gfromColumns = fromIdentityColumns

130− gtoColumns = toResultColumns

129+ gtoColumns = toIdentityColumns

131

130

132

131

133instance (IsSpecialContext context ~ 'False, Labelable context, Nullifiable context) =>

132instance (IsSpecialContext context ~ 'False, Labelable context, Nullifiable context) =>

@@ -139,105 +138,105 @@ instance (IsSpecialContext context ~ 'False, Labelable context, Nullifiable cont

139

138

140type Rel8able :: KTable -> Constraint

139type Rel8able :: KTable -> Constraint

141class HTable (GRep t) => Rel8able t where

140class HTable (GRep t) => Rel8able t where

142− type GRep t :: HKTable

141+ type GRep t :: K.HTable

143

142

144− fromAggregationColumns :: GRep t (H Aggregation) -> t Aggregation

143+ fromAggregateColumns :: GRep t (Col Aggregate) -> t Aggregate

145− toAggregationColumns :: t Aggregation -> GRep t (H Aggregation)

144+ toAggregateColumns :: t Aggregate -> GRep t (Col Aggregate)

146

145

147− fromDBColumns :: GRep t (H DB) -> t DB

146+ fromExprColumns :: GRep t (Col Expr) -> t Expr

148− toDBColumns :: t DB -> GRep t (H DB)

147+ toExprColumns :: t Expr -> GRep t (Col Expr)

149

148

150− fromInsertionColumns :: GRep t (H Insertion) -> t Insertion

149+ fromInsertionColumns :: GRep t (Col Insertion) -> t Insertion

151− toInsertionColumns :: t Insertion -> GRep t (H Insertion)

150+ toInsertionColumns :: t Insertion -> GRep t (Col Insertion)

152

151

153− fromResultColumns :: GRep t (H Result) -> t Result

152+ fromIdentityColumns :: GRep t (Col Identity) -> t Identity

154− toResultColumns :: t Result -> GRep t (H Result)

153+ toIdentityColumns :: t Identity -> GRep t (Col Identity)

155

154

156 fromUnspecialColumns ::

155 fromUnspecialColumns ::

157 ( IsSpecialContext context ~ 'False

156 ( IsSpecialContext context ~ 'False

158 , Labelable context, Nullifiable context

157 , Labelable context, Nullifiable context

159 )

158 )

160− => GRep t (H context) -> t context

159+ => GRep t (Col context) -> t context

161 toUnspecialColumns ::

160 toUnspecialColumns ::

162 ( IsSpecialContext context ~ 'False

161 ( IsSpecialContext context ~ 'False

163 , Labelable context, Nullifiable context

162 , Labelable context, Nullifiable context

164 )

163 )

165− => t context -> GRep t (H context)

164+ => t context -> GRep t (Col context)

166

165

167 type GRep t = GColumns (Rep (t Structure))

166 type GRep t = GColumns (Rep (t Structure))

168

167

169− default fromAggregationColumns ::

168+ default fromAggregateColumns ::

170− ( Generic (t Aggregation)

169+ ( Generic (t Aggregate)

171 , GColumns (Rep (t Structure)) ~ GRep t

170 , GColumns (Rep (t Structure)) ~ GRep t

172− , GRel8able Aggregation (Rep (t Structure)) (Rep (t Aggregation))

171+ , GRel8able Aggregate (Rep (t Structure)) (Rep (t Aggregate))

173− ) => GRep t (H Aggregation) -> t Aggregation

172+ ) => GRep t (Col Aggregate) -> t Aggregate

174− fromAggregationColumns = to . fromGColumns @_ @(Rep (t Structure))

173+ fromAggregateColumns = to . fromGColumns @_ @(Rep (t Structure))

175

174

176− default toAggregationColumns ::

175+ default toAggregateColumns ::

177− ( Generic (t Aggregation)

176+ ( Generic (t Aggregate)

178 , GColumns (Rep (t Structure)) ~ GRep t

177 , GColumns (Rep (t Structure)) ~ GRep t

179− , GRel8able Aggregation (Rep (t Structure)) (Rep (t Aggregation))

178+ , GRel8able Aggregate (Rep (t Structure)) (Rep (t Aggregate))

180− ) => t Aggregation -> GRep t (H Aggregation)

179+ ) => t Aggregate -> GRep t (Col Aggregate)

181− toAggregationColumns = toGColumns @_ @(Rep (t Structure)) . from

180+ toAggregateColumns = toGColumns @_ @(Rep (t Structure)) . from

182

181

183− default fromDBColumns ::

182+ default fromExprColumns ::

184− ( Generic (t DB)

183+ ( Generic (t Expr)

185 , GColumns (Rep (t Structure)) ~ GRep t

184 , GColumns (Rep (t Structure)) ~ GRep t

186− , GRel8able DB (Rep (t Structure)) (Rep (t DB))

185+ , GRel8able Expr (Rep (t Structure)) (Rep (t Expr))

187− ) => GRep t (H DB) -> t DB

186+ ) => GRep t (Col Expr) -> t Expr

188− fromDBColumns = to . fromGColumns @_ @(Rep (t Structure))

187+ fromExprColumns = to . fromGColumns @_ @(Rep (t Structure))

189

188

190− default toDBColumns ::

189+ default toExprColumns ::

191− ( Generic (t DB)

190+ ( Generic (t Expr)

192 , GColumns (Rep (t Structure)) ~ GRep t

191 , GColumns (Rep (t Structure)) ~ GRep t

193− , GRel8able DB (Rep (t Structure)) (Rep (t DB))

192+ , GRel8able Expr (Rep (t Structure)) (Rep (t Expr))

194− ) => t DB -> GRep t (H DB)

193+ ) => t Expr -> GRep t (Col Expr)

195− toDBColumns = toGColumns @_ @(Rep (t Structure)) . from

194+ toExprColumns = toGColumns @_ @(Rep (t Structure)) . from

196

195

197 default fromInsertionColumns ::

196 default fromInsertionColumns ::

198 ( Generic (t Insertion)

197 ( Generic (t Insertion)

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

198 , GColumns (Rep (t Structure)) ~ GRep t

200 , GRel8able Insertion (Rep (t Structure)) (Rep (t Insertion))

199 , GRel8able Insertion (Rep (t Structure)) (Rep (t Insertion))

201− ) => GRep t (H Insertion) -> t Insertion

200+ ) => GRep t (Col Insertion) -> t Insertion

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

201 fromInsertionColumns = to . fromGColumns @_ @(Rep (t Structure))

203

202

204 default toInsertionColumns ::

203 default toInsertionColumns ::

205 ( Generic (t Insertion)

204 ( Generic (t Insertion)

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

205 , GColumns (Rep (t Structure)) ~ GRep t

207 , GRel8able Insertion (Rep (t Structure)) (Rep (t Insertion))

206 , GRel8able Insertion (Rep (t Structure)) (Rep (t Insertion))

208− ) => t Insertion -> GRep t (H Insertion)

207+ ) => t Insertion -> GRep t (Col Insertion)

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

208 toInsertionColumns = toGColumns @_ @(Rep (t Structure)) . from

210

209

211− default fromResultColumns ::

210+ default fromIdentityColumns ::

212− ( Generic (t Result)

211+ ( Generic (t Identity)

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

212 , GColumns (Rep (t Structure)) ~ GRep t

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

213+ , GRel8able Identity (Rep (t Structure)) (Rep (t Identity))

215− ) => GRep t (H Result) -> t Result

214+ ) => GRep t (Col Identity) -> t Identity

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

215+ fromIdentityColumns = to . fromGColumns @_ @(Rep (t Structure))

217

216

218− default toResultColumns ::

217+ default toIdentityColumns ::

219− ( Generic (t Result)

218+ ( Generic (t Identity)

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

219 , GColumns (Rep (t Structure)) ~ GRep t

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

220+ , GRel8able Identity (Rep (t Structure)) (Rep (t Identity))

222− ) => t Result -> GRep t (H Result)

221+ ) => t Identity -> GRep t (Col Identity)

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

222+ toIdentityColumns = toGColumns @_ @(Rep (t Structure)) . from

224

223

225 default fromUnspecialColumns ::

224 default fromUnspecialColumns ::

226 ( Generic (t context)

225 ( Generic (t context)

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

226 , GColumns (Rep (t Structure)) ~ GRep t

228 , GRel8able context (Rep (t Structure)) (Rep (t context))

227 , GRel8able context (Rep (t Structure)) (Rep (t context))

229− ) => GRep t (H context) -> t context

228+ ) => GRep t (Col context) -> t context

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

229 fromUnspecialColumns = to . fromGColumns @_ @(Rep (t Structure))

231

230

232 default toUnspecialColumns ::

231 default toUnspecialColumns ::

233 ( Generic (t context)

232 ( Generic (t context)

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

233 , GColumns (Rep (t Structure)) ~ GRep t

235 , GRel8able context (Rep (t Structure)) (Rep (t context))

234 , GRel8able context (Rep (t Structure)) (Rep (t context))

236− ) => t context -> GRep t (H context)

235+ ) => t context -> GRep t (Col context)

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

236 toUnspecialColumns = toGColumns @_ @(Rep (t Structure)) . from

238

237

239

238

240−type GColumns :: (Type -> Type) -> HKTable

239+type GColumns :: (Type -> Type) -> K.HTable

241type family GColumns structure where

240type family GColumns structure where

242 GColumns (M1 D _ structure) = GColumns structure

241 GColumns (M1 D _ structure) = GColumns structure

243 GColumns (M1 C _ structure) = GColumns structure

242 GColumns (M1 C _ structure) = GColumns structure

@@ -246,10 +245,10 @@ type family GColumns structure where

246 K1Columns label structure

245 K1Columns label structure

247

246

248

247

249−type GRel8able :: Kind.Context -> (Type -> Type) -> (Type -> Type) -> Constraint

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

250class GRel8able context structure rep where

249class GRel8able context structure rep where

251− fromGColumns :: GColumns structure (H context) -> rep x

250+ fromGColumns :: GColumns structure (Col context) -> rep x

252− toGColumns :: rep x -> GColumns structure (H context)

251+ toGColumns :: rep x -> GColumns structure (Col context)

253

252

254

253

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

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

@@ -285,7 +284,7 @@ instance

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

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

286

285

287

286

288−type K1Columns :: Symbol -> Type -> HKTable

287+type K1Columns :: Symbol -> Type -> K.HTable

289type family K1Columns label structure where

288type family K1Columns label structure where

290 K1Columns label (Shape1 'Column ('Spec '[] necessity nullability blueprint)) =

289 K1Columns label (Shape1 'Column ('Spec '[] necessity nullability blueprint)) =

291 HIdentity ('Spec '[label] necessity nullability blueprint)

290 HIdentity ('Spec '[label] necessity nullability blueprint)

@@ -327,19 +326,19 @@ type family K1Columns label structure where

327 K1Columns label a = HLabel label (Columns a)

326 K1Columns label a = HLabel label (Columns a)

328

327

329

328

330−type K1Table :: Symbol -> Bool -> Kind.Context -> Bool -> Type -> Type -> Constraint

329+type K1Table :: Symbol -> Bool -> K.Context -> Bool -> Type -> Type -> Constraint

331class

330class

332 ( isSpecialContext ~ IsSpecialContext context

331 ( isSpecialContext ~ IsSpecialContext context

333 , isStructure ~ IsStructure structure

332 , isStructure ~ IsStructure structure

334 ) => K1Table label isSpecialContext context isStructure structure a

333 ) => K1Table label isSpecialContext context isStructure structure a

335 where

334 where

336− fromK1Columns :: K1Columns label structure (H context) -> a

335+ fromK1Columns :: K1Columns label structure (Col context) -> a

337− toK1Columns :: a -> K1Columns label structure (H context)

336+ toK1Columns :: a -> K1Columns label structure (Col context)

338

337

339

338

340instance

339instance

341− ( x ~ Field Aggregation '[] necessity db a

340+ ( x ~ Field Aggregate '[] necessity db a

342− ) => K1Table label 'True Aggregation 'True (Shape1 'Column ('Spec '[] necessity db a)) x

341+ ) => K1Table label 'True Aggregate 'True (Shape1 'Column ('Spec '[] necessity db a)) x

343 where

342 where

344 fromK1Columns (HIdentity (Aggregation a)) = a

343 fromK1Columns (HIdentity (Aggregation a)) = a

345 toK1Columns = HIdentity . Aggregation

344 toK1Columns = HIdentity . Aggregation

@@ -348,8 +347,8 @@ instance

348

347

349

348

350instance

349instance

351− ( x ~ Field Aggregation (label ': labels) necessity db a

350+ ( x ~ Field Aggregate (label ': labels) necessity db a

352− ) => K1Table _label 'True Aggregation 'True (Shape1 'Column ('Spec (label ': labels) necessity db a)) x

351+ ) => K1Table _label 'True Aggregate 'True (Shape1 'Column ('Spec (label ': labels) necessity db a)) x

353 where

352 where

354 fromK1Columns (HIdentity (Aggregation a)) = a

353 fromK1Columns (HIdentity (Aggregation a)) = a

355 toK1Columns = HIdentity . Aggregation

354 toK1Columns = HIdentity . Aggregation

@@ -358,8 +357,8 @@ instance

358

357

359

358

360instance

359instance

361− ( x ~ Field DB '[] necessity db a

360+ ( x ~ Field Expr '[] necessity db a

362− ) => K1Table label 'True DB 'True (Shape1 'Column ('Spec '[] necessity db a)) x

361+ ) => K1Table label 'True Expr 'True (Shape1 'Column ('Spec '[] necessity db a)) x

363 where

362 where

364 fromK1Columns (HIdentity (DB a)) = a

363 fromK1Columns (HIdentity (DB a)) = a

365 toK1Columns = HIdentity . DB

364 toK1Columns = HIdentity . DB

@@ -368,8 +367,8 @@ instance

368

367

369

368

370instance

369instance

371− ( x ~ Field DB (label ': labels) necessity db a

370+ ( x ~ Field Expr (label ': labels) necessity db a

372− ) => K1Table _label 'True DB 'True (Shape1 'Column ('Spec (label ': labels) necessity db a)) x

371+ ) => K1Table _label 'True Expr 'True (Shape1 'Column ('Spec (label ': labels) necessity db a)) x

373 where

372 where

374 fromK1Columns (HIdentity (DB a)) = a

373 fromK1Columns (HIdentity (DB a)) = a

375 toK1Columns = HIdentity . DB

374 toK1Columns = HIdentity . DB

@@ -408,8 +407,8 @@ instance

408

407

409

408

410instance

409instance

411− ( x ~ Field Result '[] necessity db a

410+ ( x ~ Field Identity '[] necessity db a

412− ) => K1Table label 'True Result 'True (Shape1 'Column ('Spec '[] necessity db a)) x

411+ ) => K1Table label 'True Identity 'True (Shape1 'Column ('Spec '[] necessity db a)) x

413 where

412 where

414 fromK1Columns (HIdentity (Result a)) = a

413 fromK1Columns (HIdentity (Result a)) = a

415 toK1Columns = HIdentity . Result

414 toK1Columns = HIdentity . Result

@@ -418,8 +417,8 @@ instance

418

417

419

418

420instance

419instance

421− ( x ~ Field Result (label ': labels) necessity db a

420+ ( x ~ Field Identity (label ': labels) necessity db a

422− ) => K1Table _label 'True Result 'True (Shape1 'Column ('Spec (label ': labels) necessity db a)) x

421+ ) => K1Table _label 'True Identity 'True (Shape1 'Column ('Spec (label ': labels) necessity db a)) x

423 where

422 where

424 fromK1Columns (HIdentity (Result a)) = a

423 fromK1Columns (HIdentity (Result a)) = a

425 toK1Columns = HIdentity . Result

424 toK1Columns = HIdentity . Result

@@ -429,23 +428,23 @@ instance

429

428

430instance

429instance

431 ( IsSpecialContext context ~ 'False

430 ( IsSpecialContext context ~ 'False

432− , x ~ context ('Spec (label ': labels) necessity db a)

431+ , x ~ context a

433 ) => K1Table _label 'False context 'True (Shape1 'Column ('Spec (label ': labels) necessity db a)) x

432 ) => K1Table _label 'False context 'True (Shape1 'Column ('Spec (label ': labels) necessity db a)) x

434 where

433 where

435− fromK1Columns = unHIdentity

434+ fromK1Columns (HIdentity (Col a)) = a

436− toK1Columns = HIdentity

435+ toK1Columns = HIdentity . Col

437 {-# INLINABLE fromK1Columns #-}

436 {-# INLINABLE fromK1Columns #-}

438 {-# INLINABLE toK1Columns #-}

437 {-# INLINABLE toK1Columns #-}

439

438

440

439

441instance

440instance

442 ( IsSpecialContext context ~ 'False

441 ( IsSpecialContext context ~ 'False

443− , x ~ context ('Spec '[] necessity db a)

442+ , x ~ context a

444 , Labelable context

443 , Labelable context

445 ) => K1Table label 'False context 'True (Shape1 'Column ('Spec '[] necessity db a)) x

444 ) => K1Table label 'False context 'True (Shape1 'Column ('Spec '[] necessity db a)) x

446 where

445 where

447− fromK1Columns = unlabeler . unHIdentity

446+ fromK1Columns = (\(Col a) -> a) . unlabeler . unHIdentity

448− toK1Columns = HIdentity . labeler

447+ toK1Columns = HIdentity . labeler . Col

449 {-# INLINABLE fromK1Columns #-}

448 {-# INLINABLE fromK1Columns #-}

450 {-# INLINABLE toK1Columns #-}

449 {-# INLINABLE toK1Columns #-}

451

450

@@ -453,10 +452,10 @@ instance

453instance

452instance

454 ( HTable (K1Columns "Left" structure1)

453 ( HTable (K1Columns "Left" structure1)

455 , HTable (K1Columns "Right" structure2)

454 , HTable (K1Columns "Right" structure2)

456− , K1Table "Left" 'True Aggregation (IsStructure structure1) structure1 a

455+ , K1Table "Left" 'True Aggregate (IsStructure structure1) structure1 a

457− , K1Table "Right" 'True Aggregation (IsStructure structure2) structure2 b

456+ , K1Table "Right" 'True Aggregate (IsStructure structure2) structure2 b

458 , e ~ EitherTable a b

457 , e ~ EitherTable a b

459− ) => K1Table label 'True Aggregation 'True (Shape2 'Either structure1 structure2) e

458+ ) => K1Table label 'True Aggregate 'True (Shape2 'Either structure1 structure2) e

460 where

459 where

461 fromK1Columns =

460 fromK1Columns =

462 fromColumns2

461 fromColumns2

@@ -475,10 +474,10 @@ instance

475instance

474instance

476 ( HTable (K1Columns "Left" structure1)

475 ( HTable (K1Columns "Left" structure1)

477 , HTable (K1Columns "Right" structure2)

476 , HTable (K1Columns "Right" structure2)

478− , K1Table "Left" 'True DB (IsStructure structure1) structure1 a

477+ , K1Table "Left" 'True Expr (IsStructure structure1) structure1 a

479− , K1Table "Right" 'True DB (IsStructure structure2) structure2 b

478+ , K1Table "Right" 'True Expr (IsStructure structure2) structure2 b

480 , e ~ EitherTable a b

479 , e ~ EitherTable a b

481− ) => K1Table label 'True DB 'True (Shape2 'Either structure1 structure2) e

480+ ) => K1Table label 'True Expr 'True (Shape2 'Either structure1 structure2) e

482 where

481 where

483 fromK1Columns =

482 fromK1Columns =

484 fromColumns2

483 fromColumns2

@@ -519,10 +518,10 @@ instance

519instance

518instance

520 ( HTable (K1Columns "Left" structure1)

519 ( HTable (K1Columns "Left" structure1)

521 , HTable (K1Columns "Right" structure2)

520 , HTable (K1Columns "Right" structure2)

522− , K1Table "Left" 'True Result (IsStructure structure1) structure1 a

521+ , K1Table "Left" 'True Identity (IsStructure structure1) structure1 a

523− , K1Table "Right" 'True Result (IsStructure structure2) structure2 b

522+ , K1Table "Right" 'True Identity (IsStructure structure2) structure2 b

524 , e ~ Either a b

523 , e ~ Either a b

525− ) => K1Table label 'True Result 'True (Shape2 'Either structure1 structure2) e

524+ ) => K1Table label 'True Identity 'True (Shape2 'Either structure1 structure2) e

526 where

525 where

527 fromK1Columns

526 fromK1Columns

528 = bimap

527 = bimap

@@ -566,27 +565,27 @@ instance

566

565

567

566

568instance

567instance

569− ( K1Table label 'True Aggregation (IsStructure structure) structure a

568+ ( K1Table label 'True Aggregate (IsStructure structure) structure a

570− , Table Aggregation a

569+ , Table Aggregate a

571 , K1Columns label structure ~ HLabel label (Columns a)

570 , K1Columns label structure ~ HLabel label (Columns a)

572 , as ~ ListTable a

571 , as ~ ListTable a

573− ) => K1Table label 'True Aggregation 'True (Shape1 'List structure) as

572+ ) => K1Table label 'True Aggregate 'True (Shape1 'List structure) as

574 where

573 where

575− fromK1Columns = fromColumns . hrelabel (hunlabel unlabeler)

574+ fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)

576− toK1Columns = hrelabel (hlabel labeler) . toColumns

575+ toK1Columns = hrelabel (hlabel hlabeler) . toColumns

577 {-# INLINABLE fromK1Columns #-}

576 {-# INLINABLE fromK1Columns #-}

578 {-# INLINABLE toK1Columns #-}

577 {-# INLINABLE toK1Columns #-}

579

578

580

579

581instance

580instance

582− ( K1Table label 'True DB (IsStructure structure) structure a

581+ ( K1Table label 'True Expr (IsStructure structure) structure a

583− , Table DB a

582+ , Table Expr a

584 , K1Columns label structure ~ HLabel label (Columns a)

583 , K1Columns label structure ~ HLabel label (Columns a)

585 , as ~ ListTable a

584 , as ~ ListTable a

586− ) => K1Table label 'True DB 'True (Shape1 'List structure) as

585+ ) => K1Table label 'True Expr 'True (Shape1 'List structure) as

587 where

586 where

588− fromK1Columns = fromColumns . hrelabel (hunlabel unlabeler)

587+ fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)

589− toK1Columns = hrelabel (hlabel labeler) . toColumns

588+ toK1Columns = hrelabel (hlabel hlabeler) . toColumns

590 {-# INLINABLE fromK1Columns #-}

589 {-# INLINABLE fromK1Columns #-}

591 {-# INLINABLE toK1Columns #-}

590 {-# INLINABLE toK1Columns #-}

592

591

@@ -598,20 +597,20 @@ instance

598 , as ~ ListTable a

597 , as ~ ListTable a

599 ) => K1Table label 'True Insertion 'True (Shape1 'List structure) as

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

600 where

599 where

601− fromK1Columns = fromColumns . hrelabel (hunlabel unlabeler)

600+ fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)

602− toK1Columns = hrelabel (hlabel labeler) . toColumns

601+ toK1Columns = hrelabel (hlabel hlabeler) . toColumns

603 {-# INLINABLE fromK1Columns #-}

602 {-# INLINABLE fromK1Columns #-}

604 {-# INLINABLE toK1Columns #-}

603 {-# INLINABLE toK1Columns #-}

605

604

606

605

607instance

606instance

608− ( K1Table label 'True Result (IsStructure structure) structure a

607+ ( K1Table label 'True Identity (IsStructure structure) structure a

609 , HTable (K1Columns label structure)

608 , HTable (K1Columns label structure)

610 , as ~ [a]

609 , as ~ [a]

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

610+ ) => K1Table label 'True Identity 'True (Shape1 'List structure) as

612 where

611 where

613− fromK1Columns = fmap (fromK1Columns @label @'True @Result @_ @structure) . fromHListTable

612+ fromK1Columns = fmap (fromK1Columns @label @'True @Identity @_ @structure) . fromHListTable

614− toK1Columns = toHListTable . fmap (toK1Columns @label @'True @Result @_ @structure)

613+ toK1Columns = toHListTable . fmap (toK1Columns @label @'True @Identity @_ @structure)

615 {-# INLINABLE fromK1Columns #-}

614 {-# INLINABLE fromK1Columns #-}

616 {-# INLINABLE toK1Columns #-}

615 {-# INLINABLE toK1Columns #-}

617

616

@@ -625,23 +624,23 @@ instance

625 , as ~ ListTable a

624 , as ~ ListTable a

626 ) => K1Table label 'False context 'True (Shape1 'List structure) as

625 ) => K1Table label 'False context 'True (Shape1 'List structure) as

627 where

626 where

628− fromK1Columns = fromColumns . hrelabel (hunlabel unlabeler)

627+ fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)

629− toK1Columns = hrelabel (hlabel labeler) . toColumns

628+ toK1Columns = hrelabel (hlabel hlabeler) . toColumns

630 {-# INLINABLE fromK1Columns #-}

629 {-# INLINABLE fromK1Columns #-}

631 {-# INLINABLE toK1Columns #-}

630 {-# INLINABLE toK1Columns #-}

632

631

633

632

634instance

633instance

635 ( HTable (K1Columns "Just" structure)

634 ( HTable (K1Columns "Just" structure)

636− , K1Table "Just" 'True Aggregation (IsStructure structure) structure a

635+ , K1Table "Just" 'True Aggregate (IsStructure structure) structure a

637 , ma ~ MaybeTable a

636 , ma ~ MaybeTable a

638− ) => K1Table label 'True Aggregation 'True (Shape1 'Maybe structure) ma

637+ ) => K1Table label 'True Aggregate 'True (Shape1 'Maybe structure) ma

639 where

638 where

640 fromK1Columns =

639 fromK1Columns =

641 fromColumns1 (fromK1Columns @"Just" @_ @_ @_ @structure) .

640 fromColumns1 (fromK1Columns @"Just" @_ @_ @_ @structure) .

642− hunlabel unlabeler

641+ hunlabel hunlabeler

643 toK1Columns =

642 toK1Columns =

644− hlabel labeler .

643+ hlabel hlabeler .

645 toColumns1 (toK1Columns @"Just" @_ @_ @_ @structure)

644 toColumns1 (toK1Columns @"Just" @_ @_ @_ @structure)

646 {-# INLINABLE fromK1Columns #-}

645 {-# INLINABLE fromK1Columns #-}

647 {-# INLINABLE toK1Columns #-}

646 {-# INLINABLE toK1Columns #-}

@@ -649,15 +648,15 @@ instance

649

648

650instance

649instance

651 ( HTable (K1Columns "Just" structure)

650 ( HTable (K1Columns "Just" structure)

652− , K1Table "Just" 'True DB (IsStructure structure) structure a

651+ , K1Table "Just" 'True Expr (IsStructure structure) structure a

653 , ma ~ MaybeTable a

652 , ma ~ MaybeTable a

654− ) => K1Table label 'True DB 'True (Shape1 'Maybe structure) ma

653+ ) => K1Table label 'True Expr 'True (Shape1 'Maybe structure) ma

655 where

654 where

656 fromK1Columns =

655 fromK1Columns =

657 fromColumns1 (fromK1Columns @"Just" @_ @_ @_ @structure) .

656 fromColumns1 (fromK1Columns @"Just" @_ @_ @_ @structure) .

658− hunlabel unlabeler

657+ hunlabel hunlabeler

659 toK1Columns =

658 toK1Columns =

660− hlabel labeler .

659+ hlabel hlabeler .

661 toColumns1 (toK1Columns @"Just" @_ @_ @_ @structure)

660 toColumns1 (toK1Columns @"Just" @_ @_ @_ @structure)

662 {-# INLINABLE fromK1Columns #-}

661 {-# INLINABLE fromK1Columns #-}

663 {-# INLINABLE toK1Columns #-}

662 {-# INLINABLE toK1Columns #-}

@@ -671,9 +670,9 @@ instance

671 where

670 where

672 fromK1Columns =

671 fromK1Columns =

673 fromColumns1 (fromK1Columns @"Just" @_ @_ @_ @structure) .

672 fromColumns1 (fromK1Columns @"Just" @_ @_ @_ @structure) .

674− hunlabel unlabeler

673+ hunlabel hunlabeler

675 toK1Columns =

674 toK1Columns =

676− hlabel labeler .

675+ hlabel hlabeler .

677 toColumns1 (toK1Columns @"Just" @_ @_ @_ @structure)

676 toColumns1 (toK1Columns @"Just" @_ @_ @_ @structure)

678 {-# INLINABLE fromK1Columns #-}

677 {-# INLINABLE fromK1Columns #-}

679 {-# INLINABLE toK1Columns #-}

678 {-# INLINABLE toK1Columns #-}

@@ -681,9 +680,9 @@ instance

681

680

682instance

681instance

683 ( HTable (K1Columns "Just" structure)

682 ( HTable (K1Columns "Just" structure)

684− , K1Table "Just" 'True Result (IsStructure structure) structure a

683+ , K1Table "Just" 'True Identity (IsStructure structure) structure a

685 , ma ~ Maybe a

684 , ma ~ Maybe a

686− ) => K1Table label 'True Result 'True (Shape1 'Maybe structure) ma

685+ ) => K1Table label 'True Identity 'True (Shape1 'Maybe structure) ma

687 where

686 where

688 fromK1Columns

687 fromK1Columns

689 = fmap (fromK1Columns @"Just" @_ @_ @_ @structure)

688 = fmap (fromK1Columns @"Just" @_ @_ @_ @structure)

@@ -717,27 +716,27 @@ instance

717

716

718

717

719instance

718instance

720− ( K1Table label 'True Aggregation (IsStructure structure) structure a

719+ ( K1Table label 'True Aggregate (IsStructure structure) structure a

721− , Table Aggregation a

720+ , Table Aggregate a

722 , K1Columns label structure ~ HLabel label (Columns a)

721 , K1Columns label structure ~ HLabel label (Columns a)

723 , as ~ NonEmptyTable a

722 , as ~ NonEmptyTable a

724− ) => K1Table label 'True Aggregation 'True (Shape1 'NonEmpty structure) as

723+ ) => K1Table label 'True Aggregate 'True (Shape1 'NonEmpty structure) as

725 where

724 where

726− fromK1Columns = fromColumns . hrelabel (hunlabel unlabeler)

725+ fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)

727− toK1Columns = hrelabel (hlabel labeler) . toColumns

726+ toK1Columns = hrelabel (hlabel hlabeler) . toColumns

728 {-# INLINABLE fromK1Columns #-}

727 {-# INLINABLE fromK1Columns #-}

729 {-# INLINABLE toK1Columns #-}

728 {-# INLINABLE toK1Columns #-}

730

729

731

730

732instance

731instance

733− ( K1Table label 'True DB (IsStructure structure) structure a

732+ ( K1Table label 'True Expr (IsStructure structure) structure a

734− , Table DB a

733+ , Table Expr a

735 , K1Columns label structure ~ HLabel label (Columns a)

734 , K1Columns label structure ~ HLabel label (Columns a)

736 , as ~ NonEmptyTable a

735 , as ~ NonEmptyTable a

737− ) => K1Table label 'True DB 'True (Shape1 'NonEmpty structure) as

736+ ) => K1Table label 'True Expr 'True (Shape1 'NonEmpty structure) as

738 where

737 where

739− fromK1Columns = fromColumns . hrelabel (hunlabel unlabeler)

738+ fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)

740− toK1Columns = hrelabel (hlabel labeler) . toColumns

739+ toK1Columns = hrelabel (hlabel hlabeler) . toColumns

741 {-# INLINABLE fromK1Columns #-}

740 {-# INLINABLE fromK1Columns #-}

742 {-# INLINABLE toK1Columns #-}

741 {-# INLINABLE toK1Columns #-}

743

742

@@ -749,20 +748,20 @@ instance

749 , as ~ NonEmptyTable a

748 , as ~ NonEmptyTable a

750 ) => K1Table label 'True Insertion 'True (Shape1 'NonEmpty structure) as

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

751 where

750 where

752− fromK1Columns = fromColumns . hrelabel (hunlabel unlabeler)

751+ fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)

753− toK1Columns = hrelabel (hlabel labeler) . toColumns

752+ toK1Columns = hrelabel (hlabel hlabeler) . toColumns

754 {-# INLINABLE fromK1Columns #-}

753 {-# INLINABLE fromK1Columns #-}

755 {-# INLINABLE toK1Columns #-}

754 {-# INLINABLE toK1Columns #-}

756

755

757

756

758instance

757instance

759− ( K1Table label 'True Result (IsStructure structure) structure a

758+ ( K1Table label 'True Identity (IsStructure structure) structure a

760 , HTable (K1Columns label structure)

759 , HTable (K1Columns label structure)

761 , as ~ NonEmpty a

760 , as ~ NonEmpty a

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

761+ ) => K1Table label 'True Identity 'True (Shape1 'NonEmpty structure) as

763 where

762 where

764− fromK1Columns = fmap (fromK1Columns @label @'True @Result @_ @structure) . fromHNonEmptyTable

763+ fromK1Columns = fmap (fromK1Columns @label @'True @Identity @_ @structure) . fromHNonEmptyTable

765− toK1Columns = toHNonEmptyTable . fmap (toK1Columns @label @'True @Result @_ @structure)

764+ toK1Columns = toHNonEmptyTable . fmap (toK1Columns @label @'True @Identity @_ @structure)

766 {-# INLINABLE fromK1Columns #-}

765 {-# INLINABLE fromK1Columns #-}

767 {-# INLINABLE toK1Columns #-}

766 {-# INLINABLE toK1Columns #-}

768

767

@@ -776,8 +775,8 @@ instance

776 , as ~ NonEmptyTable a

775 , as ~ NonEmptyTable a

777 ) => K1Table label 'False context 'True (Shape1 'NonEmpty structure) as

776 ) => K1Table label 'False context 'True (Shape1 'NonEmpty structure) as

778 where

777 where

779− fromK1Columns = fromColumns . hrelabel (hunlabel unlabeler)

778+ fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)

780− toK1Columns = hrelabel (hlabel labeler) . toColumns

779+ toK1Columns = hrelabel (hlabel hlabeler) . toColumns

781 {-# INLINABLE fromK1Columns #-}

780 {-# INLINABLE fromK1Columns #-}

782 {-# INLINABLE toK1Columns #-}

781 {-# INLINABLE toK1Columns #-}

783

782

@@ -785,10 +784,10 @@ instance

785instance

784instance

786 ( HTable (K1Columns "Here" structure1)

785 ( HTable (K1Columns "Here" structure1)

787 , HTable (K1Columns "There" structure2)

786 , HTable (K1Columns "There" structure2)

788− , K1Table "Here" 'True Aggregation (IsStructure structure1) structure1 a

787+ , K1Table "Here" 'True Aggregate (IsStructure structure1) structure1 a

789− , K1Table "There" 'True Aggregation (IsStructure structure2) structure2 b

788+ , K1Table "There" 'True Aggregate (IsStructure structure2) structure2 b

790 , e ~ TheseTable a b

789 , e ~ TheseTable a b

791− ) => K1Table label 'True Aggregation 'True (Shape2 'These structure1 structure2) e

790+ ) => K1Table label 'True Aggregate 'True (Shape2 'These structure1 structure2) e

792 where

791 where

793 fromK1Columns =

792 fromK1Columns =

794 fromColumns2

793 fromColumns2

@@ -807,10 +806,10 @@ instance

807instance

806instance

808 ( HTable (K1Columns "Here" structure1)

807 ( HTable (K1Columns "Here" structure1)

809 , HTable (K1Columns "There" structure2)

808 , HTable (K1Columns "There" structure2)

810− , K1Table "Here" 'True DB (IsStructure structure1) structure1 a

809+ , K1Table "Here" 'True Expr (IsStructure structure1) structure1 a

811− , K1Table "There" 'True DB (IsStructure structure2) structure2 b

810+ , K1Table "There" 'True Expr (IsStructure structure2) structure2 b

812 , e ~ TheseTable a b

811 , e ~ TheseTable a b

813− ) => K1Table label 'True DB 'True (Shape2 'These structure1 structure2) e

812+ ) => K1Table label 'True Expr 'True (Shape2 'These structure1 structure2) e

814 where

813 where

815 fromK1Columns =

814 fromK1Columns =

816 fromColumns2

815 fromColumns2

@@ -851,10 +850,10 @@ instance

851instance

850instance

852 ( HTable (K1Columns "Here" structure1)

851 ( HTable (K1Columns "Here" structure1)

853 , HTable (K1Columns "There" structure2)

852 , HTable (K1Columns "There" structure2)

854− , K1Table "Here" 'True Result (IsStructure structure1) structure1 a

853+ , K1Table "Here" 'True Identity (IsStructure structure1) structure1 a

855− , K1Table "There" 'True Result (IsStructure structure2) structure2 b

854+ , K1Table "There" 'True Identity (IsStructure structure2) structure2 b

856 , e ~ These a b

855 , e ~ These a b

857− ) => K1Table label 'True Result 'True (Shape2 'These structure1 structure2) e

856+ ) => K1Table label 'True Identity 'True (Shape2 'These structure1 structure2) e

858 where

857 where

859 fromK1Columns

858 fromK1Columns

860 = bimap

859 = bimap

src/Rel8/Schema/HTable.hs+41−42

@@ -36,71 +36,71 @@ import Prelude

37-- rel8

38import Rel8.Schema.Dict ( Dict )

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

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

40−import Rel8.Schema.HTable.Context ( HKTable, H )

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

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

41+import qualified Rel8.Schema.Kind as K

43-- semigroupoids

44import Data.Functor.Apply ( Apply, (<.>) )

47−type HTable :: HKTable -> Constraint

47+type HTable :: K.HTable -> Constraint

48class HTable t where

49− type HField t = (field :: Context) | field -> t

49+ type HField t = (field :: Spec -> Type) | field -> t

50 type HConstrainTable t (c :: Spec -> Constraint) :: Constraint

52− hfield :: t (H context) -> HField t spec -> context spec

52+ hfield :: t context -> HField t spec -> context spec

53− htabulate :: (forall spec. HField t spec -> context spec) -> t (H context)

53+ htabulate :: (forall spec. HField t spec -> context spec) -> t context

54− htraverse :: Apply m => (forall spec. f spec -> m (g spec)) -> t (H f) -> m (t (H g))

54+ htraverse :: Apply m => (forall spec. f spec -> m (g spec)) -> t f -> m (t g)

55− hdicts :: HConstrainTable t c => t (H (Dict c))

55+ hdicts :: HConstrainTable t c => t (Dict c)

56− hspecs :: t (H SSpec)

56+ hspecs :: t SSpec

58 type HField t = GHField t

59− type HConstrainTable t c = HConstrainTable (GHColumns (Rep (t (H Proxy)))) c

59+ type HConstrainTable t c = HConstrainTable (GHColumns (Rep (t Proxy))) c

61 default hfield ::

62− ( Generic (t (H context))

62+ ( Generic (t context)

63 , HField t ~ GHField t

64− , HField (GHColumns (Rep (t (H Proxy)))) ~ HField (GHColumns (Rep (t (H context))))

64+ , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))

65− , GHTable context (Rep (t (H context)))

65+ , GHTable context (Rep (t context))

66 )

67− => t (H context) -> HField t spec -> context spec

67+ => t context -> HField t spec -> context spec

68 hfield table (GHField field) = hfield (toGHColumns (from table)) field

70 default htabulate ::

71− ( Generic (t (H context))

71+ ( Generic (t context)

72 , HField t ~ GHField t

73− , HField (GHColumns (Rep (t (H Proxy)))) ~ HField (GHColumns (Rep (t (H context))))

73+ , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))

74− , GHTable context (Rep (t (H context)))

74+ , GHTable context (Rep (t context))

75 )

76− => (forall spec. HField t spec -> context spec) -> t (H context)

76+ => (forall spec. HField t spec -> context spec) -> t context

77 htabulate f = to $ fromGHColumns $ htabulate (f . GHField)

79 default htraverse

80 :: forall f g m

81 . ( Apply m

82− , Generic (t (H f)), GHTable f (Rep (t (H f)))

82+ , Generic (t f), GHTable f (Rep (t f))

83− , Generic (t (H g)), GHTable g (Rep (t (H g)))

83+ , Generic (t g), GHTable g (Rep (t g))

84− , GHColumns (Rep (t (H f))) ~ GHColumns (Rep (t (H g)))

84+ , GHColumns (Rep (t f)) ~ GHColumns (Rep (t g))

85 )

86− => (forall spec. f spec -> m (g spec)) -> t (H f) -> m (t (H g))

86+ => (forall spec. f spec -> m (g spec)) -> t f -> m (t g)

87 htraverse f = fmap (to . fromGHColumns) . htraverse f . toGHColumns . from

89 default hdicts

90 :: forall c

91− . ( Generic (t (H (Dict c)))

91+ . ( Generic (t (Dict c))

92− , GHTable (Dict c) (Rep (t (H (Dict c))))

92+ , GHTable (Dict c) (Rep (t (Dict c)))

93− , GHColumns (Rep (t (H Proxy))) ~ GHColumns (Rep (t (H (Dict c))))

93+ , GHColumns (Rep (t Proxy)) ~ GHColumns (Rep (t (Dict c)))

94− , HConstrainTable (GHColumns (Rep (t (H Proxy)))) c

94+ , HConstrainTable (GHColumns (Rep (t Proxy))) c

95 )

96− => t (H (Dict c))

96+ => t (Dict c)

97− hdicts = to $ fromGHColumns (hdicts @(GHColumns (Rep (t (H Proxy)))) @c)

97+ hdicts = to $ fromGHColumns (hdicts @(GHColumns (Rep (t Proxy))) @c)

99 default hspecs ::

100− ( Generic (t (H SSpec))

100+ ( Generic (t SSpec)

101− , GHTable SSpec (Rep (t (H SSpec)))

101+ , GHTable SSpec (Rep (t SSpec))

102 )

103− => t (H SSpec)

103+ => t SSpec

104 hspecs = to $ fromGHColumns hspecs

105

106 {-# INLINABLE hfield #-}

@@ -111,21 +111,20 @@ class HTable t where

111

112

113htabulateA :: (HTable t, Apply m)

114− => (forall spec. HField t spec -> m (context spec))

114+ => (forall spec. HField t spec -> m (context spec)) -> m (t context)

115− -> m (t (H context))

116htabulateA f = htraverse getCompose $ htabulate $ Compose . f

115htabulateA f = htraverse getCompose $ htabulate $ Compose . f

117{-# INLINABLE htabulateA #-}

116{-# INLINABLE htabulateA #-}

118

117

119

118

120−type GHField :: HKTable -> Context

119+type GHField :: K.HTable -> Spec -> Type

121−newtype GHField t spec = GHField (HField (GHColumns (Rep (t (H Proxy)))) spec)

120+newtype GHField t spec = GHField (HField (GHColumns (Rep (t Proxy))) spec)

122

121

123

122

124−type GHTable :: Context -> (Type -> Type) -> Constraint

123+type GHTable :: K.HContext -> (Type -> Type) -> Constraint

125class HTable (GHColumns rep) => GHTable context rep | rep -> context where

124class HTable (GHColumns rep) => GHTable context rep | rep -> context where

126− type GHColumns rep :: HKTable

125+ type GHColumns rep :: K.HTable

127− toGHColumns :: rep x -> GHColumns rep (H context)

126+ toGHColumns :: rep x -> GHColumns rep context

128− fromGHColumns :: GHColumns rep (H context) -> rep x

127+ fromGHColumns :: GHColumns rep context -> rep x

129

128

130

129

131instance GHTable context rep => GHTable context (M1 i c rep) where

130instance GHTable context rep => GHTable context (M1 i c rep) where

@@ -134,8 +133,8 @@ instance GHTable context rep => GHTable context (M1 i c rep) where

134 fromGHColumns = M1 . fromGHColumns

133 fromGHColumns = M1 . fromGHColumns

135

134

136

135

137−instance HTable table => GHTable context (K1 i (table (H context))) where

136+instance HTable table => GHTable context (K1 i (table context)) where

138− type GHColumns (K1 i (table (H context))) = table

137+ type GHColumns (K1 i (table context)) = table

139 toGHColumns (K1 a) = a

138 toGHColumns (K1 a) = a

140 fromGHColumns = K1

139 fromGHColumns = K1

141

140

@@ -147,7 +146,7 @@ instance (GHTable context a, GHTable context b) => GHTable context (a :*: b) whe

147

146

148

147

149-- | A HField type for indexing into HPair.

148-- | A HField type for indexing into HPair.

150−type HPairField :: HKTable -> HKTable -> Context

149+type HPairField :: K.HTable -> K.HTable -> Spec -> Type

151data HPairField x y spec

150data HPairField x y spec

152 = HFst (HField x spec)

151 = HFst (HField x spec)

153 | HSnd (HField y spec)

152 | HSnd (HField y spec)

src/Rel8/Schema/HTable/Context.hsdeleted−26

@@ -1,26 +0,0 @@

1−{-# language DataKinds #-}

2−{-# language StandaloneKindSignatures #-}

3−

4−module Rel8.Schema.HTable.Context

5− ( HContext, H, HKTable

6− )

7−where

8−

9−-- base

10−import Data.Kind ( Type )

11−import Prelude ()

12−

13−-- rel8

14−import Rel8.Schema.Spec ( Context )

15−

16−

17−type HContext :: Type

18−newtype HContext = H Context

19−

20−

21−type H :: Context -> HContext

22−type H = 'H

23−

24−

25−type HKTable :: Type

26−type HKTable = HContext -> Type

src/Rel8/Schema/HTable/Either.hs+2−2

@@ -16,14 +16,14 @@ import Prelude ()

16-- rel8

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

18import Rel8.Schema.HTable ( HTable )

19−import Rel8.Schema.HTable.Context ( HKTable )

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

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

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

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

21+import qualified Rel8.Schema.Kind as K

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

23import Rel8.Type.Tag ( EitherTag )

26−type HEitherTable :: HKTable -> HKTable -> HKTable

26+type HEitherTable :: K.HTable -> K.HTable -> K.HTable

27data HEitherTable left right context = HEitherTable

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

29 , hleft :: HNullify left context

src/Rel8/Schema/HTable/Identity.hs+8−8

@@ -9,6 +9,7 @@ module Rel8.Schema.HTable.Identity

9where

11-- base

12+import Data.Kind ( Type )

12import Prelude

13import Prelude

14-- rel8

15-- rel8

@@ -17,18 +18,17 @@ import Rel8.Schema.HTable

17 ( HTable, HConstrainTable, HField

18 ( HTable, HConstrainTable, HField

18 , hfield, htabulate, htraverse, hdicts, hspecs

19 , hfield, htabulate, htraverse, hdicts, hspecs

19 )

20 )

20−import Rel8.Schema.HTable.Context ( H, HKTable )

21+import qualified Rel8.Schema.Kind as K

21−import Rel8.Schema.Spec ( Context, Spec, KnownSpec, specSing )

22+import Rel8.Schema.Spec ( Spec, KnownSpec, specSing )

24−type HIdentity :: Spec -> HKTable

25+type HIdentity :: Spec -> K.HTable

25−data HIdentity spec context where

26+newtype HIdentity spec context = HIdentity

26− HIdentity ::

27− { unHIdentity :: context spec

27+ { unHIdentity :: context spec

28− } -> HIdentity spec (H context)

28+ }

31−type HIdentityField :: Spec -> Context

31+type HIdentityField :: Spec -> Spec -> Type

32data HIdentityField _spec spec where

33 HIdentityField :: HIdentityField spec spec

src/Rel8/Schema/HTable/Label.hs+10−10

@@ -33,16 +33,16 @@ import Rel8.Schema.HTable

33 ( HTable, HConstrainTable, HField

34 , hfield, htabulate, htraverse, hdicts, hspecs

35 )

36−import Rel8.Schema.HTable.Context ( H, HKTable )

36+import qualified Rel8.Schema.Kind as K

37−import Rel8.Schema.Spec ( Context, Spec( Spec ), SSpec(..) )

37+import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )

40−type HLabel :: Symbol -> HKTable -> HKTable

40+type HLabel :: Symbol -> K.HTable -> K.HTable

41data HLabel label table context where

42− HLabel :: table (H (LabelSpec label context)) -> HLabel label table (H context)

42+ HLabel :: table (LabelSpec label context) -> HLabel label table context

45−type HLabelField :: Symbol -> HKTable -> Context

45+type HLabelField :: Symbol -> K.HTable -> Spec -> Type

46data HLabelField label table spec where

47 HLabelField

48 :: HField table ('Spec labels necessity db a)

@@ -62,7 +62,7 @@ instance (HTable table, KnownSymbol label) => HTable (HLabel label table) where

62 htraverse f (HLabel t) = HLabel <$> htraverse (traverseLabelSpec f) t

64 hdicts :: forall c. HConstrainTable table (LabelSpecC label c)

65− => HLabel label table (H (Dict c))

65+ => HLabel label table (Dict c)

66 hdicts = HLabel $ htabulate $ \field -> case hfield hspecs field of

67 SSpec {} -> case hfield (hdicts @_ @(LabelSpecC label c)) field of

68 Dict -> LabelSpec Dict

@@ -111,8 +111,8 @@ hlabel :: HTable t

111 => (forall labels necessity db a. ()

112 => context ('Spec labels necessity db a)

113 -> context ('Spec (label ': labels) necessity db a))

114− -> t (H context)

114+ -> t context

115− -> HLabel label t (H context)

115+ -> HLabel label t context

116hlabel labeler a = HLabel $ htabulate $ \field ->

117 case hfield hspecs field of

118 SSpec {} -> LabelSpec (labeler (hfield a field))

@@ -123,8 +123,8 @@ hunlabel :: HTable t

123 => (forall labels necessity db a. ()

124 => context ('Spec (label ': labels) necessity db a)

125 -> context ('Spec labels necessity db a))

126− -> HLabel label t (H context)

126+ -> HLabel label t context

127− -> t (H context)

127+ -> t context

128hunlabel unlabler (HLabel as) =

129 htabulate $ \field -> case hfield as field of

130 LabelSpec a -> unlabler a

src/Rel8/Schema/HTable/List.hs+2−2

@@ -10,9 +10,9 @@ where

10import Prelude ()

12-- rel8

13−import Rel8.Schema.HTable.Context ( HKTable )

13+import qualified Rel8.Schema.Kind as K

14import Rel8.Schema.HTable.Vectorize ( HVectorize )

17−type HListTable :: HKTable -> HKTable

17+type HListTable :: K.HTable -> K.HTable

18type HListTable = HVectorize []

src/Rel8/Schema/HTable/Maybe.hs+2−2

@@ -16,14 +16,14 @@ import Prelude

16-- rel8

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

18import Rel8.Schema.HTable ( HTable )

19−import Rel8.Schema.HTable.Context ( HKTable )

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

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

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

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

21+import qualified Rel8.Schema.Kind as K

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

23import Rel8.Type.Tag ( MaybeTag )

26−type HMaybeTable :: HKTable -> HKTable

26+type HMaybeTable :: K.HTable -> K.HTable

27data HMaybeTable table context = HMaybeTable

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

29 , hjust :: HNullify table context

src/Rel8/Schema/HTable/NonEmpty.hs+2−2

@@ -11,9 +11,9 @@ import Data.List.NonEmpty ( NonEmpty )

11import Prelude ()

13-- rel8

14−import Rel8.Schema.HTable.Context ( HKTable )

15import Rel8.Schema.HTable.Vectorize ( HVectorize )

14import Rel8.Schema.HTable.Vectorize ( HVectorize )

15+import qualified Rel8.Schema.Kind as K

18−type HNonEmptyTable :: HKTable -> HKTable

18+type HNonEmptyTable :: K.HTable -> K.HTable

19type HNonEmptyTable = HVectorize NonEmpty

src/Rel8/Schema/HTable/Nullify.hs+11−12

@@ -29,20 +29,19 @@ import Rel8.Schema.HTable

29 ( HTable, HConstrainTable, HField

30 , hfield, htabulate, htabulateA, htraverse, hdicts, hspecs

31 )

32−import Rel8.Schema.HTable.Context ( H, HKTable )

32+import qualified Rel8.Schema.Kind as K

33import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ) )

34−import Rel8.Schema.Spec ( Context, Spec( Spec ), SSpec(..) )

34+import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )

36-- semigroupoids

37import Data.Functor.Apply ( Apply )

40−type HNullify :: HKTable -> HKTable

40+type HNullify :: K.HTable -> K.HTable

41−data HNullify table context where

42− HNullify :: table (H (NullifySpec context)) -> HNullify table (H context)

41+newtype HNullify table context = HNullify (table (NullifySpec context))

45−type HNullifyField :: HKTable -> Context

44+type HNullifyField :: K.HTable -> Spec -> Type

46data HNullifyField table spec where

45data HNullifyField table spec where

47 HNullifyField

46 HNullifyField

48 :: HField table ('Spec labels necessity dbType a)

47 :: HField table ('Spec labels necessity dbType a)

@@ -63,7 +62,7 @@ instance HTable table => HTable (HNullify table) where

63 htraverse f (HNullify t) = HNullify <$> htraverse (traverseNullifySpec f) t

62 htraverse f (HNullify t) = HNullify <$> htraverse (traverseNullifySpec f) t

65 hdicts :: forall c. HConstrainTable table (NullifySpecC c)

64 hdicts :: forall c. HConstrainTable table (NullifySpecC c)

66− => HNullify table (H (Dict c))

65+ => HNullify table (Dict c)

67 hdicts = HNullify $ htabulate $ \field -> case hfield hspecs field of

66 hdicts = HNullify $ htabulate $ \field -> case hfield hspecs field of

68 SSpec {} -> case hfield (hdicts @_ @(NullifySpecC c)) field of

67 SSpec {} -> case hfield (hdicts @_ @(NullifySpecC c)) field of

69 Dict -> NullifySpec Dict

68 Dict -> NullifySpec Dict

@@ -113,7 +112,7 @@ traverseNullifySpec f (NullifySpec a) = NullifySpec <$> f a

113hnulls :: HTable t

112hnulls :: HTable t

114 => (forall labels necessity dbType. ()

113 => (forall labels necessity dbType. ()

115 => context ('Spec labels necessity dbType (Maybe dbType)))

114 => context ('Spec labels necessity dbType (Maybe dbType)))

116− -> HNullify t (H context)

115+ -> HNullify t context

117hnulls null = HNullify $ htabulate $ \field -> case hfield hspecs field of

116hnulls null = HNullify $ htabulate $ \field -> case hfield hspecs field of

118 SSpec {} -> NullifySpec null

117 SSpec {} -> NullifySpec null

119{-# INLINABLE hnulls #-}

118{-# INLINABLE hnulls #-}

@@ -124,8 +123,8 @@ hnullify :: HTable t

124 => SSpec ('Spec labels necessity dbType a)

123 => SSpec ('Spec labels necessity dbType a)

125 -> context ('Spec labels necessity dbType a)

124 -> context ('Spec labels necessity dbType a)

126 -> context ('Spec labels necessity dbType (Maybe dbType)))

125 -> context ('Spec labels necessity dbType (Maybe dbType)))

127− -> t (H context)

126+ -> t context

128− -> HNullify t (H context)

127+ -> HNullify t context

129hnullify nullifier a = HNullify $ htabulate $ \field ->

128hnullify nullifier a = HNullify $ htabulate $ \field ->

130 case hfield hspecs field of

129 case hfield hspecs field of

131 spec@SSpec {} -> NullifySpec (nullifier spec (hfield a field))

130 spec@SSpec {} -> NullifySpec (nullifier spec (hfield a field))

@@ -137,8 +136,8 @@ hunnullify :: (HTable t, Apply m)

137 => SSpec ('Spec labels necessity dbType a)

136 => SSpec ('Spec labels necessity dbType a)

138 -> context ('Spec labels necessity dbType (Maybe dbType))

137 -> context ('Spec labels necessity dbType (Maybe dbType))

139 -> m (context ('Spec labels necessity dbType a)))

138 -> m (context ('Spec labels necessity dbType a)))

140− -> HNullify t (H context)

139+ -> HNullify t context

141− -> m (t (H context))

140+ -> m (t context)

142hunnullify unnullifier (HNullify as) =

141hunnullify unnullifier (HNullify as) =

143 htabulateA $ \field -> case hfield hspecs field of

142 htabulateA $ \field -> case hfield hspecs field of

144 spec@SSpec {} -> case hfield as field of

143 spec@SSpec {} -> case hfield as field of

src/Rel8/Schema/HTable/Pair.hs+2−2

@@ -10,10 +10,10 @@ where

10import Prelude ()

12-- rel8

13−import Rel8.Schema.HTable.Context ( HKTable )

13+import qualified Rel8.Schema.Kind as K

16−type HPair :: HKTable -> HKTable -> HKTable

16+type HPair :: K.HTable -> K.HTable -> K.HTable

17data HPair fst snd context = HPair

18 { hfst :: fst context

19 , hsnd :: snd context

src/Rel8/Schema/HTable/Quartet.hs+2−2

@@ -15,10 +15,10 @@ import Prelude ()

16-- rel8

17import Rel8.Schema.HTable ( HTable )

18−import Rel8.Schema.HTable.Context ( HKTable )

18+import qualified Rel8.Schema.Kind as K

21−type HQuartet :: HKTable -> HKTable -> HKTable -> HKTable -> HKTable

21+type HQuartet :: K.HTable -> K.HTable -> K.HTable -> K.HTable -> K.HTable

22data HQuartet w x y z context = HQuartet

23 { hfst :: w context

24 , hsnd :: x context

src/Rel8/Schema/HTable/Quintet.hs+2−2

@@ -15,10 +15,10 @@ import Prelude ()

16-- rel8

17import Rel8.Schema.HTable ( HTable )

18−import Rel8.Schema.HTable.Context ( HKTable )

18+import qualified Rel8.Schema.Kind as K

21−type HQuintet :: HKTable -> HKTable -> HKTable -> HKTable -> HKTable -> HKTable

21+type HQuintet :: K.HTable -> K.HTable -> K.HTable -> K.HTable -> K.HTable -> K.HTable

22data HQuintet v w x y z context = HQuintet

23 { hfst :: v context

24 , hsnd :: w context

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

@@ -16,14 +16,14 @@ import Prelude

16-- rel8

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

18import Rel8.Schema.HTable ( HTable )

19−import Rel8.Schema.HTable.Context ( HKTable )

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

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

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

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

21+import qualified Rel8.Schema.Kind as K

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

23import Rel8.Type.Tag ( MaybeTag )

26−type HTheseTable :: HKTable -> HKTable -> HKTable

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

27data HTheseTable here there context = HTheseTable

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

29 , hhere :: HNullify here context

src/Rel8/Schema/HTable/Trio.hs+2−2

@@ -15,10 +15,10 @@ import Prelude ()

16-- rel8

17import Rel8.Schema.HTable ( HTable )

18−import Rel8.Schema.HTable.Context ( HKTable )

18+import qualified Rel8.Schema.Kind as K

21−type HTrio :: HKTable -> HKTable -> HKTable -> HKTable

21+type HTrio :: K.HTable -> K.HTable -> K.HTable -> K.HTable

22data HTrio x y z context = HTrio

23 { hfst :: x context

24 , hsnd :: y context

src/Rel8/Schema/HTable/Type.hs+7−8

@@ -22,20 +22,19 @@ import Rel8.Schema.HTable

22 ( HTable, HConstrainTable, HField

23 , hfield, htabulate, htraverse, hdicts, hspecs

24 )

25−import Rel8.Schema.HTable.Context ( H, HKTable )

25+import qualified Rel8.Schema.Kind as K

26import Rel8.Schema.Nullability ( Unnullify, Sql, nullabilization )

27−import Rel8.Schema.Spec ( Context, Spec( Spec ), SSpec(..) )

27+import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )

28import Rel8.Type ( DBType, typeInformation )

31−type HType :: Type -> HKTable

31+type HType :: Type -> K.HTable

32−data HType a context where

32+newtype HType a context = HType

33− HType ::

34− { unHType :: context ('Spec '[""] 'Required (Unnullify a) a)

33+ { unHType :: context ('Spec '[""] 'Required (Unnullify a) a)

35− } -> HType a (H context)

34+ }

38−type HTypeField :: Type -> Context

37+type HTypeField :: Type -> Spec -> Type

39data HTypeField a spec where

38data HTypeField a spec where

40 HTypeField :: HTypeField a ('Spec '[""] 'Required (Unnullify a) a)

39 HTypeField :: HTypeField a ('Spec '[""] 'Required (Unnullify a) a)

src/Rel8/Schema/HTable/Vectorize.hs+23−24

@@ -32,15 +32,15 @@ import Data.Type.Equality ( (:~:)( Refl ) )

32import Prelude

34-- rel8

35−import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )

35+import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler )

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

37+import qualified Rel8.Schema.Kind as K

37import Rel8.Schema.HTable

38import Rel8.Schema.HTable

38 ( HTable, HConstrainTable, HField

39 ( HTable, HConstrainTable, HField

39 , hfield, htabulate, htabulateA, htraverse, hdicts, hspecs

40 , hfield, htabulate, htabulateA, htraverse, hdicts, hspecs

40 )

41 )

41−import Rel8.Schema.HTable.Context ( H, HKTable )

42import Rel8.Schema.Nullability ( IsMaybe, Nullability( NonNullable ) )

43−import Rel8.Schema.Spec ( Context, Spec( Spec ), SSpec(..) )

43+import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )

44import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )

45import Rel8.Type.Information ( TypeInformation )

@@ -66,12 +66,12 @@ instance Vector NonEmpty where

66 vectorTypeInformation = nonEmptyTypeInformation

69−type HVectorize :: (Type -> Type) -> HKTable -> HKTable

69+type HVectorize :: (Type -> Type) -> K.HTable -> K.HTable

70−data HVectorize list table context where

70+newtype HVectorize list table context =

71− HVectorize :: table (H (VectorizeSpec list context)) -> HVectorize list table (H context)

71+ HVectorize (table (VectorizeSpec list context))

74−type HVectorizeField :: (Type -> Type) -> HKTable -> Context

74+type HVectorizeField :: (Type -> Type) -> K.HTable -> Spec -> Type

75data HVectorizeField list table spec where

76 HVectorizeField

77 :: HField table ('Spec labels necessity db a)

@@ -81,7 +81,6 @@ data HVectorizeField list table spec where

83instance (HTable table, Vector list) => HTable (HVectorize list table) where

84−

85 type HField (HVectorize list table) = HVectorizeField list table

84 type HField (HVectorize list table) = HVectorizeField list table

86 type HConstrainTable (HVectorize list table) c =

85 type HConstrainTable (HVectorize list table) c =

87 HConstrainTable table (VectorizeSpecC list c)

86 HConstrainTable table (VectorizeSpecC list c)

@@ -94,7 +93,7 @@ instance (HTable table, Vector list) => HTable (HVectorize list table) where

94 htraverse f (HVectorize t) = HVectorize <$> htraverse (traverseVectorizeSpec f) t

93 htraverse f (HVectorize t) = HVectorize <$> htraverse (traverseVectorizeSpec f) t

96 hdicts :: forall c. HConstrainTable table (VectorizeSpecC list c) =>

95 hdicts :: forall c. HConstrainTable table (VectorizeSpecC list c) =>

97− HVectorize list table (H (Dict c))

96+ HVectorize list table (Dict c)

98 hdicts = HVectorize $ htabulate $ \field -> case hfield hspecs field of

97 hdicts = HVectorize $ htabulate $ \field -> case hfield hspecs field of

99 SSpec {} -> case hfield (hdicts @_ @(VectorizeSpecC list c)) field of

98 SSpec {} -> case hfield (hdicts @_ @(VectorizeSpecC list c)) field of

100 Dict -> VectorizeSpec Dict

99 Dict -> VectorizeSpec Dict

@@ -125,9 +124,9 @@ data VectorizeSpec list context spec where

125 } -> VectorizeSpec list context ('Spec labels necessity db a)

124 } -> VectorizeSpec list context ('Spec labels necessity db a)

126

125

127

126

128−instance Labelable context => Labelable (VectorizeSpec list context) where

127+instance HLabelable context => HLabelable (VectorizeSpec list context) where

129− labeler (VectorizeSpec a) = VectorizeSpec (labeler a)

128+ hlabeler (VectorizeSpec a) = VectorizeSpec (hlabeler a)

130− unlabeler (VectorizeSpec a) = VectorizeSpec (unlabeler a)

129+ hunlabeler (VectorizeSpec a) = VectorizeSpec (hunlabeler a)

131

130

132

131

133type VectorizeSpecC :: VectorizingSpec Constraint

132type VectorizeSpecC :: VectorizingSpec Constraint

@@ -157,8 +156,8 @@ hvectorize :: (HTable t, Unzip f)

157 => SSpec ('Spec labels necessity db a)

156 => SSpec ('Spec labels necessity db a)

158 -> f (context ('Spec labels necessity db a))

157 -> f (context ('Spec labels necessity db a))

159 -> context' ('Spec labels necessity (list a) (list a)))

158 -> context' ('Spec labels necessity (list a) (list a)))

160− -> f (t (H context))

159+ -> f (t context)

161− -> HVectorize list t (H context')

160+ -> HVectorize list t context'

162hvectorize vectorizer as = HVectorize $ htabulate $ \field ->

161hvectorize vectorizer as = HVectorize $ htabulate $ \field ->

163 case hfield hspecs field of

162 case hfield hspecs field of

164 spec@SSpec {} -> VectorizeSpec (vectorizer spec (fmap (`hfield` field) as))

163 spec@SSpec {} -> VectorizeSpec (vectorizer spec (fmap (`hfield` field) as))

@@ -170,8 +169,8 @@ hunvectorize :: (HTable t, Repeat f)

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

169 => SSpec ('Spec labels necessity db a)

171 -> context ('Spec labels necessity (list a) (list a))

170 -> context ('Spec labels necessity (list a) (list a))

172 -> f (context' ('Spec labels necessity db a)))

171 -> f (context' ('Spec labels necessity db a)))

173− -> HVectorize list t (H context)

172+ -> HVectorize list t context

174− -> f (t (H context'))

173+ -> f (t context')

175hunvectorize unvectorizer (HVectorize table) =

174hunvectorize unvectorizer (HVectorize table) =

176 getZippy $ htabulateA $ \field -> case hfield hspecs field of

175 getZippy $ htabulateA $ \field -> case hfield hspecs field of

177 spec -> case hfield table field of

176 spec -> case hfield table field of

@@ -187,9 +186,9 @@ happend :: HTable t =>

187 -> context ('Spec labels necessity (list a) (list a))

186 -> context ('Spec labels necessity (list a) (list a))

188 -> context ('Spec labels necessity (list a) (list a))

187 -> context ('Spec labels necessity (list a) (list a))

189 )

188 )

190− -> HVectorize list t (H context)

189+ -> HVectorize list t context

191− -> HVectorize list t (H context)

190+ -> HVectorize list t context

192− -> HVectorize list t (H context)

191+ -> HVectorize list t context

193happend append (HVectorize as) (HVectorize bs) = HVectorize $

192happend append (HVectorize as) (HVectorize bs) = HVectorize $

194 htabulate $ \field -> case (hfield as field, hfield bs field) of

193 htabulate $ \field -> case (hfield as field, hfield bs field) of

195 (VectorizeSpec a, VectorizeSpec b) -> case hfield hspecs field of

194 (VectorizeSpec a, VectorizeSpec b) -> case hfield hspecs field of

@@ -202,13 +201,13 @@ hempty :: HTable t =>

202 -> TypeInformation db

201 -> TypeInformation db

203 -> context ('Spec labels necessity [a] [a])

202 -> context ('Spec labels necessity [a] [a])

204 )

203 )

205− -> HVectorize [] t (H context)

204+ -> HVectorize [] t context

206hempty empty = HVectorize $ htabulate $ \field -> case hfield hspecs field of

205hempty empty = HVectorize $ htabulate $ \field -> case hfield hspecs field of

207 SSpec {nullability, info} -> VectorizeSpec (empty nullability info)

206 SSpec {nullability, info} -> VectorizeSpec (empty nullability info)

208

207

209

208

210−hrelabel :: Labelable context

209+hrelabel :: HLabelable context

211− => (forall ctx. Labelable ctx => t (H ctx) -> u (H ctx))

210+ => (forall ctx. HLabelable ctx => t ctx -> u ctx)

212− -> HVectorize list t (H context)

211+ -> HVectorize list t context

213− -> HVectorize list u (H context)

212+ -> HVectorize list u context

214hrelabel f (HVectorize table) = HVectorize (f table)

213hrelabel f (HVectorize table) = HVectorize (f table)

src/Rel8/Schema/Kind.hsnew file+30

@@ -0,0 +1,30 @@

1+{-# language StandaloneKindSignatures #-}

3+module Rel8.Schema.Kind

4+ ( Context, Table

5+ , HContext, HTable

6+ )

7+where

9+-- base

10+import Data.Kind ( Type )

11+import Prelude ()

12+

13+-- rel8

14+import Rel8.Schema.Spec ( Spec )

15+

16+

17+type HContext :: Type

18+type HContext = Spec -> Type

19+

20+

21+type HTable :: Type

22+type HTable = HContext -> Type

23+

24+

25+type Context :: Type

26+type Context = Type -> Type

27+

28+

29+type Table :: Type

30+type Table = Context -> Type

src/Rel8/Schema/Spec.hs+9−4

@@ -8,7 +8,8 @@ module Rel8.Schema.Spec

8 ( Spec( Spec )

9 , SSpec( SSpec, labels, necessity, info, nullability )

10 , KnownSpec( specSing )

11+ , KContext, HKTable

11− , Context, KTable

12+ , KTable

12 )

13 )

13where

14where

@@ -64,9 +65,13 @@ instance

64 }

65 }

67−type Context :: Type

68+type KContext :: Type

68−type Context = Spec -> Type

69+type KContext = Spec -> Type

70+

71+

72+type HKTable :: Type

73+type HKTable = KContext -> Type

71type KTable :: Type

76type KTable :: Type

72−type KTable = Context -> Type

77+type KTable = (Type -> Type) -> Type

src/Rel8/Schema/Spec/ConstrainContext.hsdeleted−23

@@ -1,23 +0,0 @@

1−{-# language ConstraintKinds #-}

2−{-# language DataKinds #-}

3−{-# language FlexibleInstances #-}

4−{-# language MultiParamTypeClasses #-}

5−{-# language StandaloneKindSignatures #-}

6−{-# language UndecidableSuperClasses #-}

7−

8−module Rel8.Schema.Spec.ConstrainContext

9− ( ConstrainContext

10− )

11−where

12−

13−-- base

14−import Data.Kind ( Constraint, Type )

15−import Prelude ()

16−

17−-- rel8

18−import Rel8.Schema.Spec ( Context, Spec )

19−

20−

21−type ConstrainContext :: (Type -> Constraint) -> Context -> Spec -> Constraint

22−class constraint (context spec) => ConstrainContext constraint context spec

23−instance constraint (context spec) => ConstrainContext constraint context spec

src/Rel8/Schema/Structure.hs+4−3

@@ -17,11 +17,12 @@ import Data.Kind ( Type )

17import Prelude

19-- rel8

20+import qualified Rel8.Schema.Kind as K

20−import Rel8.Schema.Spec ( Context, Spec )

21+import Rel8.Schema.Spec ( Spec )

23−type Structure :: Context

24+type Structure :: K.Context

24−data Structure spec

25+data Structure a

27type Shape :: Type

28type Shape :: Type

src/Rel8/Table.hs+41−24

@@ -24,13 +24,10 @@ import Rel8.Aggregate ( Aggregate )

24import Rel8.Expr ( Expr )

25import Rel8.Opaque ( Opaque, Opaque1 )

26import Rel8.Schema.Context

27− ( Aggregation( Aggregation )

27+ ( Col, Col'(..), Insertion(..), Name, IsSpecialContext

28− , DB( DB ), unDB

29− , Result( Result )

30 )

28 )

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

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

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

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

33−import Rel8.Schema.HTable.Context ( H, HKTable )

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

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

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

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

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

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

@@ -38,42 +35,46 @@ import Rel8.Schema.HTable.Quartet ( HQuartet(..) )

38import Rel8.Schema.HTable.Quintet ( HQuintet(..) )

35import Rel8.Schema.HTable.Quintet ( HQuintet(..) )

39import Rel8.Schema.HTable.Trio ( HTrio(..) )

36import Rel8.Schema.HTable.Trio ( HTrio(..) )

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

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

38+import qualified Rel8.Schema.Kind as K

41import Rel8.Schema.Nullability ( Sql )

39import Rel8.Schema.Nullability ( Sql )

42import Rel8.Schema.Spec ( SSpec( SSpec ), KnownSpec )

40import Rel8.Schema.Spec ( SSpec( SSpec ), KnownSpec )

43−import qualified Rel8.Schema.Spec as Kind ( Context )

44import Rel8.Type ( DBType )

41import Rel8.Type ( DBType )

47−type Table :: Kind.Context -> Type -> Constraint

44+type Table :: K.Context -> Type -> Constraint

48class (HTable (Columns a), context ~ Context a) => Table context a | a -> context where

45class (HTable (Columns a), context ~ Context a) => Table context a | a -> context where

49− type Columns a :: HKTable

46+ type Columns a :: K.HTable

50− type Context a :: Kind.Context

47+ type Context a :: K.Context

52− toColumns :: a -> Columns a (H (Context a))

49+ toColumns :: a -> Columns a (Col (Context a))

53− fromColumns :: Columns a (H (Context a)) -> a

50+ fromColumns :: Columns a (Col (Context a)) -> a

56-- | Any 'HTable' is also a 'Table'.

53-- | Any 'HTable' is also a 'Table'.

54+instance (HTable t, x ~ IsSpecialContext context) =>

57−instance HTable t => Table context (t (H context)) where

55+ Table context (t (Col' x context))

56+ where

58− type Columns (t (H context)) = t

57+ type Columns (t (Col' x context)) = t

59− type Context (t (H context)) = context

58+ type Context (t (Col' x context)) = context

61 toColumns = id

60 toColumns = id

62 fromColumns = id

61 fromColumns = id

65-- | Any context is trivially a table.

64-- | Any context is trivially a table.

65+instance (KnownSpec spec, x ~ IsSpecialContext context) =>

66−instance KnownSpec spec => Table context (context spec) where

66+ Table context (Col' x context spec)

67+ where

67− type Columns (context spec) = HIdentity spec

68+ type Columns (Col' x context spec) = HIdentity spec

68− type Context (context spec) = context

69+ type Context (Col' x context spec) = context

70 toColumns = HIdentity

71 toColumns = HIdentity

71 fromColumns = unHIdentity

72 fromColumns = unHIdentity

74−instance Table DB a => Table Aggregation (Aggregate a) where

75+instance Table Expr a => Table Aggregate (Aggregate a) where

75 type Columns (Aggregate a) = Columns a

76 type Columns (Aggregate a) = Columns a

76− type Context (Aggregate a) = Aggregation

77+ type Context (Aggregate a) = Aggregate

78 toColumns a = htabulate $ \field -> case hfield hspecs field of

79 toColumns a = htabulate $ \field -> case hfield hspecs field of

79 SSpec {} -> Aggregation $ unDB . (`hfield` field) . toColumns <$> a

80 SSpec {} -> Aggregation $ unDB . (`hfield` field) . toColumns <$> a

@@ -82,22 +83,38 @@ instance Table DB a => Table Aggregation (Aggregate a) where

82 Aggregation a -> DB <$> a

83 Aggregation a -> DB <$> a

85−instance Sql DBType a => Table DB (Expr a) where

86+instance Sql DBType a => Table Expr (Expr a) where

86 type Columns (Expr a) = HType a

87 type Columns (Expr a) = HType a

87− type Context (Expr a) = DB

88+ type Context (Expr a) = Expr

89 toColumns a = HType (DB a)

90 toColumns a = HType (DB a)

90 fromColumns (HType (DB a)) = a

91 fromColumns (HType (DB a)) = a

93−instance Sql DBType a => Table Result (Identity a) where

94+instance Sql DBType a => Table Identity (Identity a) where

94 type Columns (Identity a) = HType a

95 type Columns (Identity a) = HType a

95− type Context (Identity a) = Result

96+ type Context (Identity a) = Identity

97 toColumns (Identity a) = HType (Result a)

98 toColumns (Identity a) = HType (Result a)

98 fromColumns (HType (Result a)) = Identity a

99 fromColumns (HType (Result a)) = Identity a

100

101

102+instance Sql DBType a => Table Insertion (Insertion a) where

103+ type Columns (Insertion a) = HType a

104+ type Context (Insertion a) = Insertion

105+

106+ toColumns (Insertion a) = HType (RequiredInsert a)

107+ fromColumns (HType (RequiredInsert a)) = Insertion a

108+

109+

110+instance Sql DBType a => Table Name (Name a) where

111+ type Columns (Name a) = HType a

112+ type Context (Name a) = Name

113+

114+ toColumns a = HType (Col a)

115+ fromColumns (HType (Col a)) = a

116+

117+

101instance

118instance

102 ( Table context a, Table context b

119 ( Table context a, Table context b

103 , Labelable context

120 , Labelable context

@@ -202,9 +219,9 @@ instance

202 )

219 )

203

220

204

221

205−instance Table DB Opaque where

222+instance Table Expr Opaque where

206 type Columns Opaque = HType Opaque

223 type Columns Opaque = HType Opaque

207− type Context Opaque = DB

224+ type Context Opaque = Expr

208

225

209 fromColumns = error "opaque"

226 fromColumns = error "opaque"

210 toColumns = error "opaque"

227 toColumns = error "opaque"

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

@@ -19,8 +19,9 @@ import Prelude

20-- rel8

21import Rel8.Aggregate ( Aggregate )

22+import Rel8.Expr ( Expr )

22import Rel8.Expr.Aggregate ( listAggExpr, nonEmptyAggExpr, sgroupByExpr )

23import Rel8.Expr.Aggregate ( listAggExpr, nonEmptyAggExpr, sgroupByExpr )

23−import Rel8.Schema.Context ( Aggregation( Aggregation ), DB( DB ) )

24+import Rel8.Schema.Context ( Col'(..) )

24import Rel8.Schema.Dict ( Dict( Dict ) )

25import Rel8.Schema.Dict ( Dict( Dict ) )

25import Rel8.Schema.HTable ( htabulate, hfield, hdicts, hspecs )

26import Rel8.Schema.HTable ( htabulate, hfield, hdicts, hspecs )

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

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

@@ -60,7 +61,7 @@ groupBy (toColumns -> exprs) = fromColumns $ htabulate $ \field ->

60-- items <- aggregate $ listAgg <$> itemsFromOrder order

61-- items <- aggregate $ listAgg <$> itemsFromOrder order

61-- return (order, items)

62-- return (order, items)

62-- @

63-- @

63−listAgg :: Table DB exprs => exprs -> Aggregate (ListTable exprs)

64+listAgg :: Table Expr exprs => exprs -> Aggregate (ListTable exprs)

64listAgg (toColumns -> exprs) = fromColumns $

65listAgg (toColumns -> exprs) = fromColumns $

65 hvectorize

66 hvectorize

66 (\_ (Identity (DB a)) -> Aggregation $ listAggExpr a)

67 (\_ (Identity (DB a)) -> Aggregation $ listAggExpr a)

@@ -68,7 +69,7 @@ listAgg (toColumns -> exprs) = fromColumns $

70-- | Like 'listAgg', but the result is guaranteed to be a non-empty list.

71-- | Like 'listAgg', but the result is guaranteed to be a non-empty list.

71−nonEmptyAgg :: Table DB exprs => exprs -> Aggregate (NonEmptyTable exprs)

72+nonEmptyAgg :: Table Expr exprs => exprs -> Aggregate (NonEmptyTable exprs)

72nonEmptyAgg (toColumns -> exprs) = fromColumns $

73nonEmptyAgg (toColumns -> exprs) = fromColumns $

73 hvectorize

74 hvectorize

74 (\_ (Identity (DB a)) -> Aggregation $ nonEmptyAggExpr a)

75 (\_ (Identity (DB a)) -> Aggregation $ nonEmptyAggExpr a)

src/Rel8/Table/Alternative.hs+3−3

@@ -13,16 +13,16 @@ import Data.Kind ( Constraint, Type )

13import Prelude ()

15-- rel8

16−import Rel8.Schema.Context ( DB )

16+import Rel8.Expr ( Expr )

17import Rel8.Table ( Table )

20type AltTable :: (Type -> Type) -> Constraint

21class AltTable f where

22− (<|>:) :: Table DB a => f a -> f a -> f a

22+ (<|>:) :: Table Expr a => f a -> f a -> f a

23 infixl 3 <|>:

26type AlternativeTable :: (Type -> Type) -> Constraint

27class AltTable f => AlternativeTable f where

28− emptyTable :: Table DB a => f a

28+ emptyTable :: Table Expr a => f a

src/Rel8/Table/Bool.hs+3−3

@@ -14,12 +14,12 @@ import Prelude

14-- rel8

15import Rel8.Expr ( Expr )

16import Rel8.Expr.Bool ( boolExpr, caseExpr )

17−import Rel8.Schema.Context ( DB( DB ), unDB )

17+import Rel8.Schema.Context ( Col'(..) )

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

19import Rel8.Table ( Table, fromColumns, toColumns )

22−bool :: Table DB a => a -> a -> Expr Bool -> a

22+bool :: Table Expr a => a -> a -> Expr Bool -> a

23bool (toColumns -> false) (toColumns -> true) condition =

24 fromColumns $ htabulate $ \field ->

25 case (hfield false field, hfield true field) of

@@ -27,7 +27,7 @@ bool (toColumns -> false) (toColumns -> true) condition =

27 DB (boolExpr falseExpr trueExpr condition)

30−case_ :: Table DB a => [(Expr Bool, a)] -> a -> a

30+case_ :: Table Expr a => [(Expr Bool, a)] -> a -> a

31case_ (map (fmap toColumns) -> branches) (toColumns -> fallback) =

32 fromColumns $ htabulate $ \field -> case hfield fallback field of

33 DB fallbackExpr ->

src/Rel8/Table/Either.hs+8−9

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

25-- rel8

26import Rel8.Expr ( Expr )

27import Rel8.Expr.Serialize ( litExpr )

28−import Rel8.Schema.Context ( DB )

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

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

30import Rel8.Schema.Context.Nullify

29import Rel8.Schema.Context.Nullify

31 ( Nullifiable, NullifiableEq

30 ( Nullifiable, NullifiableEq

@@ -64,27 +63,27 @@ instance Bifunctor EitherTable where

64 bimap f g (EitherTable tag a b) = EitherTable tag (f a) (g b)

63 bimap f g (EitherTable tag a b) = EitherTable tag (f a) (g b)

67−instance Table DB a => Apply (EitherTable a) where

66+instance Table Expr a => Apply (EitherTable a) where

68 EitherTable tag l1 f <.> EitherTable tag' l2 a =

67 EitherTable tag l1 f <.> EitherTable tag' l2 a =

69 EitherTable (tag <> tag') (bool l1 l2 (isLeft tag)) (f a)

68 EitherTable (tag <> tag') (bool l1 l2 (isLeft tag)) (f a)

72−instance Table DB a => Applicative (EitherTable a) where

71+instance Table Expr a => Applicative (EitherTable a) where

73 pure = rightTable

72 pure = rightTable

74 (<*>) = (<.>)

73 (<*>) = (<.>)

77−instance Table DB a => Bind (EitherTable a) where

76+instance Table Expr a => Bind (EitherTable a) where

78 EitherTable tag l1 a >>- f = case f a of

77 EitherTable tag l1 a >>- f = case f a of

79 EitherTable tag' l2 b ->

78 EitherTable tag' l2 b ->

80 EitherTable (tag <> tag') (bool l1 l2 (isRight tag)) b

79 EitherTable (tag <> tag') (bool l1 l2 (isRight tag)) b

83−instance Table DB a => Monad (EitherTable a) where

82+instance Table Expr a => Monad (EitherTable a) where

84 (>>=) = (>>-)

83 (>>=) = (>>-)

87−instance (Table DB a, Table DB b) => Semigroup (EitherTable a b) where

86+instance (Table Expr a, Table Expr b) => Semigroup (EitherTable a b) where

88 a <> b = bool a b (isRightTable a)

87 a <> b = bool a b (isRightTable a)

@@ -160,15 +159,15 @@ isRightTable :: EitherTable a b -> Expr Bool

160isRightTable = isRight . tag

159isRightTable = isRight . tag

161

160

162

161

163−eitherTable :: Table DB c

162+eitherTable :: Table Expr c

164 => (a -> c) -> (b -> c) -> EitherTable a b -> c

163 => (a -> c) -> (b -> c) -> EitherTable a b -> c

165eitherTable f g EitherTable {tag, left, right} =

164eitherTable f g EitherTable {tag, left, right} =

166 bool (f left) (g right) (isRight tag)

165 bool (f left) (g right) (isRight tag)

167

166

168

167

169−leftTable :: Table DB b => a -> EitherTable a b

168+leftTable :: Table Expr b => a -> EitherTable a b

170leftTable a = EitherTable (litExpr IsLeft) a undefined

169leftTable a = EitherTable (litExpr IsLeft) a undefined

171

170

172

171

173−rightTable :: Table DB a => b -> EitherTable a b

172+rightTable :: Table Expr a => b -> EitherTable a b

174rightTable = EitherTable (litExpr IsRight) undefined

173rightTable = EitherTable (litExpr IsRight) undefined

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

@@ -27,7 +27,7 @@ import Rel8.Expr ( Expr )

27import Rel8.Expr.Bool ( (||.), (&&.) )

28import Rel8.Expr.Eq ( seq, sne )

29import Rel8.Opaque ( Opaque )

30−import Rel8.Schema.Context ( DB( DB ) )

30+import Rel8.Schema.Context ( Col'(..) )

31import Rel8.Schema.Dict ( Dict( Dict ) )

32import Rel8.Schema.HTable

33 ( HConstrainTable

@@ -42,11 +42,11 @@ import Rel8.Type.Eq ( DBEq )

43type EqTable :: Type -> Constraint

44class

45− ( Table DB a

45+ ( Table Expr a

46 , HConstrainTable (Columns a) (ConstrainDBType DBEq)

47 ) => EqTable a

48instance

49− ( Table DB a

49+ ( Table Expr a

50 , HConstrainTable (Columns a) (ConstrainDBType DBEq)

51 ) => EqTable a

52instance {-# OVERLAPPING #-} EqTable Opaque

src/Rel8/Table/Insert.hs+1−1

@@ -14,7 +14,7 @@ import Prelude

15-- rel8

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

17−import Rel8.Schema.Context ( DB(..), Insertion(..) )

17+import Rel8.Schema.Context ( Col'(..) )

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

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

20import Rel8.Table ( fromColumns, toColumns )

src/Rel8/Table/Lifted.hs+18−23

@@ -16,47 +16,42 @@ import Data.Kind ( Constraint, Type )

16import Prelude ()

18-- rel8

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

19import Rel8.Schema.HTable ( HTable )

20import Rel8.Schema.HTable ( HTable )

20−import Rel8.Schema.HTable.Context ( H, HKTable )

21+import qualified Rel8.Schema.Kind as K

21−import Rel8.Schema.Spec ( Context )

24type Table1 :: (Type -> Type) -> Constraint

25class Table1 f where

26− type Columns1 f :: HKTable -> HKTable

26+ type Columns1 f :: K.HTable -> K.HTable

27− type ConstrainContext1 f :: Context -> Constraint

27+ type ConstrainContext1 f :: K.Context -> Constraint

28− type ConstrainContext1 _ = DefaultConstrainContext

28+ type ConstrainContext1 _ = Interpretation

30 toColumns1 :: (ConstrainContext1 f context, HTable t)

31− => (a -> t (H context))

31+ => (a -> t (Col context))

32 -> f a

33− -> Columns1 f t (H context)

33+ -> Columns1 f t (Col context)

35 fromColumns1 :: (ConstrainContext1 f context, HTable t)

36− => (t (H context) -> a)

36+ => (t (Col context) -> a)

37− -> Columns1 f t (H context)

37+ -> Columns1 f t (Col context)

38 -> f a

41type Table2 :: (Type -> Type -> Type) -> Constraint

42class Table2 p where

43− type Columns2 p :: HKTable -> HKTable -> HKTable

43+ type Columns2 p :: K.HTable -> K.HTable -> K.HTable

44− type ConstrainContext2 p :: Context -> Constraint

44+ type ConstrainContext2 p :: K.Context -> Constraint

45− type ConstrainContext2 _ = DefaultConstrainContext

45+ type ConstrainContext2 _ = Interpretation

47 toColumns2 :: (ConstrainContext2 p context, HTable t, HTable u)

48− => (a -> t (H context))

48+ => (a -> t (Col context))

49− -> (b -> u (H context))

49+ -> (b -> u (Col context))

50 -> p a b

51− -> Columns2 p t u (H context)

51+ -> Columns2 p t u (Col context)

53 fromColumns2 :: (ConstrainContext2 p context, HTable t, HTable u)

54− => (t (H context) -> a)

54+ => (t (Col context) -> a)

55− -> (u (H context) -> b)

55+ -> (u (Col context) -> b)

56− -> Columns2 p t u (H context)

56+ -> Columns2 p t u (Col context)

57 -> p a b

58−

59−

60−type DefaultConstrainContext :: Context -> Constraint

61−class DefaultConstrainContext context

62−instance DefaultConstrainContext context

src/Rel8/Table/List.hs+5−5

@@ -15,9 +15,9 @@ import Data.Kind ( Type )

15import Prelude

17-- rel8

18+import Rel8.Expr ( Expr )

18import Rel8.Expr.Array ( sappend, sempty )

19import Rel8.Expr.Array ( sappend, sempty )

19−import Rel8.Schema.Context ( DB( DB ) )

20+import Rel8.Schema.Context ( Col, Col'(..) )

20−import Rel8.Schema.HTable.Context ( H )

21import Rel8.Schema.HTable.List ( HListTable )

22import Rel8.Schema.HTable.Vectorize ( happend, hempty )

23import Rel8.Table ( Table, Context, Columns, fromColumns, toColumns )

@@ -31,7 +31,7 @@ import Rel8.Table.Recontextualize ( Recontextualize )

31-- | A @ListTable@ value contains zero or more instances of @a@. You construct

32-- @ListTable@s with 'many' or 'listAgg'.

33type ListTable :: Type -> Type

34−newtype ListTable a = ListTable (HListTable (Columns a) (H (Context a)))

34+newtype ListTable a = ListTable (HListTable (Columns a) (Col (Context a)))

37instance Table context a => Table context (ListTable a) where

@@ -54,11 +54,11 @@ instance AlternativeTable ListTable where

54 emptyTable = mempty

57−instance Table DB a => Semigroup (ListTable a) where

57+instance Table Expr a => Semigroup (ListTable a) where

58 ListTable as <> ListTable bs = ListTable $

59 happend (\_ _ (DB a) (DB b) -> DB (sappend a b)) as bs

62−instance Table DB a => Monoid (ListTable a) where

62+instance Table Expr a => Monoid (ListTable a) where

63 mempty = ListTable $ hempty $ \nullability info ->

64 DB (sempty nullability info)

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

@@ -29,7 +29,6 @@ import Rel8.Expr ( Expr )

29import Rel8.Expr.Bool ( boolExpr )

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

31import Rel8.Expr.Serialize ( litExpr )

32−import Rel8.Schema.Context ( DB )

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

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

34import Rel8.Schema.Context.Nullify

33import Rel8.Schema.Context.Nullify

35 ( Nullifiable

34 ( Nullifiable

@@ -115,11 +114,11 @@ instance AlternativeTable MaybeTable where

115 emptyTable = nothingTable

114 emptyTable = nothingTable

116

115

117

116

118−instance (Table DB a, Semigroup a) => Semigroup (MaybeTable a) where

117+instance (Table Expr a, Semigroup a) => Semigroup (MaybeTable a) where

119 ma <> mb = maybeTable mb (\a -> maybeTable ma (justTable . (a <>)) mb) ma

118 ma <> mb = maybeTable mb (\a -> maybeTable ma (justTable . (a <>)) mb) ma

120

119

121

120

122−instance (Table DB a, Semigroup a) => Monoid (MaybeTable a) where

121+instance (Table Expr a, Semigroup a) => Monoid (MaybeTable a) where

123 mempty = nothingTable

122 mempty = nothingTable

124

123

125

124

@@ -176,12 +175,12 @@ isJustTable (MaybeTable tag _) = isNonNull tag

176

175

177

176

178-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.

177-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.

179−maybeTable :: Table DB b => b -> (a -> b) -> MaybeTable a -> b

178+maybeTable :: Table Expr b => b -> (a -> b) -> MaybeTable a -> b

180maybeTable b f ma@(MaybeTable _ a) = bool (f a) b (isNothingTable ma)

179maybeTable b f ma@(MaybeTable _ a) = bool (f a) b (isNothingTable ma)

181

180

182

181

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

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

184−nothingTable :: Table DB a => MaybeTable a

183+nothingTable :: Table Expr a => MaybeTable a

185nothingTable = MaybeTable null undefined

184nothingTable = MaybeTable null undefined

186

185

187

186

src/Rel8/Table/Name.hs+3−3

@@ -24,7 +24,7 @@ import Text.Casing ( quietSnake )

25-- rel8

26import Rel8.Kind.Labels ( renderLabels )

27−import Rel8.Schema.Context ( Name( Name ) )

27+import Rel8.Schema.Context ( Col'(..), Name( Name ) )

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

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

30import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )

@@ -40,7 +40,7 @@ namesFromLabelsWith :: Table Name a

40 => (NonEmpty String -> String) -> a

41namesFromLabelsWith f = fromColumns $ htabulate $ \field ->

42 case hfield hspecs field of

43− SSpec {labels} -> Name (f (renderLabels labels))

43+ SSpec {labels} -> Col (Name (f (renderLabels labels)))

46showLabels :: forall a. Table (Context a) a => a -> [NonEmpty String]

@@ -52,4 +52,4 @@ showLabels _ = getConst $

52showNames :: forall a. Table Name a => a -> [String]

53showNames (toColumns -> names) = getConst $

54 htabulateA @(Columns a) $ \field -> case hfield names field of

55− Name name -> Const [name]

55+ Col (Name name) -> Const [name]

src/Rel8/Table/NonEmpty.hs+4−4

@@ -15,9 +15,9 @@ import Data.Kind ( Type )

15import Prelude

17-- rel8

18+import Rel8.Expr ( Expr )

18import Rel8.Expr.Array ( sappend1 )

19import Rel8.Expr.Array ( sappend1 )

19−import Rel8.Schema.Context ( DB( DB ) )

20+import Rel8.Schema.Context ( Col, Col'(..) )

20−import Rel8.Schema.HTable.Context ( H )

21import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )

22import Rel8.Schema.HTable.Vectorize ( happend )

23import Rel8.Table ( Table, Context, Columns, fromColumns, toColumns )

@@ -29,7 +29,7 @@ import Rel8.Table.Recontextualize ( Recontextualize )

29-- construct @NonEmptyTable@s with 'some' or 'nonEmptyAgg'.

30type NonEmptyTable :: Type -> Type

31newtype NonEmptyTable a =

32− NonEmptyTable (HNonEmptyTable (Columns a) (H (Context a)))

32+ NonEmptyTable (HNonEmptyTable (Columns a) (Col (Context a)))

35instance Table context a => Table context (NonEmptyTable a) where

@@ -48,6 +48,6 @@ instance AltTable NonEmptyTable where

48 (<|>:) = (<>)

51−instance Table DB a => Semigroup (NonEmptyTable a) where

51+instance Table Expr a => Semigroup (NonEmptyTable a) where

52 NonEmptyTable as <> NonEmptyTable bs = NonEmptyTable $

53 happend (\_ _ (DB a) (DB b) -> DB (sappend1 a b)) as bs

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

@@ -33,6 +33,7 @@ import Data.Profunctor ( dimap, lmap )

34-- rel8

35import Rel8.Aggregate ( Aggregate( Aggregate ) )

36+import Rel8.Expr ( Expr )

36import Rel8.Expr.Opaleye

37import Rel8.Expr.Opaleye

37 ( scastExpr

38 ( scastExpr

38 , fromPrimExpr, toPrimExpr

39 , fromPrimExpr, toPrimExpr

@@ -40,7 +41,7 @@ import Rel8.Expr.Opaleye

40 , fromColumn, toColumn

41 , fromColumn, toColumn

41 )

42 )

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

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

43−import Rel8.Schema.Context ( DB(..), Insertion(..), Name(..) )

44+import Rel8.Schema.Context ( Col, Col'(..), Insertion, Name(..) )

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

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

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

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

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

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

@@ -57,7 +58,7 @@ aggregator = Opaleye.Aggregator $ Opaleye.PackMap $

57 \f (Aggregate (Opaleye.Aggregator (Opaleye.PackMap inner))) -> inner f ()

58 \f (Aggregate (Opaleye.Aggregator (Opaleye.PackMap inner))) -> inner f ()

60−binaryspec :: Table DB a => Opaleye.Binaryspec a a

61+binaryspec :: Table Expr a => Opaleye.Binaryspec a a

61binaryspec = Opaleye.Binaryspec $ Opaleye.PackMap $ \f (as, bs) ->

62binaryspec = Opaleye.Binaryspec $ Opaleye.PackMap $ \f (as, bs) ->

62 fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->

63 fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->

63 WrapApplicative $

64 WrapApplicative $

@@ -65,7 +66,7 @@ binaryspec = Opaleye.Binaryspec $ Opaleye.PackMap $ \f (as, bs) ->

65 (DB a, DB b) -> DB . fromPrimExpr <$> f (toPrimExpr a, toPrimExpr b)

66 (DB a, DB b) -> DB . fromPrimExpr <$> f (toPrimExpr a, toPrimExpr b)

68−distinctspec :: Table DB a => Opaleye.Distinctspec a a

69+distinctspec :: Table Expr a => Opaleye.Distinctspec a a

69distinctspec =

70distinctspec =

70 Opaleye.Distinctspec $ Opaleye.Aggregator $ Opaleye.PackMap $ \f ->

71 Opaleye.Distinctspec $ Opaleye.Aggregator $ Opaleye.PackMap $ \f ->

71 fmap fromColumns .

72 fmap fromColumns .

@@ -94,8 +95,8 @@ tableFields (toColumns -> names) = dimap toColumns fromColumns $

94 specs -> case hfield names field of

95 specs -> case hfield names field of

95 name -> lmap (`hfield` field) (go specs name)

96 name -> lmap (`hfield` field) (go specs name)

96 where

97 where

97− go :: SSpec spec -> Name spec -> Opaleye.TableFields (Insertion spec) (DB spec)

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

98− go SSpec {necessity, info, nullability} (Name name) =

99+ go SSpec {necessity, info, nullability} (Col (Name name)) =

99 case necessity of

100 case necessity of

100 SRequired ->

101 SRequired ->

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

102 lmap (\(RequiredInsert a) -> toColumn $ toPrimExpr a) $

@@ -107,7 +108,7 @@ tableFields (toColumns -> names) = dimap toColumns fromColumns $

107 Opaleye.optionalTableField name

108 Opaleye.optionalTableField name

108

109

110

110−unpackspec :: Table DB a => Opaleye.Unpackspec a a

111+unpackspec :: Table Expr a => Opaleye.Unpackspec a a

111unpackspec = Opaleye.Unpackspec $ Opaleye.PackMap $ \f ->

112unpackspec = Opaleye.Unpackspec $ Opaleye.PackMap $ \f ->

112 fmap fromColumns .

113 fmap fromColumns .

113 unwrapApplicative .

114 unwrapApplicative .

@@ -116,11 +117,11 @@ unpackspec = Opaleye.Unpackspec $ Opaleye.PackMap $ \f ->

116{-# INLINABLE unpackspec #-}

117{-# INLINABLE unpackspec #-}

117

118

119

119−valuesspec :: Table DB a => Opaleye.ValuesspecSafe a a

120+valuesspec :: Table Expr a => Opaleye.ValuesspecSafe a a

120valuesspec = Opaleye.ValuesspecSafe (toPackMap undefined) unpackspec

121valuesspec = Opaleye.ValuesspecSafe (toPackMap undefined) unpackspec

121

122

123

123−toPackMap :: Table DB a

124+toPackMap :: Table Expr a

124 => a -> Opaleye.PackMap Opaleye.PrimExpr Opaleye.PrimExpr () a

125 => a -> Opaleye.PackMap Opaleye.PrimExpr Opaleye.PrimExpr () a

125toPackMap as = Opaleye.PackMap $ \f () ->

126toPackMap as = Opaleye.PackMap $ \f () ->

126 fmap fromColumns $

127 fmap fromColumns $

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

@@ -25,7 +25,7 @@ import Rel8.Expr.Bool ( (||.), (&&.), false, true )

25import Rel8.Expr.Eq ( seq )

26import Rel8.Expr.Ord ( slt, sgt)

27import Rel8.Opaque ( Opaque )

28−import Rel8.Schema.Context ( DB( DB ) )

28+import Rel8.Schema.Context ( Col'(..) )

29import Rel8.Schema.Dict ( Dict( Dict ) )

30import Rel8.Schema.HTable

31 ( HConstrainTable

src/Rel8/Table/Recontextualize.hs+78−27

@@ -25,18 +25,17 @@ import Prelude ()

25import Rel8.Aggregate ( Aggregate )

26import Rel8.Expr ( Expr )

27import Rel8.Opaque ( Opaque, Opaque1 )

28−import Rel8.Schema.Context ( Aggregation, DB, Insertion, Name, Result )

28+import Rel8.Schema.Context ( Col', Insertion, Name, IsSpecialContext )

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

30import Rel8.Schema.HTable ( HTable )

31−import Rel8.Schema.HTable.Context ( H )

31+import qualified Rel8.Schema.Kind as K

32import Rel8.Schema.Nullability ( Sql )

33import Rel8.Schema.Spec ( KnownSpec )

34−import qualified Rel8.Schema.Spec as Kind ( Context )

35import Rel8.Table ( Table, Congruent )

34import Rel8.Table ( Table, Congruent )

36import Rel8.Type ( DBType )

35import Rel8.Type ( DBType )

39−type Recontextualize :: Kind.Context -> Kind.Context -> Type -> Type -> Constraint

38+type Recontextualize :: K.Context -> K.Context -> Type -> Type -> Constraint

40class

39class

41 ( Table from a

40 ( Table from a

42 , Table to b

41 , Table to b

@@ -51,49 +50,101 @@ class

51 , b from -> a

50 , b from -> a

53+instance (KnownSpec spec, x ~ IsSpecialContext from, y ~ IsSpecialContext to) =>

54+ Recontextualize from to (Col' x from spec) (Col' y to spec)

55+

56+

57+instance Sql DBType a =>

58+ Recontextualize Aggregate Aggregate (Aggregate (Expr a)) (Aggregate (Expr a))

59+

60+

54instance Sql DBType a =>

61instance Sql DBType a =>

55− Recontextualize Aggregation Aggregation (Aggregate (Expr a)) (Aggregate (Expr a))

62+ Recontextualize Aggregate Expr (Aggregate (Expr a)) (Expr a)

58instance Sql DBType a =>

65instance Sql DBType a =>

59− Recontextualize Aggregation DB (Aggregate (Expr a)) (Expr a)

66+ Recontextualize Aggregate Identity (Aggregate (Expr a)) (Identity a)

62instance Sql DBType a =>

69instance Sql DBType a =>

63− Recontextualize Aggregation Result (Aggregate (Expr a)) (Identity a)

70+ Recontextualize Aggregate Insertion (Aggregate (Expr a)) (Insertion a)

66instance Sql DBType a =>

73instance Sql DBType a =>

67− Recontextualize DB Aggregation (Expr a) (Aggregate (Expr a))

74+ Recontextualize Aggregate Name (Aggregate (Expr a)) (Name a)

70instance Sql DBType a =>

77instance Sql DBType a =>

71− Recontextualize DB DB (Expr a) (Expr a)

78+ Recontextualize Expr Aggregate (Expr a) (Aggregate (Expr a))

79+

80+

81+instance Sql DBType a => Recontextualize Expr Expr (Expr a) (Expr a)

82+

83+

84+instance Sql DBType a => Recontextualize Expr Identity (Expr a) (Identity a)

85+

86+

87+instance Sql DBType a => Recontextualize Expr Insertion (Expr a) (Insertion a)

88+

89+

90+instance Sql DBType a => Recontextualize Expr Name (Expr a) (Name a)

91+

92+

93+instance Sql DBType a =>

94+ Recontextualize Identity Aggregate (Identity a) (Aggregate (Expr a))

95+

96+

97+instance Sql DBType a => Recontextualize Identity Expr (Identity a) (Expr a)

98+

99+

100+instance Sql DBType a => Recontextualize Identity Identity (Identity a) (Identity a)

101

102

74instance Sql DBType a =>

103instance Sql DBType a =>

75− Recontextualize DB Result (Expr a) (Identity a)

104+ Recontextualize Identity Insertion (Identity a) (Insertion a)

105+

106+

107+instance Sql DBType a => Recontextualize Identity Name (Identity a) (Name a)

108

109

78instance Sql DBType a =>

110instance Sql DBType a =>

79− Recontextualize Result Aggregation (Identity a) (Aggregate (Expr a))

111+ Recontextualize Insertion Aggregate (Insertion a) (Aggregate (Expr a))

112+

113+

114+instance Sql DBType a => Recontextualize Insertion Expr (Insertion a) (Expr a)

115

116

82instance Sql DBType a =>

117instance Sql DBType a =>

83− Recontextualize Result DB (Identity a) (Expr a)

118+ Recontextualize Insertion Identity (Insertion a) (Identity a)

119+

120+

121+instance Sql DBType a => Recontextualize Insertion Insertion (Insertion a) (Insertion a)

122+

123+

124+instance Sql DBType a => Recontextualize Insertion Name (Insertion a) (Name a)

125

126

86instance Sql DBType a =>

127instance Sql DBType a =>

87− Recontextualize Result Result (Identity a) (Identity a)

128+ Recontextualize Name Aggregate (Name a) (Aggregate (Expr a))

129+

130+

131+instance Sql DBType a => Recontextualize Name Expr (Name a) (Expr a)

132+

133+

134+instance Sql DBType a => Recontextualize Name Identity (Name a) (Identity a)

135+

136+

137+instance Sql DBType a => Recontextualize Name Insertion (Name a) (Insertion a)

138

139

90−instance KnownSpec spec => Recontextualize from to (from spec) (to spec)

140+instance Sql DBType a => Recontextualize Name Name (Name a) (Name a)

141

142

93instance Recontextualize from to (Opaque1 from a) (Opaque1 to a)

143instance Recontextualize from to (Opaque1 from a) (Opaque1 to a)

144

145

146+instance (HTable t, x ~ IsSpecialContext from, y ~ IsSpecialContext to) =>

96−instance HTable t => Recontextualize from to (t (H from)) (t (H to))

147+ Recontextualize from to (t (Col' x from)) (t (Col' y to))

148

149

99instance

150instance

@@ -139,24 +190,24 @@ instance

139

190

140

191

141type Aggregates :: Type -> Type -> Constraint

192type Aggregates :: Type -> Type -> Constraint

142−class Recontextualize Aggregation DB aggregates exprs => Aggregates aggregates exprs

193+class Recontextualize Aggregate Expr aggregates exprs => Aggregates aggregates exprs

143−instance Recontextualize Aggregation DB aggregates exprs => Aggregates aggregates exprs

194+instance Recontextualize Aggregate Expr aggregates exprs => Aggregates aggregates exprs

144−instance {-# OVERLAPPING #-} Aggregates (Opaque1 Aggregation Opaque) (Opaque1 DB Opaque)

195+instance {-# OVERLAPPING #-} Aggregates (Opaque1 Aggregate Opaque) (Opaque1 Expr Opaque)

145

196

146

197

147type Encodes :: Type -> Type -> Constraint

198type Encodes :: Type -> Type -> Constraint

148−class Recontextualize Result DB a exprs => Encodes a exprs

199+class Recontextualize Identity Expr a exprs => Encodes a exprs

149−instance Recontextualize Result DB a exprs => Encodes a exprs

200+instance Recontextualize Identity Expr a exprs => Encodes a exprs

150−instance {-# OVERLAPPING #-} Encodes (Opaque1 Result Opaque) (Opaque1 DB Opaque)

201+instance {-# OVERLAPPING #-} Encodes (Opaque1 Identity Opaque) (Opaque1 Expr Opaque)

151

202

152

203

153type Inserts :: Type -> Type -> Constraint

204type Inserts :: Type -> Type -> Constraint

154−class Recontextualize DB Insertion exprs inserts => Inserts exprs inserts

205+class Recontextualize Expr Insertion exprs inserts => Inserts exprs inserts

155−instance Recontextualize DB Insertion exprs inserts => Inserts exprs inserts

206+instance Recontextualize Expr Insertion exprs inserts => Inserts exprs inserts

156−instance {-# OVERLAPPING #-} Inserts (Opaque1 DB Opaque) (Opaque1 Insertion Opaque)

207+instance {-# OVERLAPPING #-} Inserts (Opaque1 Expr Opaque) (Opaque1 Insertion Opaque)

157

208

158

209

159type Selects :: Type -> Type -> Constraint

210type Selects :: Type -> Type -> Constraint

160−class Recontextualize Name DB names exprs => Selects names exprs

211+class Recontextualize Name Expr names exprs => Selects names exprs

161−instance Recontextualize Name DB names exprs => Selects names exprs

212+instance Recontextualize Name Expr names exprs => Selects names exprs

162−instance {-# OVERLAPPING #-} Selects (Opaque1 Name Opaque) (Opaque1 DB Opaque)

213+instance {-# OVERLAPPING #-} Selects (Opaque1 Name Opaque) (Opaque1 Expr Opaque)

src/Rel8/Table/Serialize.hs+109−108

@@ -19,6 +19,7 @@ where

20-- base

21import Data.Bifunctor ( bimap )

22+import Data.Functor.Identity ( Identity )

22import Data.Kind ( Constraint, Type )

23import Data.Kind ( Constraint, Type )

23import Data.List.NonEmpty ( NonEmpty )

24import Data.List.NonEmpty ( NonEmpty )

24import Prelude

25import Prelude

@@ -30,15 +31,15 @@ import qualified Hasql.Decoders as Hasql

30import Rel8.Expr ( Expr )

31import Rel8.Expr ( Expr )

31import Rel8.Expr.Serialize ( slitExpr, sparseValue )

32import Rel8.Expr.Serialize ( slitExpr, sparseValue )

32import Rel8.Opaque ( Opaque )

33import Rel8.Opaque ( Opaque )

33−import Rel8.Schema.Context ( DB(..), Result(..) )

34+import Rel8.Schema.Context ( Col, Col'(..) )

34−import Rel8.Schema.Context.Label ( labeler, unlabeler )

35+import Rel8.Schema.Context.Identity

35−import Rel8.Schema.Context.Result

36 ( fromHEitherTable, toHEitherTable

37 , fromHListTable, toHListTable

38 , fromHMaybeTable, toHMaybeTable

39 , fromHNonEmptyTable, toHNonEmptyTable

40 , fromHTheseTable, toHTheseTable

41 )

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

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

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

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

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

44import Rel8.Schema.HTable.Quartet ( HQuartet(..) )

45import Rel8.Schema.HTable.Quartet ( HQuartet(..) )

@@ -46,7 +47,6 @@ import Rel8.Schema.HTable.Quintet ( HQuintet(..) )

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

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

47import Rel8.Schema.HTable.Trio ( HTrio(..) )

48import Rel8.Schema.HTable.Trio ( HTrio(..) )

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

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

49−import Rel8.Schema.HTable.Context ( H )

50import Rel8.Schema.Nullability ( IsMaybe, Sql )

51import Rel8.Schema.Spec ( SSpec(..), KnownSpec )

52import Rel8.Table ( Table, Columns, fromColumns, toColumns )

@@ -76,9 +76,9 @@ type family IsPlainColumn a where

76 IsPlainColumn (_, _, _) = 'False

77 IsPlainColumn (_, _, _, _) = 'False

78 IsPlainColumn (_, _, _, _, _) = 'False

79− IsPlainColumn (_ (H Result)) = 'False

79+ IsPlainColumn (_ Identity) = 'False

80− IsPlainColumn (_ Result) = 'False

80+ IsPlainColumn (_ (Col' _ Identity _)) = 'False

81− IsPlainColumn (Result _) = 'False

81+ IsPlainColumn (Identity _) = 'False

82 IsPlainColumn _ = 'True

@@ -93,9 +93,9 @@ type family IsTabular a where

93 IsTabular (_, _, _) = 'True

94 IsTabular (_, _, _, _) = 'True

95 IsTabular (_, _, _, _, _) = 'True

96− IsTabular (_ (H Result)) = 'True

96+ IsTabular (_ Identity) = 'True

97− IsTabular (_ Result) = 'True

97+ IsTabular (_ (Col' _ Identity)) = 'True

98− IsTabular (Result _) = 'True

98+ IsTabular (Col' _ Identity _) = 'True

99 IsTabular _ = 'False

100

101

@@ -123,19 +123,19 @@ class ExprsFor (IsPlainColumn a) (IsTabular' (IsTabular a) exprs) a exprs => ToE

123instance ExprsFor (IsPlainColumn a) (IsTabular' (IsTabular a) exprs) a exprs => ToExprs a exprs

124

125

126−fromResults' :: forall exprs a. ToExprs a exprs => Columns exprs (H Result) -> a

126+fromIdentity' :: forall exprs a. ToExprs a exprs => Columns exprs (Col Identity) -> a

127−fromResults' = fromResults @(IsPlainColumn a) @_ @_ @exprs

127+fromIdentity' = fromIdentity @(IsPlainColumn a) @_ @_ @exprs

128

129

130−toResults' :: forall exprs a. ToExprs a exprs => a -> Columns exprs (H Result)

130+toIdentity' :: forall exprs a. ToExprs a exprs => a -> Columns exprs (Col Identity)

131−toResults' = toResults @(IsPlainColumn a) @_ @_ @exprs

131+toIdentity' = toIdentity @(IsPlainColumn a) @_ @_ @exprs

132

133

134type ExprsFor :: Bool -> Bool -> Type -> Type -> Constraint

135−class (Table DB exprs, isTabular ~ IsTabular a) =>

135+class (Table Expr exprs, isTabular ~ IsTabular a) =>

136 ExprsFor isPlainColumn isTabular a exprs where

137− fromResults :: Columns exprs (H Result) -> a

137+ fromIdentity :: Columns exprs (Col Identity) -> a

138− toResults :: a -> Columns exprs (H Result)

138+ toIdentity :: a -> Columns exprs (Col Identity)

139

140

141instance

@@ -146,8 +146,8 @@ instance

146 )

147 => ExprsFor 'True 'False a x

148 where

149− fromResults (HType (Result a)) = a

149+ fromIdentity (HType (Result a)) = a

150− toResults = HType . Result

150+ toIdentity = HType . Result

151

152

153instance

@@ -156,8 +156,8 @@ instance

156 , x ~ [a]

157 ) => ExprsFor 'False 'False [a] (Expr x)

158 where

159− fromResults (HType (Result a)) = a

159+ fromIdentity (HType (Result a)) = a

160− toResults = HType . Result

160+ toIdentity = HType . Result

161

162

163instance

@@ -168,8 +168,8 @@ instance

168 , x ~ Maybe a

169 ) => ExprsFor 'False 'False (Maybe a) (Expr x)

170 where

171− fromResults (HType (Result a)) = a

171+ fromIdentity (HType (Result a)) = a

172− toResults = HType . Result

172+ toIdentity = HType . Result

173

174

175instance

@@ -178,8 +178,8 @@ instance

178 , x ~ NonEmpty a

179 ) => ExprsFor 'False 'False (NonEmpty a) (Expr x)

180 where

181− fromResults (HType (Result a)) = a

181+ fromIdentity (HType (Result a)) = a

182− toResults = HType . Result

182+ toIdentity = HType . Result

183

184

185instance

@@ -187,8 +187,8 @@ instance

187 , IsListTabular a ~ 'False

188 ) => ExprsFor 'False 'False [a] (ListTable exprs)

189 where

190− fromResults = fmap (fromResults' @exprs) . fromHListTable

190+ fromIdentity = fmap (fromIdentity' @exprs) . fromHListTable

191− toResults = toHListTable . fmap (toResults' @exprs)

191+ toIdentity = toHListTable . fmap (toIdentity' @exprs)

192

193

194instance

@@ -196,12 +196,12 @@ instance

196 , IsMaybeTabular a ~ 'False

197 ) => ExprsFor 'False 'False (Maybe a) (MaybeTable exprs)

198 where

199− fromResults =

199+ fromIdentity =

200− fmap (fromResults' @exprs . hunlabel unlabeler) .

200+ fmap (fromIdentity' @exprs . hunlabel unlabeler) .

201 fromHMaybeTable

202− toResults =

202+ toIdentity =

203 toHMaybeTable .

204− fmap (hlabel labeler . toResults' @exprs)

204+ fmap (hlabel labeler . toIdentity' @exprs)

205

206

207instance

@@ -209,8 +209,8 @@ instance

209 , IsListTabular a ~ 'False

210 ) => ExprsFor 'False 'False (NonEmpty a) (NonEmptyTable exprs)

211 where

212− fromResults = fmap (fromResults' @exprs) . fromHNonEmptyTable

212+ fromIdentity = fmap (fromIdentity' @exprs) . fromHNonEmptyTable

213− toResults = toHNonEmptyTable . fmap (toResults' @exprs)

213+ toIdentity = toHNonEmptyTable . fmap (toIdentity' @exprs)

214

215

216instance

@@ -220,16 +220,16 @@ instance

220 , x ~ EitherTable exprs1 exprs2

221 ) => ExprsFor 'False isTabular (Either a b) x

222 where

223− fromResults =

223+ fromIdentity =

224 bimap

225− (fromResults' @exprs1 . hunlabel unlabeler)

225+ (fromIdentity' @exprs1 . hunlabel unlabeler)

226− (fromResults' @exprs2 . hunlabel unlabeler) .

226+ (fromIdentity' @exprs2 . hunlabel unlabeler) .

227 fromHEitherTable

228− toResults =

228+ toIdentity =

229 toHEitherTable .

230 bimap

231− (hlabel labeler . toResults' @exprs1)

231+ (hlabel labeler . toIdentity' @exprs1)

232− (hlabel labeler . toResults' @exprs2)

232+ (hlabel labeler . toIdentity' @exprs2)

233

234

235instance

@@ -238,8 +238,8 @@ instance

238 , x ~ ListTable exprs

239 ) => ExprsFor 'False 'True [a] x

240 where

241− fromResults = fmap (fromResults' @exprs) . fromHListTable

241+ fromIdentity = fmap (fromIdentity' @exprs) . fromHListTable

242− toResults = toHListTable . fmap (toResults' @exprs)

242+ toIdentity = toHListTable . fmap (toIdentity' @exprs)

243

244

245instance

@@ -248,12 +248,12 @@ instance

248 , x ~ MaybeTable exprs

249 ) => ExprsFor 'False 'True (Maybe a) x

250 where

251− fromResults =

251+ fromIdentity =

252− fmap (fromResults' @exprs . hunlabel unlabeler) .

252+ fmap (fromIdentity' @exprs . hunlabel unlabeler) .

253 fromHMaybeTable

254− toResults =

254+ toIdentity =

255 toHMaybeTable .

256− fmap (hlabel labeler . toResults' @exprs)

256+ fmap (hlabel labeler . toIdentity' @exprs)

257

258

259instance

@@ -262,8 +262,8 @@ instance

262 , x ~ NonEmptyTable exprs

263 ) => ExprsFor 'False 'True (NonEmpty a) x

264 where

265− fromResults = fmap (fromResults' @exprs) . fromHNonEmptyTable

265+ fromIdentity = fmap (fromIdentity' @exprs) . fromHNonEmptyTable

266− toResults = toHNonEmptyTable . fmap (toResults' @exprs)

266+ toIdentity = toHNonEmptyTable . fmap (toIdentity' @exprs)

267

268

269instance

@@ -273,16 +273,16 @@ instance

273 , x ~ TheseTable exprs1 exprs2

274 ) => ExprsFor 'False isTabular (These a b) x

275 where

276− fromResults =

276+ fromIdentity =

277 bimap

278− (fromResults' @exprs1 . hunlabel unlabeler)

278+ (fromIdentity' @exprs1 . hunlabel unlabeler)

279− (fromResults' @exprs2 . hunlabel unlabeler) .

279+ (fromIdentity' @exprs2 . hunlabel unlabeler) .

280 fromHTheseTable

281− toResults =

281+ toIdentity =

282 toHTheseTable .

283 bimap

284− (hlabel labeler . toResults' @exprs1)

284+ (hlabel labeler . toIdentity' @exprs1)

285− (hlabel labeler . toResults' @exprs2)

285+ (hlabel labeler . toIdentity' @exprs2)

286

287

288instance

@@ -292,13 +292,13 @@ instance

292 , x ~ (exprs1, exprs2)

293 ) => ExprsFor 'False isTabular (a, b) x

294 where

295− fromResults (HPair a b) =

295+ fromIdentity (HPair a b) =

296− ( fromResults' @exprs1 $ hunlabel unlabeler a

296+ ( fromIdentity' @exprs1 $ hunlabel unlabeler a

297− , fromResults' @exprs2 $ hunlabel unlabeler b

297+ , fromIdentity' @exprs2 $ hunlabel unlabeler b

298 )

299− toResults (a, b) = HPair

299+ toIdentity (a, b) = HPair

300− { hfst = hlabel labeler $ toResults' @exprs1 a

300+ { hfst = hlabel labeler $ toIdentity' @exprs1 a

301− , hsnd = hlabel labeler $ toResults' @exprs2 b

301+ , hsnd = hlabel labeler $ toIdentity' @exprs2 b

302 }

303

304

@@ -310,15 +310,15 @@ instance

310 , x ~ (exprs1, exprs2, exprs3)

311 ) => ExprsFor 'False isTabular (a, b, c) x

312 where

313− fromResults (HTrio a b c) =

313+ fromIdentity (HTrio a b c) =

314− ( fromResults' @exprs1 $ hunlabel unlabeler a

314+ ( fromIdentity' @exprs1 $ hunlabel unlabeler a

315− , fromResults' @exprs2 $ hunlabel unlabeler b

315+ , fromIdentity' @exprs2 $ hunlabel unlabeler b

316− , fromResults' @exprs3 $ hunlabel unlabeler c

316+ , fromIdentity' @exprs3 $ hunlabel unlabeler c

317 )

318− toResults (a, b, c) = HTrio

318+ toIdentity (a, b, c) = HTrio

319− { hfst = hlabel labeler $ toResults' @exprs1 a

319+ { hfst = hlabel labeler $ toIdentity' @exprs1 a

320− , hsnd = hlabel labeler $ toResults' @exprs2 b

320+ , hsnd = hlabel labeler $ toIdentity' @exprs2 b

321− , htrd = hlabel labeler $ toResults' @exprs3 c

321+ , htrd = hlabel labeler $ toIdentity' @exprs3 c

322 }

323

324

@@ -331,17 +331,17 @@ instance

331 , x ~ (exprs1, exprs2, exprs3, exprs4)

332 ) => ExprsFor 'False isTabular (a, b, c, d) x

333 where

334− fromResults (HQuartet a b c d) =

334+ fromIdentity (HQuartet a b c d) =

335− ( fromResults' @exprs1 $ hunlabel unlabeler a

335+ ( fromIdentity' @exprs1 $ hunlabel unlabeler a

336− , fromResults' @exprs2 $ hunlabel unlabeler b

336+ , fromIdentity' @exprs2 $ hunlabel unlabeler b

337− , fromResults' @exprs3 $ hunlabel unlabeler c

337+ , fromIdentity' @exprs3 $ hunlabel unlabeler c

338− , fromResults' @exprs4 $ hunlabel unlabeler d

338+ , fromIdentity' @exprs4 $ hunlabel unlabeler d

339 )

340− toResults (a, b, c, d) = HQuartet

340+ toIdentity (a, b, c, d) = HQuartet

341− { hfst = hlabel labeler $ toResults' @exprs1 a

341+ { hfst = hlabel labeler $ toIdentity' @exprs1 a

342− , hsnd = hlabel labeler $ toResults' @exprs2 b

342+ , hsnd = hlabel labeler $ toIdentity' @exprs2 b

343− , htrd = hlabel labeler $ toResults' @exprs3 c

343+ , htrd = hlabel labeler $ toIdentity' @exprs3 c

344− , hfrt = hlabel labeler $ toResults' @exprs4 d

344+ , hfrt = hlabel labeler $ toIdentity' @exprs4 d

345 }

346

347

@@ -355,58 +355,59 @@ instance

355 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5)

356 ) => ExprsFor 'False isTabular (a, b, c, d, e) x

357 where

358− fromResults (HQuintet a b c d e) =

358+ fromIdentity (HQuintet a b c d e) =

359− ( fromResults' @exprs1 $ hunlabel unlabeler a

359+ ( fromIdentity' @exprs1 $ hunlabel unlabeler a

360− , fromResults' @exprs2 $ hunlabel unlabeler b

360+ , fromIdentity' @exprs2 $ hunlabel unlabeler b

361− , fromResults' @exprs3 $ hunlabel unlabeler c

361+ , fromIdentity' @exprs3 $ hunlabel unlabeler c

362− , fromResults' @exprs4 $ hunlabel unlabeler d

362+ , fromIdentity' @exprs4 $ hunlabel unlabeler d

363− , fromResults' @exprs5 $ hunlabel unlabeler e

363+ , fromIdentity' @exprs5 $ hunlabel unlabeler e

364 )

365− toResults (a, b, c, d, e) = HQuintet

365+ toIdentity (a, b, c, d, e) = HQuintet

366− { hfst = hlabel labeler $ toResults' @exprs1 a

366+ { hfst = hlabel labeler $ toIdentity' @exprs1 a

367− , hsnd = hlabel labeler $ toResults' @exprs2 b

367+ , hsnd = hlabel labeler $ toIdentity' @exprs2 b

368− , htrd = hlabel labeler $ toResults' @exprs3 c

368+ , htrd = hlabel labeler $ toIdentity' @exprs3 c

369− , hfrt = hlabel labeler $ toResults' @exprs4 d

369+ , hfrt = hlabel labeler $ toIdentity' @exprs4 d

370− , hfft = hlabel labeler $ toResults' @exprs5 e

370+ , hfft = hlabel labeler $ toIdentity' @exprs5 e

371 }

372

373

374instance

375 ( HTable t

376 , isTabular ~ 'True

377− , result ~ H Result

377+ , result ~ Col Identity

378− , x ~ t (H DB)

378+ , x ~ t (Col Expr)

379 ) => ExprsFor 'False isTabular (t result) x

380 where

381− fromResults = id

381+ fromIdentity = id

382− toResults = id

382+ toIdentity = id

383

384

385instance

386− ( Encodes (t Result) (t DB)

386+ ( Encodes (t Identity) (t Expr)

387 , isTabular ~ 'True

388− , result ~ Result

388+ , result ~ Identity

389− , x ~ t DB

389+ , x ~ t Expr

390 ) => ExprsFor 'False isTabular (t result) x

391 where

392− fromResults = fromColumns

392+ fromIdentity = fromColumns

393− toResults = toColumns

393+ toIdentity = toColumns

394

395

396instance

397 ( KnownSpec spec

398 , isTabular ~ 'True

399+ , isSpecial ~ 'True

399− , x ~ DB spec

400+ , x ~ Col Expr spec

400− ) => ExprsFor 'False isTabular (Result spec) x

401+ ) => ExprsFor 'False isTabular (Col' isSpecial Identity spec) x

401 where

402 where

402− fromResults = fromColumns

403+ fromIdentity = fromColumns

403− toResults = toColumns

404+ toIdentity = toColumns

404

405

406

406type FromExprs :: Type -> Type

407type FromExprs :: Type -> Type

407type family FromExprs a where

408type family FromExprs a where

408 FromExprs (Expr a) = a

409 FromExprs (Expr a) = a

409− FromExprs (DB spec) = Result spec

410+ FromExprs (Col' _ Expr spec) = Col Identity spec

410 FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)

411 FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)

411 FromExprs (ListTable a) = [FromExprs a]

412 FromExprs (ListTable a) = [FromExprs a]

412 FromExprs (MaybeTable a) = Maybe (FromExprs a)

413 FromExprs (MaybeTable a) = Maybe (FromExprs a)

@@ -418,8 +419,8 @@ type family FromExprs a where

418 (FromExprs a, FromExprs b, FromExprs c, FromExprs d)

419 (FromExprs a, FromExprs b, FromExprs c, FromExprs d)

419 FromExprs (a, b, c, d, e) =

420 FromExprs (a, b, c, d, e) =

420 (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e)

421 (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e)

421− FromExprs (t DB) = t Result

422+ FromExprs (t Expr) = t Identity

422− FromExprs (t (H DB)) = t (H Result)

423+ FromExprs (t (Col' _ Expr)) = t (Col Identity)

423

424

425

425-- | @Serializable@ witnesses the one-to-one correspondence between the type

426-- | @Serializable@ witnesses the one-to-one correspondence between the type

@@ -431,11 +432,11 @@ instance Serializable (Expr Opaque) Opaque

431

432

433

433lit :: forall exprs a. Serializable exprs a => a -> exprs

434lit :: forall exprs a. Serializable exprs a => a -> exprs

434−lit = fromColumns . litTable . toResults' @exprs

435+lit = fromColumns . litTable . toIdentity' @exprs

435

436

437

437parse :: forall exprs a. Serializable exprs a => Hasql.Row a

438parse :: forall exprs a. Serializable exprs a => Hasql.Row a

438−parse = fromResults' @exprs <$> parseTable

439+parse = fromIdentity' @exprs <$> parseTable

439

440

441

441litTable :: Encodes a b => a -> b

442litTable :: Encodes a b => a -> b

@@ -445,7 +446,7 @@ litTable (toColumns -> as) = fromColumns $ htabulate $ \field ->

445 Result value -> DB (slitExpr nullability info value)

446 Result value -> DB (slitExpr nullability info value)

446

447

448

448−parseTable :: Table Result a => Hasql.Row a

449+parseTable :: Table Identity a => Hasql.Row a

449parseTable = fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->

450parseTable = fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->

450 WrapApplicative $ case hfield hspecs field of

451 WrapApplicative $ case hfield hspecs field of

451 SSpec {nullability, info} -> Result <$> sparseValue nullability info

452 SSpec {nullability, info} -> Result <$> sparseValue nullability info

src/Rel8/Table/These.hs+8−9

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

29import Rel8.Expr ( Expr )

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

31import Rel8.Expr.Null ( isNonNull )

32−import Rel8.Schema.Context ( DB )

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

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

34import Rel8.Schema.Context.Nullify

33import Rel8.Schema.Context.Nullify

35 ( Nullifiable, NullifiableEq

34 ( Nullifiable, NullifiableEq

@@ -70,20 +69,20 @@ instance Bifunctor TheseTable where

70 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)

69 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)

73−instance (Table DB a, Semigroup a) => Apply (TheseTable a) where

72+instance (Table Expr a, Semigroup a) => Apply (TheseTable a) where

74 fs <.> as = TheseTable

73 fs <.> as = TheseTable

75 { here = here fs <> here as

74 { here = here fs <> here as

76 , there = there fs <.> there as

75 , there = there fs <.> there as

77 }

76 }

80−instance (Table DB a, Semigroup a) => Applicative (TheseTable a)

79+instance (Table Expr a, Semigroup a) => Applicative (TheseTable a)

81 where

80 where

82 pure = thatTable

81 pure = thatTable

83 (<*>) = (<.>)

82 (<*>) = (<.>)

86−instance (Table DB a, Semigroup a) => Bind (TheseTable a) where

85+instance (Table Expr a, Semigroup a) => Bind (TheseTable a) where

87 TheseTable here1 ma >>- f = case ma >>- f' of

86 TheseTable here1 ma >>- f = case ma >>- f' of

88 mtb -> TheseTable

87 mtb -> TheseTable

89 { here = maybeTable here1 ((here1 <>) . fst) mtb

88 { here = maybeTable here1 ((here1 <>) . fst) mtb

@@ -94,11 +93,11 @@ instance (Table DB a, Semigroup a) => Bind (TheseTable a) where

94 TheseTable here2 mb -> (here2,) <$> mb

93 TheseTable here2 mb -> (here2,) <$> mb

97−instance (Table DB a, Semigroup a) => Monad (TheseTable a) where

96+instance (Table Expr a, Semigroup a) => Monad (TheseTable a) where

98 (>>=) = (>>-)

97 (>>=) = (>>-)

100

101−instance (Table DB a, Table DB b, Semigroup a, Semigroup b) =>

100+instance (Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>

102 Semigroup (TheseTable a b)

101 Semigroup (TheseTable a b)

103 where

102 where

104 a <> b = TheseTable

103 a <> b = TheseTable

@@ -212,11 +211,11 @@ justThereTable :: TheseTable a b -> MaybeTable b

212justThereTable = there

211justThereTable = there

213

212

214

213

215−thisTable :: Table DB b => a -> TheseTable a b

214+thisTable :: Table Expr b => a -> TheseTable a b

216thisTable a = TheseTable (justTable a) nothingTable

215thisTable a = TheseTable (justTable a) nothingTable

217

216

218

217

219−thatTable :: Table DB a => b -> TheseTable a b

218+thatTable :: Table Expr a => b -> TheseTable a b

220thatTable b = TheseTable nothingTable (justTable b)

219thatTable b = TheseTable nothingTable (justTable b)

221

220

222

221

@@ -224,7 +223,7 @@ thoseTable :: a -> b -> TheseTable a b

224thoseTable a b = TheseTable (justTable a) (justTable b)

223thoseTable a b = TheseTable (justTable a) (justTable b)

225

224

226

225

227−theseTable :: Table DB c

226+theseTable :: Table Expr c

228 => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable a b -> c

227 => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable a b -> c

229theseTable f g h TheseTable {here, there} =

228theseTable f g h TheseTable {here, there} =

230 maybeTable

229 maybeTable

src/Rel8/Table/Undefined.hs+5−4

@@ -11,16 +11,17 @@ where

11import Prelude hiding ( undefined )

13-- rel8

14+import Rel8.Expr ( Expr )

14import Rel8.Expr.Null ( snull, unsafeUnnullify )

15import Rel8.Expr.Null ( snull, unsafeUnnullify )

15−import Rel8.Schema.Context ( DB( DB ) )

16+import Rel8.Schema.Context ( Col'(..) )

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

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

17import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ) )

18import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ) )

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

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

19import Rel8.Table ( Table, fromColumns )

20import Rel8.Table ( Table, fromColumns )

22−undefined :: Table DB a => a

23+undefined :: Table Expr a => a

23undefined = fromColumns $ htabulate $ \field -> case hfield hspecs field of

24undefined = fromColumns $ htabulate $ \field -> case hfield hspecs field of

24 SSpec {nullability, info} -> case nullability of

25 SSpec {nullability, info} -> case nullability of

25− Nullable -> DB (snull Nullable info)

26+ Nullable -> DB (snull Nullable info)

26− NonNullable -> DB (unsafeUnnullify (snull Nullable info))

27+ NonNullable -> DB (unsafeUnnullify (snull Nullable info))

src/Rel8/Tabulate.hs+2−3

@@ -46,7 +46,6 @@ import Rel8.Query.Exists ( withBy, withoutBy )

46import Rel8.Query.Filter ( filter, where_ )

47import Rel8.Query.Maybe ( optional )

48import Rel8.Query.These ( alignBy )

49−import Rel8.Schema.Context ( DB )

50import Rel8.Table ( Table )

49import Rel8.Table ( Table )

51import Rel8.Table.Aggregate ( groupBy )

50import Rel8.Table.Aggregate ( groupBy )

52import Rel8.Table.Eq ( EqTable, (==:) )

51import Rel8.Table.Eq ( EqTable, (==:) )

@@ -159,12 +158,12 @@ lookup key (Tabulation query) = do

159 pure a

158 pure a

160

159

161

160

162−align :: (EqTable k, Table DB a, Table DB b)

161+align :: (EqTable k, Table Expr a, Table Expr b)

163 => Tabulation k a -> Tabulation k b -> Tabulation k (TheseTable a b)

162 => Tabulation k a -> Tabulation k b -> Tabulation k (TheseTable a b)

164align = alignWith id

163align = alignWith id

165

164

166

165

167−alignWith :: (EqTable k, Table DB a, Table DB b)

166+alignWith :: (EqTable k, Table Expr a, Table Expr b)

168 => (TheseTable a b -> c)

167 => (TheseTable a b -> c)

169 -> Tabulation k a -> Tabulation k b -> Tabulation k c

168 -> Tabulation k a -> Tabulation k b -> Tabulation k c

170alignWith f kas kbs = do

169alignWith f kas kbs = do

tests/Main.hs+15−15

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

1{-# language BlockArguments #-}

2−{-# language BlockArguments #-}

3{-# language DataKinds #-}

2{-# language DataKinds #-}

4{-# language DeriveAnyClass #-}

3{-# language DeriveAnyClass #-}

5{-# language DeriveGeneric #-}

4{-# language DeriveGeneric #-}

@@ -28,6 +27,7 @@ import Control.Monad (void)

28import Control.Monad.IO.Class ( MonadIO, liftIO )

27import Control.Monad.IO.Class ( MonadIO, liftIO )

29import Data.Bifunctor ( bimap )

28import Data.Bifunctor ( bimap )

30import Data.Foldable ( for_ )

29import Data.Foldable ( for_ )

30+import Data.Functor.Identity ( Identity )

31import Data.Int ( Int32, Int64 )

32import Data.List ( nub, sort )

33import Data.Maybe ( catMaybes )

@@ -191,9 +191,9 @@ data TestTable f = TestTable

191 deriving anyclass Rel8.Rel8able

192

193

194−deriving stock instance Eq (TestTable Rel8.Result)

194+deriving stock instance Eq (TestTable Identity)

195−deriving stock instance Ord (TestTable Rel8.Result)

195+deriving stock instance Ord (TestTable Identity)

196−deriving stock instance Show (TestTable Rel8.Result)

196+deriving stock instance Show (TestTable Identity)

197

198

199testTableSchema :: Rel8.TableSchema (TestTable Rel8.Name)

@@ -589,9 +589,9 @@ data TwoTestTables f =

589 deriving anyclass Rel8.Rel8able

590

591

592−deriving stock instance Eq (TwoTestTables Rel8.Result)

592+deriving stock instance Eq (TwoTestTables Identity)

593−deriving stock instance Ord (TwoTestTables Rel8.Result)

593+deriving stock instance Ord (TwoTestTables Identity)

594−deriving stock instance Show (TwoTestTables Rel8.Result)

594+deriving stock instance Show (TwoTestTables Identity)

595

596

597testNestedTables :: IO TmpPostgres.DB -> TestTree

@@ -624,7 +624,7 @@ testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction

624 (as, []) -> selected === (Nothing <$ as)

625 (as, bs) -> sort selected === sort (Just <$> liftA2 (,) as bs)

626 where

627− genRows :: PropertyT IO [TestTable Rel8.Result]

627+ genRows :: PropertyT IO [TestTable Identity]

628 genRows = forAll do

629 Gen.list (Range.linear 0 10) $ liftA2 TestTable (Gen.text (Range.linear 0 10) Gen.unicode) (pure True)

630

@@ -637,7 +637,7 @@ rollingBack connection =

637 (liftIO (run (sql "ROLLBACK") connection))

638

639

640−genTestTable :: Gen (TestTable Rel8.Result)

640+genTestTable :: Gen (TestTable Identity)

641genTestTable = do

642 testTableColumn1 <- Gen.text (Range.linear 0 5) Gen.alphaNum

643 testTableColumn2 <- Gen.bool

@@ -719,9 +719,9 @@ newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) }

719 deriving stock Generic

720 deriving anyclass Rel8.Rel8able

721

722−deriving stock instance Eq (HKNestedPair Rel8.Result)

722+deriving stock instance Eq (HKNestedPair Identity)

723−deriving stock instance Ord (HKNestedPair Rel8.Result)

723+deriving stock instance Ord (HKNestedPair Identity)

724−deriving stock instance Show (HKNestedPair Rel8.Result)

724+deriving stock instance Show (HKNestedPair Identity)

725

726

727testSelectNestedPairs :: IO TmpPostgres.DB -> TestTree

@@ -754,9 +754,9 @@ data NestedMaybeTable f = NestedMaybeTable

754 deriving anyclass Rel8.Rel8able

755

756

757−deriving stock instance Eq (NestedMaybeTable Rel8.Result)

757+deriving stock instance Eq (NestedMaybeTable Identity)

758−deriving stock instance Ord (NestedMaybeTable Rel8.Result)

758+deriving stock instance Ord (NestedMaybeTable Identity)

759−deriving stock instance Show (NestedMaybeTable Rel8.Result)

759+deriving stock instance Show (NestedMaybeTable Identity)

760

761

762testNestedMaybeTable :: IO TmpPostgres.DB -> TestTree