git.iko.soy/rel8
on master help sign in
Make Rel8able have kind ((X -> Type) -> Type) -> Constraint
04fdf27Shane O'Brien
rel8.cabal+1
compare with master
unifiedsplit
@@ -113,6 +113,7 @@ library
113 Rel8.Schema.Kind
113 Rel8.Schema.Kind
114 Rel8.Schema.Name
114 Rel8.Schema.Name
115 Rel8.Schema.Null
115 Rel8.Schema.Null
116+ Rel8.Schema.Result
116 Rel8.Schema.Spec
117 Rel8.Schema.Spec
117 Rel8.Schema.Spec.ConstrainDBType
118 Rel8.Schema.Spec.ConstrainDBType
118 Rel8.Schema.Spec.ConstrainType
119 Rel8.Schema.Spec.ConstrainType
src/Rel8.hs+2
@@ -235,6 +235,7 @@ module Rel8
235 , Labelable
235 , Labelable
236 , ToExprs(..)
236 , ToExprs(..)
237 , FromExprs
237 , FromExprs
238+ , Result
238 ) where
239 ) where
239
240
240-- base
241-- base
@@ -277,6 +278,7 @@ import Rel8.Schema.Generic
277import Rel8.Schema.HTable
278import Rel8.Schema.HTable
278import Rel8.Schema.Name
279import Rel8.Schema.Name
279import Rel8.Schema.Null hiding ( nullable )
280import Rel8.Schema.Null hiding ( nullable )
281+import Rel8.Schema.Result
280import Rel8.Schema.Table
282import Rel8.Schema.Table
281import Rel8.Statement.Delete
283import Rel8.Statement.Delete
282import Rel8.Statement.Insert
284import Rel8.Statement.Insert
src/Rel8/Aggregate.hs+16−8
@@ -3,9 +3,9 @@
3{-# language FlexibleContexts #-}
3{-# language FlexibleContexts #-}
4{-# language FlexibleInstances #-}
4{-# language FlexibleInstances #-}
5{-# language GADTs #-}
5{-# language GADTs #-}
6−{-# language GeneralizedNewtypeDeriving #-}
7{-# language MultiParamTypeClasses #-}
6{-# language MultiParamTypeClasses #-}
8{-# language NamedFieldPuns #-}
7{-# language NamedFieldPuns #-}
8+{-# language PolyKinds #-}
9{-# language StandaloneKindSignatures #-}
9{-# language StandaloneKindSignatures #-}
10{-# language TypeFamilies #-}
10{-# language TypeFamilies #-}
11{-# language UndecidableInstances #-}
11{-# language UndecidableInstances #-}
@@ -37,13 +37,14 @@ import Rel8.Schema.Context.Label ( Labelable(..) )
37import Rel8.Schema.HTable ( hfield, htabulate, htabulateA, hspecs )
37import Rel8.Schema.HTable ( hfield, htabulate, htabulateA, hspecs )
38import Rel8.Schema.Name ( Name )
38import Rel8.Schema.Name ( Name )
39import Rel8.Schema.Null ( Sql )
39import Rel8.Schema.Null ( Sql )
40+import Rel8.Schema.Result ( Result )
40import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
41import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
41import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
42import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
42import Rel8.Table.Recontextualize ( Recontextualize )
43import Rel8.Table.Recontextualize ( Recontextualize )
43import Rel8.Type ( DBType )
44import Rel8.Type ( DBType )
44
45
45-- semigroupoids
46-- semigroupoids
46−import Data.Functor.Apply ( Apply, WrappedApplicative(..) )
47+import Data.Functor.Apply ( Apply, (<.>) )
47
48
48
49
49-- | An @Aggregate a@ describes how to aggregate @Table@s of type @a@. You can
50-- | An @Aggregate a@ describes how to aggregate @Table@s of type @a@. You can
@@ -51,10 +52,17 @@ import Data.Functor.Apply ( Apply, WrappedApplicative(..) )
51-- @Aggregate@ is almost an 'Applicative' functor - but there is no 'pure'
52-- @Aggregate@ is almost an 'Applicative' functor - but there is no 'pure'
52-- operation. This means 'Aggregate' is an instance of 'Apply', and you can
53-- operation. This means 'Aggregate' is an instance of 'Apply', and you can
53-- combine @Aggregate@s using the @<.>@ combinator.
54-- combine @Aggregate@s using the @<.>@ combinator.
54−type Aggregate :: Type -> Type
55+type Aggregate :: k -> Type
56+data Aggregate a where
55−newtype Aggregate a = Aggregate (Opaleye.Aggregator () a)
57+ Aggregate :: !(Opaleye.Aggregator () a) -> Aggregate a
56− deriving newtype Functor
58+
57− deriving Apply via (WrappedApplicative (Opaleye.Aggregator ()))
59+
60+instance Functor Aggregate where
61+ fmap f (Aggregate a) = Aggregate (fmap f a)
62+
63+
64+instance Apply Aggregate where
65+ Aggregate f <.> Aggregate a = Aggregate (f <*> a)
58
66
59
67
60instance Interpretation Aggregate where
68instance Interpretation Aggregate where
@@ -84,7 +92,7 @@ instance Sql DBType a =>
84
92
85
93
86instance Sql DBType a =>
94instance Sql DBType a =>
87− Recontextualize Aggregate Identity (Aggregate (Expr a)) (Identity a)
95+ Recontextualize Aggregate Result (Aggregate (Expr a)) (Identity a)
88
96
89
97
90instance Sql DBType a =>
98instance Sql DBType a =>
@@ -96,7 +104,7 @@ instance Sql DBType a =>
96
104
97
105
98instance Sql DBType a =>
106instance Sql DBType a =>
99− Recontextualize Identity Aggregate (Identity a) (Aggregate (Expr a))
107+ Recontextualize Result Aggregate (Identity a) (Aggregate (Expr a))
100
108
101
109
102instance Sql DBType a =>
110instance Sql DBType a =>
src/Rel8/Expr.hs+11−5
@@ -3,8 +3,10 @@
3{-# language FlexibleInstances #-}
3{-# language FlexibleInstances #-}
4{-# language GADTs #-}
4{-# language GADTs #-}
5{-# language MultiParamTypeClasses #-}
5{-# language MultiParamTypeClasses #-}
6+{-# language PolyKinds #-}
6{-# language RoleAnnotations #-}
7{-# language RoleAnnotations #-}
7{-# language ScopedTypeVariables #-}
8{-# language ScopedTypeVariables #-}
9+{-# language StandaloneDeriving #-}
8{-# language StandaloneKindSignatures #-}
10{-# language StandaloneKindSignatures #-}
9{-# language TypeApplications #-}
11{-# language TypeApplications #-}
10{-# language TypeFamilies #-}
12{-# language TypeFamilies #-}
@@ -39,6 +41,7 @@ import Rel8.Schema.Context ( Interpretation, Col )
39import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
41import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
40import Rel8.Schema.HTable.Type ( HType( HType ) )
42import Rel8.Schema.HTable.Type ( HType( HType ) )
41import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )
43import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )
44+import Rel8.Schema.Result ( Result )
42import Rel8.Schema.Spec ( Spec( Spec ) )
45import Rel8.Schema.Spec ( Spec( Spec ) )
43import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
46import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
44import Rel8.Table.Recontextualize ( Recontextualize )
47import Rel8.Table.Recontextualize ( Recontextualize )
@@ -50,9 +53,12 @@ import Rel8.Type.Semigroup ( DBSemigroup, (<>.) )
50
53
51-- | Typed SQL expressions.
54-- | Typed SQL expressions.
52type role Expr representational
55type role Expr representational
53−type Expr :: Type -> Type
56+type Expr :: k -> Type
57+data Expr a where
54−newtype Expr a = Expr Opaleye.PrimExpr
58+ Expr :: k ~ Type => !Opaleye.PrimExpr -> Expr (a :: k)
59+
60+
55− deriving stock Show
61+deriving stock instance Show (Expr a)
56
62
57
63
58instance Sql DBSemigroup a => Semigroup (Expr a) where
64instance Sql DBSemigroup a => Semigroup (Expr a) where
@@ -111,10 +117,10 @@ instance Sql DBType a => Table Expr (Expr a) where
111instance Sql DBType a => Recontextualize Expr Expr (Expr a) (Expr a)
117instance Sql DBType a => Recontextualize Expr Expr (Expr a) (Expr a)
112
118
113
119
114−instance Sql DBType a => Recontextualize Expr Identity (Expr a) (Identity a)
120+instance Sql DBType a => Recontextualize Expr Result (Expr a) (Identity a)
115
121
116
122
117−instance Sql DBType a => Recontextualize Identity Expr (Identity a) (Expr a)
123+instance Sql DBType a => Recontextualize Result Expr (Identity a) (Expr a)
118
124
119
125
120instance Labelable Expr where
126instance Labelable Expr where
src/Rel8/Expr.hs-boot+5−2
@@ -1,3 +1,5 @@
1+{-# language GADTs #-}
2+{-# language PolyKinds #-}
1{-# language RoleAnnotations #-}
3{-# language RoleAnnotations #-}
2{-# language StandaloneKindSignatures #-}
4{-# language StandaloneKindSignatures #-}
3
5
@@ -15,5 +17,6 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
15
17
16
18
17type role Expr representational
19type role Expr representational
18−type Expr :: Type -> Type
20+type Expr :: k -> Type
21+data Expr a where
19−newtype Expr a = Expr Opaleye.PrimExpr
22+ Expr :: k ~ Type => !Opaleye.PrimExpr -> Expr (a :: k)
src/Rel8/Expr/Bool.hs+4−2
@@ -1,3 +1,5 @@
1+{-# language GADTs #-}
2+
1module Rel8.Expr.Bool
3module Rel8.Expr.Bool
2 ( false, true
4 ( false, true
3 , (&&.), (||.), not_
5 , (&&.), (||.), not_
@@ -17,7 +19,7 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
17
19
18-- rel8
20-- rel8
19import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
21import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
20−import Rel8.Expr.Opaleye ( mapPrimExpr, zipPrimExprsWith )
22+import Rel8.Expr.Opaleye ( mapPrimExpr, toPrimExpr, zipPrimExprsWith )
21import Rel8.Expr.Serialize ( litExpr )
23import Rel8.Expr.Serialize ( litExpr )
22
24
23
25
@@ -75,7 +77,7 @@ caseExpr :: [(Expr Bool, Expr a)] -> Expr a -> Expr a
75caseExpr branches (Expr fallback) =
77caseExpr branches (Expr fallback) =
76 Expr $ Opaleye.CaseExpr (map go branches) fallback
78 Expr $ Opaleye.CaseExpr (map go branches) fallback
77 where
79 where
78− go (Expr condition, Expr value) = (condition, value)
80+ go (condition, value) = (toPrimExpr condition, toPrimExpr value)
79
81
80
82
81-- | Convert a @Expr (Maybe Bool)@ to a @Expr Bool@ by treating @Nothing@ as
83-- | Convert a @Expr (Maybe Bool)@ to a @Expr Bool@ by treating @Nothing@ as
src/Rel8/Expr/Null.hs+1
@@ -78,6 +78,7 @@ liftOpNull :: DBType c
78liftOpNull f ma mb =
78liftOpNull f ma mb =
79 boolExpr (unsafeLiftOpNull f ma mb) null
79 boolExpr (unsafeLiftOpNull f ma mb) null
80 (isNull ma ||. isNull mb)
80 (isNull ma ||. isNull mb)
81+{-# INLINABLE liftOpNull #-}
81
82
82
83
83snull :: TypeInformation a -> Expr (Maybe a)
84snull :: TypeInformation a -> Expr (Maybe a)
src/Rel8/Expr/Ord.hs+4−3
@@ -23,7 +23,7 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
23import Rel8.Expr ( Expr( Expr ) )
23import Rel8.Expr ( Expr( Expr ) )
24import Rel8.Expr.Bool ( (&&.), (||.), coalesce )
24import Rel8.Expr.Bool ( (&&.), (||.), coalesce )
25import Rel8.Expr.Null ( isNull, isNonNull, nullable, unsafeLiftOpNull )
25import Rel8.Expr.Null ( isNull, isNonNull, nullable, unsafeLiftOpNull )
26−import Rel8.Expr.Opaleye ( zipPrimExprsWith )
26+import Rel8.Expr.Opaleye ( toPrimExpr, zipPrimExprsWith )
27import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql )
27import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql )
28import qualified Rel8.Schema.Null as Schema ( nullable )
28import qualified Rel8.Schema.Null as Schema ( nullable )
29import Rel8.Type.Ord ( DBOrd )
29import Rel8.Type.Ord ( DBOrd )
@@ -122,7 +122,7 @@ leastExpr ma mb = case Schema.nullable @a of
122 Null -> nullable ma (\a -> nullable mb (least_ a) mb) ma
122 Null -> nullable ma (\a -> nullable mb (least_ a) mb) ma
123 NotNull -> least_ ma mb
123 NotNull -> least_ ma mb
124 where
124 where
125− least_ (Expr a) (Expr b) = Expr (Opaleye.FunExpr "LEAST" [a, b])
125+ least_ a b = Expr (Opaleye.FunExpr "LEAST" [toPrimExpr a, toPrimExpr b])
126
126
127
127
128-- | Given two expressions, return the expression that sorts greater than the
128-- | Given two expressions, return the expression that sorts greater than the
@@ -134,4 +134,5 @@ greatestExpr ma mb = case Schema.nullable @a of
134 Null -> nullable mb (\a -> nullable ma (greatest_ a) mb) ma
134 Null -> nullable mb (\a -> nullable ma (greatest_ a) mb) ma
135 NotNull -> greatest_ ma mb
135 NotNull -> greatest_ ma mb
136 where
136 where
137+ greatest_ a b =
137− greatest_ (Expr a) (Expr b) = Expr (Opaleye.FunExpr "GREATEST" [a, b])
138+ Expr (Opaleye.FunExpr "GREATEST" [toPrimExpr a, toPrimExpr b])
src/Rel8/Schema/Context.hs+4−4
@@ -9,12 +9,12 @@ module Rel8.Schema.Context
9where
9where
10
10
11-- base
11-- base
12−import Data.Functor.Identity ( Identity )
13import Data.Kind ( Constraint )
12import Data.Kind ( Constraint )
14import Prelude ()
13import Prelude ()
15
14
16-- rel8
15-- rel8
17import Rel8.Schema.Kind ( Context, HContext )
16import Rel8.Schema.Kind ( Context, HContext )
17+import Rel8.Schema.Result ( Result )
18import Rel8.Schema.Spec ( Spec( Spec ) )
18import Rel8.Schema.Spec ( Spec( Spec ) )
19
19
20
20
@@ -23,6 +23,6 @@ class Interpretation context where
23 data Col context :: HContext
23 data Col context :: HContext
24
24
25
25
26−instance Interpretation Identity where
26+instance Interpretation Result where
27− data Col Identity _spec where
27+ data Col Result _spec where
28− Result :: a -> Col Identity ('Spec labels necessity a)
28+ Result :: a -> Col Result ('Spec labels necessity a)
src/Rel8/Schema/Context/Label.hs+2−2
@@ -11,7 +11,6 @@ module Rel8.Schema.Context.Label
11where
11where
12
12
13-- base
13-- base
14−import Data.Functor.Identity ( Identity )
15import Data.Kind ( Constraint )
14import Data.Kind ( Constraint )
16import Prelude hiding ( null )
15import Prelude hiding ( null )
17
16
@@ -20,6 +19,7 @@ import Rel8.Schema.Context ( Interpretation, Col(..) )
20import Rel8.Schema.Dict ( Dict( Dict ) )
19import Rel8.Schema.Dict ( Dict( Dict ) )
21import Rel8.Schema.Kind ( Context, HContext )
20import Rel8.Schema.Kind ( Context, HContext )
22import Rel8.Schema.Spec ( Spec( Spec ) )
21import Rel8.Schema.Spec ( Spec( Spec ) )
22+import Rel8.Schema.Result ( Result )
23import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
23import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
24
24
25
25
@@ -34,7 +34,7 @@ class Interpretation context => Labelable context where
34 -> Col context ('Spec labels necessity a)
34 -> Col context ('Spec labels necessity a)
35
35
36
36
37−instance Labelable Identity where
37+instance Labelable Result where
38 labeler (Result a) = Result a
38 labeler (Result a) = Result a
39 unlabeler (Result a) = Result a
39 unlabeler (Result a) = Result a
40
40
src/Rel8/Schema/Field.hs+29−34
@@ -19,7 +19,6 @@ where
19
19
20-- base
20-- base
21import Data.Bifunctor ( Bifunctor, bimap )
21import Data.Bifunctor ( Bifunctor, bimap )
22−import Data.Functor.Identity ( Identity )
23import Data.Kind ( Constraint, Type )
22import Data.Kind ( Constraint, Type )
24import Data.List.NonEmpty ( NonEmpty )
23import Data.List.NonEmpty ( NonEmpty )
25import Prelude
24import Prelude
@@ -45,6 +44,7 @@ import Rel8.Schema.Insert ( Insert, Col(..) )
45import qualified Rel8.Schema.Kind as K
44import qualified Rel8.Schema.Kind as K
46import Rel8.Schema.Name ( Name(..), Col(..) )
45import Rel8.Schema.Name ( Name(..), Col(..) )
47import Rel8.Schema.Null ( Sql )
46import Rel8.Schema.Null ( Sql )
47+import Rel8.Schema.Result ( Result )
48import Rel8.Schema.Spec ( Spec( Spec ) )
48import Rel8.Schema.Spec ( Spec( Spec ) )
49import Rel8.Table
49import Rel8.Table
50 ( Table, Columns, Context, fromColumns, toColumns
50 ( Table, Columns, Context, fromColumns, toColumns
@@ -65,12 +65,12 @@ import Data.These ( These )
65type Field :: K.Context -> Necessity -> Type -> Type
65type Field :: K.Context -> Necessity -> Type -> Type
66type family Field context necessity a where
66type family Field context necessity a where
67 Field (Reify context) necessity a = AField context necessity a
67 Field (Reify context) necessity a = AField context necessity a
68− Field Identity _necessity a = a
68+ Field Aggregate _necessity a = Aggregate (Expr a)
69 Field Expr _necessity a = Expr a
69 Field Expr _necessity a = Expr a
70 Field Insert 'Required a = Expr a
70 Field Insert 'Required a = Expr a
71 Field Insert 'Optional a = Maybe (Expr a)
71 Field Insert 'Optional a = Maybe (Expr a)
72− Field Aggregate _necessity a = Aggregate (Expr a)
72+ Field Name _necessity a = Name a
73− Field context _necessity a = context a
73+ Field Result _necessity a = a
74
74
75
75
76type HEither :: K.Context -> Type -> Type -> Type
76type HEither :: K.Context -> Type -> Type -> Type
@@ -78,10 +78,9 @@ type family HEither context where
78 HEither (Reify context) = AHEither context
78 HEither (Reify context) = AHEither context
79 HEither Aggregate = EitherTable
79 HEither Aggregate = EitherTable
80 HEither Expr = EitherTable
80 HEither Expr = EitherTable
81− HEither Identity = Either
82 HEither Insert = EitherTable
81 HEither Insert = EitherTable
83 HEither Name = EitherTable
82 HEither Name = EitherTable
84− HEither _ = Either
83+ HEither Result = Either
85
84
86
85
87type HList :: K.Context -> Type -> Type
86type HList :: K.Context -> Type -> Type
@@ -89,10 +88,9 @@ type family HList context where
89 HList (Reify context) = AHList context
88 HList (Reify context) = AHList context
90 HList Aggregate = ListTable
89 HList Aggregate = ListTable
91 HList Expr = ListTable
90 HList Expr = ListTable
92− HList Identity = []
93 HList Insert = ListTable
91 HList Insert = ListTable
94 HList Name = ListTable
92 HList Name = ListTable
95− HList _ = []
93+ HList Result = []
96
94
97
95
98type HMaybe :: K.Context -> Type -> Type
96type HMaybe :: K.Context -> Type -> Type
@@ -100,10 +98,9 @@ type family HMaybe context where
100 HMaybe (Reify context) = AHMaybe context
98 HMaybe (Reify context) = AHMaybe context
101 HMaybe Aggregate = MaybeTable
99 HMaybe Aggregate = MaybeTable
102 HMaybe Expr = MaybeTable
100 HMaybe Expr = MaybeTable
103− HMaybe Identity = Maybe
104 HMaybe Insert = MaybeTable
101 HMaybe Insert = MaybeTable
105 HMaybe Name = MaybeTable
102 HMaybe Name = MaybeTable
106− HMaybe _ = Maybe
103+ HMaybe Result = Maybe
107
104
108
105
109type HNonEmpty :: K.Context -> Type -> Type
106type HNonEmpty :: K.Context -> Type -> Type
@@ -111,10 +108,9 @@ type family HNonEmpty context where
111 HNonEmpty (Reify context) = AHNonEmpty context
108 HNonEmpty (Reify context) = AHNonEmpty context
112 HNonEmpty Aggregate = NonEmptyTable
109 HNonEmpty Aggregate = NonEmptyTable
113 HNonEmpty Expr = NonEmptyTable
110 HNonEmpty Expr = NonEmptyTable
114− HNonEmpty Identity = NonEmpty
115 HNonEmpty Insert = NonEmptyTable
111 HNonEmpty Insert = NonEmptyTable
116 HNonEmpty Name = NonEmptyTable
112 HNonEmpty Name = NonEmptyTable
117− HNonEmpty _ = NonEmpty
113+ HNonEmpty Result = NonEmpty
118
114
119
115
120type HThese :: K.Context -> Type -> Type -> Type
116type HThese :: K.Context -> Type -> Type -> Type
@@ -122,10 +118,9 @@ type family HThese context where
122 HThese (Reify context) = AHThese context
118 HThese (Reify context) = AHThese context
123 HThese Aggregate = TheseTable
119 HThese Aggregate = TheseTable
124 HThese Expr = TheseTable
120 HThese Expr = TheseTable
125− HThese Identity = These
126 HThese Insert = TheseTable
121 HThese Insert = TheseTable
127 HThese Name = TheseTable
122 HThese Name = TheseTable
128− HThese _ = These
123+ HThese Result = These
129
124
130
125
131type AField :: K.Context -> Necessity -> Type -> Type
126type AField :: K.Context -> Necessity -> Type -> Type
@@ -304,9 +299,9 @@ type SContext :: K.Context -> Type
304data SContext context where
299data SContext context where
305 SAggregate :: SContext Aggregate
300 SAggregate :: SContext Aggregate
306 SExpr :: SContext Expr
301 SExpr :: SContext Expr
307− SIdentity :: SContext Identity
308 SInsert :: SContext Insert
302 SInsert :: SContext Insert
309 SName :: SContext Name
303 SName :: SContext Name
304+ SResult :: SContext Result
310 SReify :: SContext context -> SContext (Reify context)
305 SReify :: SContext context -> SContext (Reify context)
311
306
312
307
@@ -323,8 +318,8 @@ instance Reifiable Expr where
323 contextSing = SExpr
318 contextSing = SExpr
324
319
325
320
326−instance Reifiable Identity where
321+instance Reifiable Result where
327− contextSing = SIdentity
322+ contextSing = SResult
328
323
329
324
330instance Reifiable Insert where
325instance Reifiable Insert where
@@ -359,7 +354,7 @@ sfromColumn :: ()
359sfromColumn = \case
354sfromColumn = \case
360 SAggregate -> \(Aggregation a) -> AField a
355 SAggregate -> \(Aggregation a) -> AField a
361 SExpr -> \(DB a) -> AField a
356 SExpr -> \(DB a) -> AField a
362− SIdentity -> \(Result a) -> AField a
357+ SResult -> \(Result a) -> AField a
363 SInsert -> \case
358 SInsert -> \case
364 RequiredInsert a -> AField a
359 RequiredInsert a -> AField a
365 OptionalInsert a -> AField a
360 OptionalInsert a -> AField a
@@ -375,7 +370,7 @@ stoColumn :: ()
375stoColumn = \case
370stoColumn = \case
376 SAggregate -> \_ (AField a) -> Aggregation a
371 SAggregate -> \_ (AField a) -> Aggregation a
377 SExpr -> \_ (AField a) -> DB a
372 SExpr -> \_ (AField a) -> DB a
378− SIdentity -> \_ (AField a) -> Result a
373+ SResult -> \_ (AField a) -> Result a
379 SInsert -> \case
374 SInsert -> \case
380 SRequired -> \(AField a) -> RequiredInsert a
375 SRequired -> \(AField a) -> RequiredInsert a
381 SOptional -> \(AField a) -> OptionalInsert a
376 SOptional -> \(AField a) -> OptionalInsert a
@@ -393,7 +388,7 @@ sbimapEither :: ()
393sbimapEither = \case
388sbimapEither = \case
394 SAggregate -> \f g (AHEither a) -> AHEither (bimap f g a)
389 SAggregate -> \f g (AHEither a) -> AHEither (bimap f g a)
395 SExpr -> \f g (AHEither a) -> AHEither (bimap f g a)
390 SExpr -> \f g (AHEither a) -> AHEither (bimap f g a)
396− SIdentity -> \f g (AHEither a) -> AHEither (bimap f g a)
391+ SResult -> \f g (AHEither a) -> AHEither (bimap f g a)
397 SInsert -> \f g (AHEither a) -> AHEither (bimap f g a)
392 SInsert -> \f g (AHEither a) -> AHEither (bimap f g a)
398 SName -> \f g (AHEither a) -> AHEither (bimap f g a)
393 SName -> \f g (AHEither a) -> AHEither (bimap f g a)
399 SReify context -> \f g (AHEither a) -> AHEither (sbimapEither context f g a)
394 SReify context -> \f g (AHEither a) -> AHEither (sbimapEither context f g a)
@@ -414,7 +409,7 @@ sfromColumnsEither = \case
414 bimap (fromColumns . hreify) (fromColumns . hreify) .
409 bimap (fromColumns . hreify) (fromColumns . hreify) .
415 fromColumns .
410 fromColumns .
416 hunreify
411 hunreify
417− SIdentity ->
412+ SResult ->
418 AHEither .
413 AHEither .
419 bimap (fromColumns . hreify) (fromColumns . hreify) .
414 bimap (fromColumns . hreify) (fromColumns . hreify) .
420 fromColumns .
415 fromColumns .
@@ -451,7 +446,7 @@ stoColumnsEither = \case
451 toColumns .
446 toColumns .
452 bimap (hunreify . toColumns) (hunreify . toColumns) .
447 bimap (hunreify . toColumns) (hunreify . toColumns) .
453 (\(AHEither a) -> a)
448 (\(AHEither a) -> a)
454− SIdentity ->
449+ SResult ->
455 hreify .
450 hreify .
456 toColumns .
451 toColumns .
457 bimap (hunreify . toColumns) (hunreify . toColumns) .
452 bimap (hunreify . toColumns) (hunreify . toColumns) .
@@ -482,7 +477,7 @@ smapList :: Congruent a b
482smapList = \case
477smapList = \case
483 SAggregate -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))
478 SAggregate -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))
484 SExpr -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))
479 SExpr -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))
485− SIdentity -> \f _ (AHList as) -> AHList (fmap f as)
480+ SResult -> \f _ (AHList as) -> AHList (fmap f as)
486 SInsert -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))
481 SInsert -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))
487 SName -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))
482 SName -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))
488 SReify context -> \f g (AHList as) -> AHList (smapList context f g as)
483 SReify context -> \f g (AHList as) -> AHList (smapList context f g as)
@@ -495,7 +490,7 @@ sfromColumnsList :: Table (Reify context) a
495sfromColumnsList = \case
490sfromColumnsList = \case
496 SAggregate -> AHList . ListTable
491 SAggregate -> AHList . ListTable
497 SExpr -> AHList . ListTable
492 SExpr -> AHList . ListTable
498− SIdentity -> AHList . fmap (fromColumns . hreify) . fromColumns . hunreify
493+ SResult -> AHList . fmap (fromColumns . hreify) . fromColumns . hunreify
499 SInsert -> AHList . ListTable
494 SInsert -> AHList . ListTable
500 SName -> AHList . ListTable
495 SName -> AHList . ListTable
501 SReify context ->
496 SReify context ->
@@ -512,7 +507,7 @@ stoColumnsList :: Table (Reify context) a
512stoColumnsList = \case
507stoColumnsList = \case
513 SAggregate -> \(AHList (ListTable a)) -> a
508 SAggregate -> \(AHList (ListTable a)) -> a
514 SExpr -> \(AHList (ListTable a)) -> a
509 SExpr -> \(AHList (ListTable a)) -> a
515− SIdentity ->
510+ SResult ->
516 hreify . toColumns . fmap (hunreify . toColumns) . (\(AHList a) -> a)
511 hreify . toColumns . fmap (hunreify . toColumns) . (\(AHList a) -> a)
517 SInsert -> \(AHList (ListTable a)) -> a
512 SInsert -> \(AHList (ListTable a)) -> a
518 SName -> \(AHList (ListTable a)) -> a
513 SName -> \(AHList (ListTable a)) -> a
@@ -531,7 +526,7 @@ smapMaybe :: ()
531smapMaybe = \case
526smapMaybe = \case
532 SAggregate -> \f (AHMaybe a) -> AHMaybe (fmap f a)
527 SAggregate -> \f (AHMaybe a) -> AHMaybe (fmap f a)
533 SExpr -> \f (AHMaybe a) -> AHMaybe (fmap f a)
528 SExpr -> \f (AHMaybe a) -> AHMaybe (fmap f a)
534− SIdentity -> \f (AHMaybe a) -> AHMaybe (fmap f a)
529+ SResult -> \f (AHMaybe a) -> AHMaybe (fmap f a)
535 SInsert -> \f (AHMaybe a) -> AHMaybe (fmap f a)
530 SInsert -> \f (AHMaybe a) -> AHMaybe (fmap f a)
536 SName -> \f (AHMaybe a) -> AHMaybe (fmap f a)
531 SName -> \f (AHMaybe a) -> AHMaybe (fmap f a)
537 SReify context -> \f (AHMaybe a) -> AHMaybe (smapMaybe context f a)
532 SReify context -> \f (AHMaybe a) -> AHMaybe (smapMaybe context f a)
@@ -544,7 +539,7 @@ sfromColumnsMaybe :: Table (Reify context) a
544sfromColumnsMaybe = \case
539sfromColumnsMaybe = \case
545 SAggregate -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
540 SAggregate -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
546 SExpr -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
541 SExpr -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
547− SIdentity -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
542+ SResult -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
548 SInsert -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
543 SInsert -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
549 SName -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
544 SName -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
550 SReify context ->
545 SReify context ->
@@ -563,7 +558,7 @@ stoColumnsMaybe = \case
563 hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)
558 hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)
564 SExpr ->
559 SExpr ->
565 hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)
560 hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)
566− SIdentity ->
561+ SResult ->
567 hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)
562 hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)
568 SInsert ->
563 SInsert ->
569 hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)
564 hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)
@@ -585,7 +580,7 @@ smapNonEmpty :: Congruent a b
585smapNonEmpty = \case
580smapNonEmpty = \case
586 SAggregate -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))
581 SAggregate -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))
587 SExpr -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))
582 SExpr -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))
588− SIdentity -> \f _ (AHNonEmpty as) -> AHNonEmpty (fmap f as)
583+ SResult -> \f _ (AHNonEmpty as) -> AHNonEmpty (fmap f as)
589 SInsert -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))
584 SInsert -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))
590 SName -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))
585 SName -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))
591 SReify context -> \f g (AHNonEmpty as) -> AHNonEmpty (smapNonEmpty context f g as)
586 SReify context -> \f g (AHNonEmpty as) -> AHNonEmpty (smapNonEmpty context f g as)
@@ -598,7 +593,7 @@ sfromColumnsNonEmpty :: Table (Reify context) a
598sfromColumnsNonEmpty = \case
593sfromColumnsNonEmpty = \case
599 SAggregate -> AHNonEmpty . NonEmptyTable
594 SAggregate -> AHNonEmpty . NonEmptyTable
600 SExpr -> AHNonEmpty . NonEmptyTable
595 SExpr -> AHNonEmpty . NonEmptyTable
601− SIdentity ->
596+ SResult ->
602 AHNonEmpty . fmap (fromColumns . hreify) . fromColumns . hunreify
597 AHNonEmpty . fmap (fromColumns . hreify) . fromColumns . hunreify
603 SInsert -> AHNonEmpty . NonEmptyTable
598 SInsert -> AHNonEmpty . NonEmptyTable
604 SName -> AHNonEmpty . NonEmptyTable
599 SName -> AHNonEmpty . NonEmptyTable
@@ -616,7 +611,7 @@ stoColumnsNonEmpty :: Table (Reify context) a
616stoColumnsNonEmpty = \case
611stoColumnsNonEmpty = \case
617 SAggregate -> \(AHNonEmpty (NonEmptyTable a)) -> a
612 SAggregate -> \(AHNonEmpty (NonEmptyTable a)) -> a
618 SExpr -> \(AHNonEmpty (NonEmptyTable a)) -> a
613 SExpr -> \(AHNonEmpty (NonEmptyTable a)) -> a
619− SIdentity ->
614+ SResult ->
620 hreify . toColumns . fmap (hunreify . toColumns) . (\(AHNonEmpty a) -> a)
615 hreify . toColumns . fmap (hunreify . toColumns) . (\(AHNonEmpty a) -> a)
621 SInsert -> \(AHNonEmpty (NonEmptyTable a)) -> a
616 SInsert -> \(AHNonEmpty (NonEmptyTable a)) -> a
622 SName -> \(AHNonEmpty (NonEmptyTable a)) -> a
617 SName -> \(AHNonEmpty (NonEmptyTable a)) -> a
@@ -636,7 +631,7 @@ sbimapThese :: ()
636sbimapThese = \case
631sbimapThese = \case
637 SAggregate -> \f g (AHThese a) -> AHThese (bimap f g a)
632 SAggregate -> \f g (AHThese a) -> AHThese (bimap f g a)
638 SExpr -> \f g (AHThese a) -> AHThese (bimap f g a)
633 SExpr -> \f g (AHThese a) -> AHThese (bimap f g a)
639− SIdentity -> \f g (AHThese a) -> AHThese (bimap f g a)
634+ SResult -> \f g (AHThese a) -> AHThese (bimap f g a)
640 SInsert -> \f g (AHThese a) -> AHThese (bimap f g a)
635 SInsert -> \f g (AHThese a) -> AHThese (bimap f g a)
641 SName -> \f g (AHThese a) -> AHThese (bimap f g a)
636 SName -> \f g (AHThese a) -> AHThese (bimap f g a)
642 SReify context -> \f g (AHThese a) -> AHThese (sbimapThese context f g a)
637 SReify context -> \f g (AHThese a) -> AHThese (sbimapThese context f g a)
@@ -657,7 +652,7 @@ sfromColumnsThese = \case
657 bimap (fromColumns . hreify) (fromColumns . hreify) .
652 bimap (fromColumns . hreify) (fromColumns . hreify) .
658 fromColumns .
653 fromColumns .
659 hunreify
654 hunreify
660− SIdentity ->
655+ SResult ->
661 AHThese .
656 AHThese .
662 bimap (fromColumns . hreify) (fromColumns . hreify) .
657 bimap (fromColumns . hreify) (fromColumns . hreify) .
663 fromColumns .
658 fromColumns .
@@ -694,7 +689,7 @@ stoColumnsThese = \case
694 toColumns .
689 toColumns .
695 bimap (hunreify . toColumns) (hunreify . toColumns) .
690 bimap (hunreify . toColumns) (hunreify . toColumns) .
696 (\(AHThese a) -> a)
691 (\(AHThese a) -> a)
697− SIdentity ->
692+ SResult ->
698 hreify .
693 hreify .
699 toColumns .
694 toColumns .
700 bimap (hunreify . toColumns) (hunreify . toColumns) .
695 bimap (hunreify . toColumns) (hunreify . toColumns) .
src/Rel8/Schema/Generic.hs+1−2
@@ -43,7 +43,6 @@ import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
43import Rel8.Schema.HTable.Pair ( HPair(..) )
43import Rel8.Schema.HTable.Pair ( HPair(..) )
44import qualified Rel8.Schema.Kind as K
44import qualified Rel8.Schema.Kind as K
45import Rel8.Schema.Name ( Name )
45import Rel8.Schema.Name ( Name )
46−import Rel8.Schema.Spec ( KTable )
47import Rel8.Table
46import Rel8.Table
48 ( Table, Columns, Context, fromColumns, toColumns
47 ( Table, Columns, Context, fromColumns, toColumns
49 )
48 )
@@ -104,7 +103,7 @@ instance
104-- data MyType f = MyType { fieldA :: Column f T }
103-- data MyType f = MyType { fieldA :: Column f T }
105-- deriving ( GHC.Generics.Generic, Rel8able )
104-- deriving ( GHC.Generics.Generic, Rel8able )
106-- @
105-- @
107−type Rel8able :: KTable -> Constraint
106+type Rel8able :: K.Table -> Constraint
108class HTable (GRep t) => Rel8able t where
107class HTable (GRep t) => Rel8able t where
109 gfromColumns :: (Labelable context, Reifiable context)
108 gfromColumns :: (Labelable context, Reifiable context)
110 => GRep t (Col (Reify context)) -> t (Reify context)
109 => GRep t (Col (Reify context)) -> t (Reify context)
src/Rel8/Schema/Insert.hs+6−5
@@ -6,6 +6,7 @@
6{-# language LambdaCase #-}
6{-# language LambdaCase #-}
7{-# language MultiParamTypeClasses #-}
7{-# language MultiParamTypeClasses #-}
8{-# language NamedFieldPuns #-}
8{-# language NamedFieldPuns #-}
9+{-# language PolyKinds #-}
9{-# language StandaloneKindSignatures #-}
10{-# language StandaloneKindSignatures #-}
10{-# language TypeFamilies #-}
11{-# language TypeFamilies #-}
11{-# language UndecidableInstances #-}
12{-# language UndecidableInstances #-}
@@ -36,9 +37,9 @@ import Rel8.Schema.Context.Nullify
36 , runTag, unnull
37 , runTag, unnull
37 )
38 )
38import Rel8.Schema.HTable.Type ( HType( HType ) )
39import Rel8.Schema.HTable.Type ( HType( HType ) )
39−import qualified Rel8.Schema.Kind as K
40import Rel8.Schema.Name ( Name, Selects )
40import Rel8.Schema.Name ( Name, Selects )
41import Rel8.Schema.Null ( Sql )
41import Rel8.Schema.Null ( Sql )
42+import Rel8.Schema.Result ( Result )
42import Rel8.Schema.Spec ( SSpec(SSpec, nullity), Spec(Spec) )
43import Rel8.Schema.Spec ( SSpec(SSpec, nullity), Spec(Spec) )
43import Rel8.Schema.Table ( TableSchema )
44import Rel8.Schema.Table ( TableSchema )
44import Rel8.Statement.Returning ( Returning )
45import Rel8.Statement.Returning ( Returning )
@@ -56,7 +57,7 @@ data OnConflict
56
57
57
58
58-- | The constituent parts of a SQL @INSERT@ statement.
59-- | The constituent parts of a SQL @INSERT@ statement.
59−type Insert :: K.Context
60+type Insert :: k -> Type
60data Insert a where
61data Insert a where
61 Insert :: (Selects names exprs, Inserts exprs inserts) =>
62 Insert :: (Selects names exprs, Inserts exprs inserts) =>
62 { into :: TableSchema names
63 { into :: TableSchema names
@@ -78,7 +79,7 @@ instance Interpretation Insert where
78 OptionalInsert :: Maybe (Expr a) -> Col Insert ('Spec labels 'Optional a)
79 OptionalInsert :: Maybe (Expr a) -> Col Insert ('Spec labels 'Optional a)
79
80
80
81
81−type Insertion :: K.Context
82+type Insertion :: Type -> Type
82newtype Insertion a = Insertion (Expr a)
83newtype Insertion a = Insertion (Expr a)
83
84
84
85
@@ -98,7 +99,7 @@ instance Sql DBType a => Recontextualize Expr Insert (Expr a) (Insertion a)
98
99
99
100
100instance Sql DBType a =>
101instance Sql DBType a =>
101− Recontextualize Identity Insert (Identity a) (Insertion a)
102+ Recontextualize Result Insert (Identity a) (Insertion a)
102
103
103
104
104instance Sql DBType a =>
105instance Sql DBType a =>
@@ -109,7 +110,7 @@ instance Sql DBType a => Recontextualize Insert Expr (Insertion a) (Expr a)
109
110
110
111
111instance Sql DBType a =>
112instance Sql DBType a =>
112− Recontextualize Insert Identity (Insertion a) (Identity a)
113+ Recontextualize Insert Result (Insertion a) (Identity a)
113
114
114
115
115instance Sql DBType a => Recontextualize Insert Insert (Insertion a) (Insertion a)
116instance Sql DBType a => Recontextualize Insert Insert (Insertion a) (Insertion a)
src/Rel8/Schema/Kind.hs+4−1
@@ -22,8 +22,11 @@ type HTable :: Type
22type HTable = HContext -> Type
22type HTable = HContext -> Type
23
23
24
24
25+data X
26+
27+
25type Context :: Type
28type Context :: Type
26−type Context = Type -> Type
29+type Context = X -> Type
27
30
28
31
29type Table :: Type
32type Table :: Type
src/Rel8/Schema/Name.hs+17−9
@@ -2,9 +2,11 @@
2{-# language DerivingStrategies #-}
2{-# language DerivingStrategies #-}
3{-# language FlexibleContexts #-}
3{-# language FlexibleContexts #-}
4{-# language FlexibleInstances #-}
4{-# language FlexibleInstances #-}
5−{-# language GeneralizedNewtypeDeriving #-}
5+{-# language GADTs #-}
6{-# language MultiParamTypeClasses #-}
6{-# language MultiParamTypeClasses #-}
7+{-# language PolyKinds #-}
7{-# language RankNTypes #-}
8{-# language RankNTypes #-}
9+{-# language StandaloneDeriving #-}
8{-# language StandaloneKindSignatures #-}
10{-# language StandaloneKindSignatures #-}
9{-# language TypeFamilies #-}
11{-# language TypeFamilies #-}
10{-# language UndecidableInstances #-}
12{-# language UndecidableInstances #-}
@@ -20,7 +22,7 @@ where
20-- base
22-- base
21import Data.Functor.Identity ( Identity )
23import Data.Functor.Identity ( Identity )
22import Data.Kind ( Constraint, Type )
24import Data.Kind ( Constraint, Type )
23−import Data.String ( IsString )
25+import Data.String ( IsString, fromString )
24import Prelude
26import Prelude
25
27
26-- rel8
28-- rel8
@@ -28,8 +30,8 @@ import Rel8.Expr ( Expr )
28import Rel8.Schema.Context ( Interpretation, Col )
30import Rel8.Schema.Context ( Interpretation, Col )
29import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
31import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
30import Rel8.Schema.HTable.Type ( HType( HType ) )
32import Rel8.Schema.HTable.Type ( HType( HType ) )
31−import qualified Rel8.Schema.Kind as K
32import Rel8.Schema.Null ( Sql )
33import Rel8.Schema.Null ( Sql )
34+import Rel8.Schema.Result ( Result )
33import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
35import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
34import Rel8.Table.Recontextualize ( Recontextualize )
36import Rel8.Table.Recontextualize ( Recontextualize )
35import Rel8.Type ( DBType )
37import Rel8.Type ( DBType )
@@ -39,10 +41,16 @@ import Rel8.Type ( DBType )
39-- schema definition. You can construct names by using the @OverloadedStrings@
41-- schema definition. You can construct names by using the @OverloadedStrings@
40-- extension and writing string literals. This is typically done when providing
42-- extension and writing string literals. This is typically done when providing
41-- a 'TableSchema' value.
43-- a 'TableSchema' value.
42−type Name :: K.Context
44+type Name :: k -> Type
43−newtype Name a = Name String
45+data Name a where
46+ Name :: k ~ Type => !String -> Name (a :: k)
47+
48+
44− deriving stock Show
49+deriving stock instance Show (Name a)
45− deriving newtype (IsString, Monoid, Semigroup)
50+
51+
52+instance k ~ Type => IsString (Name (a :: k)) where
53+ fromString = Name
46
54
47
55
48instance Sql DBType a => Table Name (Name a) where
56instance Sql DBType a => Table Name (Name a) where
@@ -56,13 +64,13 @@ instance Sql DBType a => Table Name (Name a) where
56instance Sql DBType a => Recontextualize Expr Name (Expr a) (Name a)
64instance Sql DBType a => Recontextualize Expr Name (Expr a) (Name a)
57
65
58
66
59−instance Sql DBType a => Recontextualize Identity Name (Identity a) (Name a)
67+instance Sql DBType a => Recontextualize Result Name (Identity a) (Name a)
60
68
61
69
62instance Sql DBType a => Recontextualize Name Expr (Name a) (Expr a)
70instance Sql DBType a => Recontextualize Name Expr (Name a) (Expr a)
63
71
64
72
65−instance Sql DBType a => Recontextualize Name Identity (Name a) (Identity a)
73+instance Sql DBType a => Recontextualize Name Result (Name a) (Identity a)
66
74
67
75
68instance Sql DBType a => Recontextualize Name Name (Name a) (Name a)
76instance Sql DBType a => Recontextualize Name Name (Name a) (Name a)
src/Rel8/Schema/Result.hsnew file+16
@@ -0,0 +1,16 @@
1+{-# language DataKinds #-}
2+{-# language StandaloneKindSignatures #-}
3+
4+module Rel8.Schema.Result
5+ ( Result
6+ ) where
7+
8+-- base
9+import Prelude ()
10+
11+-- rel8
12+import Rel8.Schema.Kind ( Context )
13+
14+
15+type Result :: Context
16+data Result a
src/Rel8/Schema/Spec.hs−14
@@ -8,8 +8,6 @@ module Rel8.Schema.Spec
8 ( Spec( Spec )
8 ( Spec( Spec )
9 , SSpec( SSpec, labels, necessity, info, nullity )
9 , SSpec( SSpec, labels, necessity, info, nullity )
10 , KnownSpec( specSing )
10 , KnownSpec( specSing )
11− , KContext, HKTable
12− , KTable
13 )
11 )
14where
12where
15
13
@@ -62,15 +60,3 @@ instance
62 , info = typeInformation
60 , info = typeInformation
63 , nullity = nullable
61 , nullity = nullable
64 }
62 }
65−
66−
67−type KContext :: Type
68−type KContext = Spec -> Type
69−
70−
71−type HKTable :: Type
72−type HKTable = KContext -> Type
73−
74−
75−type KTable :: Type
76−type KTable = (Type -> Type) -> Type
src/Rel8/Table.hs+24−25
@@ -44,6 +44,7 @@ import Rel8.Schema.HTable.Type ( HType( HType ) )
44import Rel8.Schema.HTable.Vectorize ( hvectorize, hunvectorize )
44import Rel8.Schema.HTable.Vectorize ( hvectorize, hunvectorize )
45import qualified Rel8.Schema.Kind as K
45import qualified Rel8.Schema.Kind as K
46import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql )
46import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql )
47+import Rel8.Schema.Result ( Result )
47import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..), KnownSpec )
48import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..), KnownSpec )
48import Rel8.Type ( DBType )
49import Rel8.Type ( DBType )
49import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), MaybeTag( IsJust ) )
50import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), MaybeTag( IsJust ) )
@@ -94,18 +95,17 @@ instance KnownSpec spec => Table context (Col context spec) where
94 fromColumns = unHIdentity
95 fromColumns = unHIdentity
95
96
96
97
97−instance Sql DBType a => Table Identity (Identity a) where
98+instance Sql DBType a => Table Result (Identity a) where
98 type Columns (Identity a) = HType a
99 type Columns (Identity a) = HType a
99− type Context (Identity a) = Identity
100+ type Context (Identity a) = Result
100
101
101 toColumns (Identity a) = HType (Result a)
102 toColumns (Identity a) = HType (Result a)
102 fromColumns (HType (Result a)) = Identity a
103 fromColumns (HType (Result a)) = Identity a
103
104
104
105
105−instance (Table Identity a, Table Identity b) => Table Identity (Either a b)
106+instance (Table Result a, Table Result b) => Table Result (Either a b) where
106− where
107 type Columns (Either a b) = HEitherTable (Columns a) (Columns b)
107 type Columns (Either a b) = HEitherTable (Columns a) (Columns b)
108− type Context (Either a b) = Identity
108+ type Context (Either a b) = Result
109
109
110 toColumns = \case
110 toColumns = \case
111 Left table -> HEitherTable
111 Left table -> HEitherTable
@@ -127,17 +127,17 @@ instance (Table Identity a, Table Identity b) => Table Identity (Either a b)
127 err = error "Either.fromColumns: mismatch between tag and data"
127 err = error "Either.fromColumns: mismatch between tag and data"
128
128
129
129
130−instance Table Identity a => Table Identity [a] where
130+instance Table Result a => Table Result [a] where
131 type Columns [a] = HListTable (Columns a)
131 type Columns [a] = HListTable (Columns a)
132− type Context [a] = Identity
132+ type Context [a] = Result
133
133
134 toColumns = hvectorize vectorizer . fmap toColumns
134 toColumns = hvectorize vectorizer . fmap toColumns
135 fromColumns = fmap fromColumns . hunvectorize unvectorizer
135 fromColumns = fmap fromColumns . hunvectorize unvectorizer
136
136
137
137
138−instance Table Identity a => Table Identity (Maybe a) where
138+instance Table Result a => Table Result (Maybe a) where
139 type Columns (Maybe a) = HMaybeTable (Columns a)
139 type Columns (Maybe a) = HMaybeTable (Columns a)
140− type Context (Maybe a) = Identity
140+ type Context (Maybe a) = Result
141
141
142 toColumns = \case
142 toColumns = \case
143 Nothing -> HMaybeTable
143 Nothing -> HMaybeTable
@@ -156,18 +156,17 @@ instance Table Identity a => Table Identity (Maybe a) where
156 Just just -> fromColumns just
156 Just just -> fromColumns just
157
157
158
158
159−instance Table Identity a => Table Identity (NonEmpty a) where
159+instance Table Result a => Table Result (NonEmpty a) where
160 type Columns (NonEmpty a) = HNonEmptyTable (Columns a)
160 type Columns (NonEmpty a) = HNonEmptyTable (Columns a)
161− type Context (NonEmpty a) = Identity
161+ type Context (NonEmpty a) = Result
162
162
163 toColumns = hvectorize vectorizer . fmap toColumns
163 toColumns = hvectorize vectorizer . fmap toColumns
164 fromColumns = fmap fromColumns . hunvectorize unvectorizer
164 fromColumns = fmap fromColumns . hunvectorize unvectorizer
165
165
166
166
167−instance (Table Identity a, Table Identity b) => Table Identity (These a b)
167+instance (Table Result a, Table Result b) => Table Result (These a b) where
168− where
169 type Columns (These a b) = HTheseTable (Columns a) (Columns b)
168 type Columns (These a b) = HTheseTable (Columns a) (Columns b)
170− type Context (These a b) = Identity
169+ type Context (These a b) = Result
171
170
172 toColumns tables = HTheseTable
171 toColumns tables = HTheseTable
173 { hhereTag = relabel hhereTag
172 { hhereTag = relabel hhereTag
@@ -311,14 +310,14 @@ class Columns a ~ Columns b => Congruent a b
311instance Columns a ~ Columns b => Congruent a b
310instance Columns a ~ Columns b => Congruent a b
312
311
313
312
314−null :: Col Identity ('Spec labels necessity (Maybe a))
313+null :: Col Result ('Spec labels necessity (Maybe a))
315null = Result Nothing
314null = Result Nothing
316
315
317
316
318nullifier :: ()
317nullifier :: ()
319 => SSpec ('Spec labels necessity a)
318 => SSpec ('Spec labels necessity a)
320− -> Col Identity ('Spec labels necessity a)
319+ -> Col Result ('Spec labels necessity a)
321− -> Col Identity ('Spec labels necessity (Nullify a))
320+ -> Col Result ('Spec labels necessity (Nullify a))
322nullifier SSpec {nullity} (Result a) = Result $ case nullity of
321nullifier SSpec {nullity} (Result a) = Result $ case nullity of
323 Null -> a
322 Null -> a
324 NotNull -> Just a
323 NotNull -> Just a
@@ -326,8 +325,8 @@ nullifier SSpec {nullity} (Result a) = Result $ case nullity of
326
325
327unnullifier :: ()
326unnullifier :: ()
328 => SSpec ('Spec labels necessity a)
327 => SSpec ('Spec labels necessity a)
329− -> Col Identity ('Spec labels necessity (Nullify a))
328+ -> Col Result ('Spec labels necessity (Nullify a))
330− -> Maybe (Col Identity ('Spec labels necessity a))
329+ -> Maybe (Col Result ('Spec labels necessity a))
331unnullifier SSpec {nullity} (Result a) =
330unnullifier SSpec {nullity} (Result a) =
332 case nullity of
331 case nullity of
333 Null -> pure $ Result a
332 Null -> pure $ Result a
@@ -336,19 +335,19 @@ unnullifier SSpec {nullity} (Result a) =
336
335
337vectorizer :: Functor f
336vectorizer :: Functor f
338 => SSpec ('Spec labels necessity a)
337 => SSpec ('Spec labels necessity a)
339− -> f (Col Identity ('Spec labels necessity a))
338+ -> f (Col Result ('Spec labels necessity a))
340− -> Col Identity ('Spec labels necessity (f a))
339+ -> Col Result ('Spec labels necessity (f a))
341vectorizer _ = Result . fmap (\(Result a) -> a)
340vectorizer _ = Result . fmap (\(Result a) -> a)
342
341
343
342
344unvectorizer :: Functor f
343unvectorizer :: Functor f
345 => SSpec ('Spec labels necessity a)
344 => SSpec ('Spec labels necessity a)
346− -> Col Identity ('Spec labels necessity (f a))
345+ -> Col Result ('Spec labels necessity (f a))
347− -> f (Col Identity ('Spec labels necessity a))
346+ -> f (Col Result ('Spec labels necessity a))
348unvectorizer _ (Result results) = Result <$> results
347unvectorizer _ (Result results) = Result <$> results
349
348
350
349
351relabel :: ()
350relabel :: ()
352− => HIdentity ('Spec labels necessity a) (Col Identity)
351+ => HIdentity ('Spec labels necessity a) (Col Result)
353− -> HIdentity ('Spec relabels necessity a) (Col Identity)
352+ -> HIdentity ('Spec relabels necessity a) (Col Result)
354relabel (HIdentity (Result a)) = HIdentity (Result a)
353relabel (HIdentity (Result a)) = HIdentity (Result a)
src/Rel8/Table/Eq.hs+2−1
@@ -40,6 +40,7 @@ import Rel8.Schema.HTable.Pair ( HPair(..) )
40import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
40import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
41import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
41import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
42import Rel8.Schema.HTable.Trio ( HTrio(..) )
42import Rel8.Schema.HTable.Trio ( HTrio(..) )
43+import Rel8.Schema.Kind ( Context )
43import Rel8.Schema.Null ( Sql )
44import Rel8.Schema.Null ( Sql )
44import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
45import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
45import Rel8.Table ( Table, Columns, toColumns )
46import Rel8.Table ( Table, Columns, toColumns )
@@ -60,7 +61,7 @@ class Table Expr a => EqTable a where
60
61
61
62
62instance
63instance
63− ( Table Expr (t Expr)
64+ ( Table Expr (t (Expr :: Context))
64 , f ~ Expr
65 , f ~ Expr
65 , HConstrainTable (Columns (t Expr)) (ConstrainDBType DBEq)
66 , HConstrainTable (Columns (t Expr)) (ConstrainDBType DBEq)
66 )
67 )
src/Rel8/Table/Name.hs+6−2
@@ -23,8 +23,12 @@ import Prelude
23-- casing
23-- casing
24import Text.Casing ( quietSnake )
24import Text.Casing ( quietSnake )
25
25
26+-- opaleye
27+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
28+
26-- rel8
29-- rel8
27import Rel8.Expr ( Expr, Col(..) )
30import Rel8.Expr ( Expr, Col(..) )
31+import Rel8.Expr.Opaleye ( toPrimExpr )
28import Rel8.Kind.Labels ( renderLabels )
32import Rel8.Kind.Labels ( renderLabels )
29import Rel8.Schema.HTable ( htabulate, htabulateA, hfield, hspecs )
33import Rel8.Schema.HTable ( htabulate, htabulateA, hfield, hspecs )
30import Rel8.Schema.Name ( Name, Col(..) )
34import Rel8.Schema.Name ( Name, Col(..) )
@@ -45,11 +49,11 @@ namesFromLabelsWith f = fromColumns $ htabulate $ \field ->
45 SSpec {labels} -> NameCol (f (renderLabels labels))
49 SSpec {labels} -> NameCol (f (renderLabels labels))
46
50
47
51
48−showExprs :: Table Expr a => a -> [(String, String)]
52+showExprs :: Table Expr a => a -> [(String, Opaleye.PrimExpr)]
49showExprs as = case (namesFromLabels, toColumns as) of
53showExprs as = case (namesFromLabels, toColumns as) of
50 (names, exprs) -> getConst $ htabulateA $ \field ->
54 (names, exprs) -> getConst $ htabulateA $ \field ->
51 case (hfield names field, hfield exprs field) of
55 case (hfield names field, hfield exprs field) of
52− (NameCol name, DB expr) -> Const [(name, show expr)]
56+ (NameCol name, DB expr) -> Const [(name, toPrimExpr expr)]
53
57
54
58
55showLabels :: forall a. Table (Context a) a => a -> [NonEmpty String]
59showLabels :: forall a. Table (Context a) a => a -> [NonEmpty String]
src/Rel8/Table/Ord.hs+2−1
@@ -37,6 +37,7 @@ import Rel8.Schema.HTable.Pair ( HPair(..) )
37import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
37import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
38import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
38import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
39import Rel8.Schema.HTable.Trio ( HTrio(..) )
39import Rel8.Schema.HTable.Trio ( HTrio(..) )
40+import Rel8.Schema.Kind ( Context )
40import Rel8.Schema.Null (Sql)
41import Rel8.Schema.Null (Sql)
41import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
42import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
42import Rel8.Table ( Table, Columns, toColumns )
43import Rel8.Table ( Table, Columns, toColumns )
@@ -58,7 +59,7 @@ class EqTable a => OrdTable a where
58
59
59
60
60instance
61instance
61− ( Table Expr (t Expr)
62+ ( Table Expr (t (Expr :: Context))
62 , f ~ Expr
63 , f ~ Expr
63 , HConstrainTable (Columns (t Expr)) (ConstrainDBType DBEq)
64 , HConstrainTable (Columns (t Expr)) (ConstrainDBType DBEq)
64 , HConstrainTable (Columns (t Expr)) (ConstrainDBType DBOrd)
65 , HConstrainTable (Columns (t Expr)) (ConstrainDBType DBOrd)
src/Rel8/Table/Recontextualize.hs+2−1
@@ -22,6 +22,7 @@ import Rel8.Schema.Context.Label ( Labelable )
22import Rel8.Schema.HTable ( HTable )
22import Rel8.Schema.HTable ( HTable )
23import qualified Rel8.Schema.Kind as K
23import qualified Rel8.Schema.Kind as K
24import Rel8.Schema.Null ( Sql )
24import Rel8.Schema.Null ( Sql )
25+import Rel8.Schema.Result ( Result )
25import Rel8.Table ( Table, Congruent )
26import Rel8.Table ( Table, Congruent )
26import Rel8.Type ( DBType )
27import Rel8.Type ( DBType )
27
28
@@ -41,7 +42,7 @@ class
41 , b from -> a
42 , b from -> a
42
43
43
44
44−instance Sql DBType a => Recontextualize Identity Identity (Identity a) (Identity a)
45+instance Sql DBType a => Recontextualize Result Result (Identity a) (Identity a)
45
46
46
47
47instance HTable t => Recontextualize from to (t (Col from)) (t (Col to))
48instance HTable t => Recontextualize from to (t (Col from)) (t (Col to))
src/Rel8/Table/Serialize.hs+84−84
@@ -21,7 +21,6 @@ where
21
21
22-- base
22-- base
23import Data.Bifunctor ( bimap )
23import Data.Bifunctor ( bimap )
24−import Data.Functor.Identity ( Identity )
25import Data.Kind ( Constraint, Type )
24import Data.Kind ( Constraint, Type )
26import Data.List.NonEmpty ( NonEmpty )
25import Data.List.NonEmpty ( NonEmpty )
27import Prelude
26import Prelude
@@ -42,6 +41,7 @@ import Rel8.Schema.HTable.Pair ( HPair(..) )
42import Rel8.Schema.HTable.Trio ( HTrio(..) )
41import Rel8.Schema.HTable.Trio ( HTrio(..) )
43import Rel8.Schema.HTable.Type ( HType(..) )
42import Rel8.Schema.HTable.Type ( HType(..) )
44import Rel8.Schema.Null ( NotNull, Sql )
43import Rel8.Schema.Null ( NotNull, Sql )
44+import Rel8.Schema.Result ( Result )
45import Rel8.Schema.Spec ( SSpec(..), KnownSpec )
45import Rel8.Schema.Spec ( SSpec(..), KnownSpec )
46import Rel8.Table ( Table, Columns, fromColumns, toColumns )
46import Rel8.Table ( Table, Columns, fromColumns, toColumns )
47import Rel8.Table.Either ( EitherTable )
47import Rel8.Table.Either ( EitherTable )
@@ -59,90 +59,90 @@ import Data.Functor.Apply ( WrappedApplicative(..) )
59import Data.These ( These )
59import Data.These ( These )
60
60
61
61
62−fromIdentity' :: forall exprs a. ToExprs a exprs => Columns exprs (Col Identity) -> a
62+fromResult' :: forall exprs a. ToExprs a exprs => Columns exprs (Col Result) -> a
63−fromIdentity' = fromIdentity @_ @exprs
63+fromResult' = fromResult @_ @exprs
64
64
65
65
66−toIdentity' :: forall exprs a. ToExprs a exprs => a -> Columns exprs (Col Identity)
66+toResult' :: forall exprs a. ToExprs a exprs => a -> Columns exprs (Col Result)
67−toIdentity' = toIdentity @_ @exprs
67+toResult' = toResult @_ @exprs
68
68
69
69
70type ToExprs :: Type -> Type -> Constraint
70type ToExprs :: Type -> Type -> Constraint
71class Table Expr exprs => ToExprs a exprs where
71class Table Expr exprs => ToExprs a exprs where
72− fromIdentity :: Columns exprs (Col Identity) -> a
72+ fromResult :: Columns exprs (Col Result) -> a
73− toIdentity :: a -> Columns exprs (Col Identity)
73+ toResult :: a -> Columns exprs (Col Result)
74
74
75
75
76instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs a x where
76instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs a x where
77− fromIdentity (HType (Result a)) = a
77+ fromResult (HType (Result a)) = a
78− toIdentity = HType . Result
78+ toResult = HType . Result
79
79
80
80
81instance (Sql DBType a, x ~ [a]) => ToExprs [a] (Expr x) where
81instance (Sql DBType a, x ~ [a]) => ToExprs [a] (Expr x) where
82− fromIdentity (HType (Result a)) = a
82+ fromResult (HType (Result a)) = a
83− toIdentity = HType . Result
83+ toResult = HType . Result
84
84
85
85
86instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Maybe a) (Expr x)
86instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Maybe a) (Expr x)
87 where
87 where
88− fromIdentity (HType (Result a)) = a
88+ fromResult (HType (Result a)) = a
89− toIdentity = HType . Result
89+ toResult = HType . Result
90
90
91
91
92instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (NonEmpty a) (Expr x)
92instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (NonEmpty a) (Expr x)
93 where
93 where
94− fromIdentity (HType (Result a)) = a
94+ fromResult (HType (Result a)) = a
95− toIdentity = HType . Result
95+ toResult = HType . Result
96
96
97
97
98instance (ToExprs a exprs1, ToExprs b exprs2, x ~ EitherTable exprs1 exprs2) =>
98instance (ToExprs a exprs1, ToExprs b exprs2, x ~ EitherTable exprs1 exprs2) =>
99 ToExprs (Either a b) x
99 ToExprs (Either a b) x
100 where
100 where
101− fromIdentity =
101+ fromResult =
102− bimap (fromIdentity' @exprs1) (fromIdentity' @exprs2) .
102+ bimap (fromResult' @exprs1) (fromResult' @exprs2) .
103 fromColumns
103 fromColumns
104− toIdentity =
104+ toResult =
105 toColumns .
105 toColumns .
106− bimap (toIdentity' @exprs1) (toIdentity' @exprs2)
106+ bimap (toResult' @exprs1) (toResult' @exprs2)
107
107
108
108
109instance ToExprs a exprs => ToExprs [a] (ListTable exprs) where
109instance ToExprs a exprs => ToExprs [a] (ListTable exprs) where
110− fromIdentity = fmap (fromIdentity' @exprs) . fromColumns
110+ fromResult = fmap (fromResult' @exprs) . fromColumns
111− toIdentity = toColumns . fmap (toIdentity' @exprs)
111+ toResult = toColumns . fmap (toResult' @exprs)
112
112
113
113
114instance ToExprs a exprs => ToExprs (Maybe a) (MaybeTable exprs) where
114instance ToExprs a exprs => ToExprs (Maybe a) (MaybeTable exprs) where
115− fromIdentity = fmap (fromIdentity' @exprs) . fromColumns
115+ fromResult = fmap (fromResult' @exprs) . fromColumns
116− toIdentity = toColumns . fmap (toIdentity' @exprs)
116+ toResult = toColumns . fmap (toResult' @exprs)
117
117
118
118
119instance ToExprs a exprs => ToExprs (NonEmpty a) (NonEmptyTable exprs)
119instance ToExprs a exprs => ToExprs (NonEmpty a) (NonEmptyTable exprs)
120 where
120 where
121− fromIdentity = fmap (fromIdentity' @exprs) . fromColumns
121+ fromResult = fmap (fromResult' @exprs) . fromColumns
122− toIdentity = toColumns . fmap (toIdentity' @exprs)
122+ toResult = toColumns . fmap (toResult' @exprs)
123
123
124
124
125instance (ToExprs a exprs1, ToExprs b exprs2, x ~ TheseTable exprs1 exprs2) =>
125instance (ToExprs a exprs1, ToExprs b exprs2, x ~ TheseTable exprs1 exprs2) =>
126 ToExprs (These a b) x
126 ToExprs (These a b) x
127 where
127 where
128− fromIdentity =
128+ fromResult =
129− bimap (fromIdentity' @exprs1) (fromIdentity' @exprs2) .
129+ bimap (fromResult' @exprs1) (fromResult' @exprs2) .
130 fromColumns
130 fromColumns
131− toIdentity =
131+ toResult =
132 toColumns .
132 toColumns .
133− bimap (toIdentity' @exprs1) (toIdentity' @exprs2)
133+ bimap (toResult' @exprs1) (toResult' @exprs2)
134
134
135
135
136instance (ToExprs a exprs1, ToExprs b exprs2, x ~ (exprs1, exprs2)) =>
136instance (ToExprs a exprs1, ToExprs b exprs2, x ~ (exprs1, exprs2)) =>
137 ToExprs (a, b) x
137 ToExprs (a, b) x
138 where
138 where
139− fromIdentity (HPair a b) =
139+ fromResult (HPair a b) =
140− ( fromIdentity' @exprs1 $ hunlabel unlabeler a
140+ ( fromResult' @exprs1 $ hunlabel unlabeler a
141− , fromIdentity' @exprs2 $ hunlabel unlabeler b
141+ , fromResult' @exprs2 $ hunlabel unlabeler b
142 )
142 )
143− toIdentity (a, b) = HPair
143+ toResult (a, b) = HPair
144− { hfst = hlabel labeler $ toIdentity' @exprs1 a
144+ { hfst = hlabel labeler $ toResult' @exprs1 a
145− , hsnd = hlabel labeler $ toIdentity' @exprs2 b
145+ , hsnd = hlabel labeler $ toResult' @exprs2 b
146 }
146 }
147
147
148
148
@@ -153,15 +153,15 @@ instance
153 , x ~ (exprs1, exprs2, exprs3)
153 , x ~ (exprs1, exprs2, exprs3)
154 ) => ToExprs (a, b, c) x
154 ) => ToExprs (a, b, c) x
155 where
155 where
156− fromIdentity (HTrio a b c) =
156+ fromResult (HTrio a b c) =
157− ( fromIdentity' @exprs1 $ hunlabel unlabeler a
157+ ( fromResult' @exprs1 $ hunlabel unlabeler a
158− , fromIdentity' @exprs2 $ hunlabel unlabeler b
158+ , fromResult' @exprs2 $ hunlabel unlabeler b
159− , fromIdentity' @exprs3 $ hunlabel unlabeler c
159+ , fromResult' @exprs3 $ hunlabel unlabeler c
160 )
160 )
161− toIdentity (a, b, c) = HTrio
161+ toResult (a, b, c) = HTrio
162− { hfst = hlabel labeler $ toIdentity' @exprs1 a
162+ { hfst = hlabel labeler $ toResult' @exprs1 a
163− , hsnd = hlabel labeler $ toIdentity' @exprs2 b
163+ , hsnd = hlabel labeler $ toResult' @exprs2 b
164− , htrd = hlabel labeler $ toIdentity' @exprs3 c
164+ , htrd = hlabel labeler $ toResult' @exprs3 c
165 }
165 }
166
166
167
167
@@ -173,17 +173,17 @@ instance
173 , x ~ (exprs1, exprs2, exprs3, exprs4)
173 , x ~ (exprs1, exprs2, exprs3, exprs4)
174 ) => ToExprs (a, b, c, d) x
174 ) => ToExprs (a, b, c, d) x
175 where
175 where
176− fromIdentity (HQuartet a b c d) =
176+ fromResult (HQuartet a b c d) =
177− ( fromIdentity' @exprs1 $ hunlabel unlabeler a
177+ ( fromResult' @exprs1 $ hunlabel unlabeler a
178− , fromIdentity' @exprs2 $ hunlabel unlabeler b
178+ , fromResult' @exprs2 $ hunlabel unlabeler b
179− , fromIdentity' @exprs3 $ hunlabel unlabeler c
179+ , fromResult' @exprs3 $ hunlabel unlabeler c
180− , fromIdentity' @exprs4 $ hunlabel unlabeler d
180+ , fromResult' @exprs4 $ hunlabel unlabeler d
181 )
181 )
182− toIdentity (a, b, c, d) = HQuartet
182+ toResult (a, b, c, d) = HQuartet
183− { hfst = hlabel labeler $ toIdentity' @exprs1 a
183+ { hfst = hlabel labeler $ toResult' @exprs1 a
184− , hsnd = hlabel labeler $ toIdentity' @exprs2 b
184+ , hsnd = hlabel labeler $ toResult' @exprs2 b
185− , htrd = hlabel labeler $ toIdentity' @exprs3 c
185+ , htrd = hlabel labeler $ toResult' @exprs3 c
186− , hfrt = hlabel labeler $ toIdentity' @exprs4 d
186+ , hfrt = hlabel labeler $ toResult' @exprs4 d
187 }
187 }
188
188
189
189
@@ -196,47 +196,47 @@ instance
196 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5)
196 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5)
197 ) => ToExprs (a, b, c, d, e) x
197 ) => ToExprs (a, b, c, d, e) x
198 where
198 where
199− fromIdentity (HQuintet a b c d e) =
199+ fromResult (HQuintet a b c d e) =
200− ( fromIdentity' @exprs1 $ hunlabel unlabeler a
200+ ( fromResult' @exprs1 $ hunlabel unlabeler a
201− , fromIdentity' @exprs2 $ hunlabel unlabeler b
201+ , fromResult' @exprs2 $ hunlabel unlabeler b
202− , fromIdentity' @exprs3 $ hunlabel unlabeler c
202+ , fromResult' @exprs3 $ hunlabel unlabeler c
203− , fromIdentity' @exprs4 $ hunlabel unlabeler d
203+ , fromResult' @exprs4 $ hunlabel unlabeler d
204− , fromIdentity' @exprs5 $ hunlabel unlabeler e
204+ , fromResult' @exprs5 $ hunlabel unlabeler e
205 )
205 )
206− toIdentity (a, b, c, d, e) = HQuintet
206+ toResult (a, b, c, d, e) = HQuintet
207− { hfst = hlabel labeler $ toIdentity' @exprs1 a
207+ { hfst = hlabel labeler $ toResult' @exprs1 a
208− , hsnd = hlabel labeler $ toIdentity' @exprs2 b
208+ , hsnd = hlabel labeler $ toResult' @exprs2 b
209− , htrd = hlabel labeler $ toIdentity' @exprs3 c
209+ , htrd = hlabel labeler $ toResult' @exprs3 c
210− , hfrt = hlabel labeler $ toIdentity' @exprs4 d
210+ , hfrt = hlabel labeler $ toResult' @exprs4 d
211− , hfft = hlabel labeler $ toIdentity' @exprs5 e
211+ , hfft = hlabel labeler $ toResult' @exprs5 e
212 }
212 }
213
213
214
214
215−instance (HTable t, result ~ Col Identity, x ~ t (Col Expr)) =>
215+instance (HTable t, result ~ Col Result, x ~ t (Col Expr)) =>
216 ToExprs (t result) x
216 ToExprs (t result) x
217 where
217 where
218− fromIdentity = id
218+ fromResult = id
219− toIdentity = id
219+ toResult = id
220
220
221
221
222−instance (Recontextualize Identity Expr (t Identity) (t Expr), result ~ Identity, x ~ t Expr) =>
222+instance (Recontextualize Result Expr (t Result) (t Expr), result ~ Result, x ~ t Expr) =>
223 ToExprs (t result) x
223 ToExprs (t result) x
224 where
224 where
225− fromIdentity = fromColumns
225+ fromResult = fromColumns
226− toIdentity = toColumns
226+ toResult = toColumns
227
227
228
228
229instance (KnownSpec spec, x ~ Col Expr spec) =>
229instance (KnownSpec spec, x ~ Col Expr spec) =>
230− ToExprs (Col Identity spec) x
230+ ToExprs (Col Result spec) x
231 where
231 where
232− fromIdentity = fromColumns
232+ fromResult = fromColumns
233− toIdentity = toColumns
233+ toResult = toColumns
234
234
235
235
236type FromExprs :: Type -> Type
236type FromExprs :: Type -> Type
237type family FromExprs a
237type family FromExprs a
238type instance FromExprs (Expr a) = a
238type instance FromExprs (Expr a) = a
239−type instance FromExprs (Col Expr spec) = Col Identity spec
239+type instance FromExprs (Col Expr spec) = Col Result spec
240type instance FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)
240type instance FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)
241type instance FromExprs (ListTable a) = [FromExprs a]
241type instance FromExprs (ListTable a) = [FromExprs a]
242type instance FromExprs (MaybeTable a) = Maybe (FromExprs a)
242type instance FromExprs (MaybeTable a) = Maybe (FromExprs a)
@@ -248,8 +248,8 @@ type instance FromExprs (a, b, c, d) =
248 (FromExprs a, FromExprs b, FromExprs c, FromExprs d)
248 (FromExprs a, FromExprs b, FromExprs c, FromExprs d)
249type instance FromExprs (a, b, c, d, e) =
249type instance FromExprs (a, b, c, d, e) =
250 (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e)
250 (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e)
251−type instance FromExprs (t Expr) = t Identity
251+type instance FromExprs (t Expr) = t Result
252−type instance FromExprs (t (Col Expr)) = t (Col Identity)
252+type instance FromExprs (t (Col Expr)) = t (Col Result)
253
253
254
254
255-- | @Serializable@ witnesses the one-to-one correspondence between the type
255-- | @Serializable@ witnesses the one-to-one correspondence between the type
@@ -264,24 +264,24 @@ instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a
264-- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is
264-- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is
265-- capable of lifting single @Expr@s to full tables.
265-- capable of lifting single @Expr@s to full tables.
266lit :: forall exprs a. Serializable exprs a => a -> exprs
266lit :: forall exprs a. Serializable exprs a => a -> exprs
267−lit = fromColumns . litHTable . toIdentity' @exprs
267+lit = fromColumns . litHTable . toResult' @exprs
268
268
269
269
270parse :: forall exprs a. Serializable exprs a => Hasql.Row a
270parse :: forall exprs a. Serializable exprs a => Hasql.Row a
271−parse = fromIdentity' @exprs <$> parseHTable
271+parse = fromResult' @exprs <$> parseHTable
272
272
273
273
274type Encodes :: Type -> Type -> Constraint
274type Encodes :: Type -> Type -> Constraint
275class Serializable exprs a => Encodes a exprs | a -> exprs, exprs -> a
275class Serializable exprs a => Encodes a exprs | a -> exprs, exprs -> a
276
276
277
277
278−instance KnownSpec spec => Encodes (Col Identity spec) (Col Expr spec)
278+instance KnownSpec spec => Encodes (Col Result spec) (Col Expr spec)
279
279
280
280
281−instance Serializable (t Identity) (t Expr) => Encodes (t Expr) (t Identity)
281+instance Serializable (t Result) (t Expr) => Encodes (t Expr) (t Result)
282
282
283
283
284−instance HTable t => Encodes (t (Col Identity)) (t (Col Expr))
284+instance HTable t => Encodes (t (Col Result)) (t (Col Expr))
285
285
286
286
287instance (Encodes a x, Encodes b y) => Encodes (Either a b) (EitherTable x y)
287instance (Encodes a x, Encodes b y) => Encodes (Either a b) (EitherTable x y)
@@ -318,14 +318,14 @@ litTable :: Encodes a exprs => a -> exprs
318litTable = lit
318litTable = lit
319
319
320
320
321−litHTable :: HTable t => t (Col Identity) -> t (Col Expr)
321+litHTable :: HTable t => t (Col Result) -> t (Col Expr)
322litHTable as = htabulate $ \field ->
322litHTable as = htabulate $ \field ->
323 case hfield hspecs field of
323 case hfield hspecs field of
324 SSpec {nullity, info} -> case hfield as field of
324 SSpec {nullity, info} -> case hfield as field of
325 Result value -> DB (slitExpr nullity info value)
325 Result value -> DB (slitExpr nullity info value)
326
326
327
327
328−parseHTable :: HTable t => Hasql.Row (t (Col Identity))
328+parseHTable :: HTable t => Hasql.Row (t (Col Result))
329parseHTable = unwrapApplicative $ htabulateA $ \field ->
329parseHTable = unwrapApplicative $ htabulateA $ \field ->
330 WrapApplicative $ case hfield hspecs field of
330 WrapApplicative $ case hfield hspecs field of
331 SSpec {nullity, info} -> Result <$> sparseValue nullity info
331 SSpec {nullity, info} -> Result <$> sparseValue nullity info
tests/Main.hs+15−15
@@ -27,7 +27,6 @@ import Control.Monad (void)
27import Control.Monad.IO.Class ( MonadIO, liftIO )
27import Control.Monad.IO.Class ( MonadIO, liftIO )
28import Data.Bifunctor ( bimap )
28import Data.Bifunctor ( bimap )
29import Data.Foldable ( for_ )
29import Data.Foldable ( for_ )
30−import Data.Functor.Identity ( Identity )
31import Data.Int ( Int32, Int64 )
30import Data.Int ( Int32, Int64 )
32import Data.List ( nub, sort )
31import Data.List ( nub, sort )
33import Data.Maybe ( catMaybes )
32import Data.Maybe ( catMaybes )
@@ -60,6 +59,7 @@ import Control.Exception.Lifted ( bracket, throwIO, bracket_ )
60import Control.Monad.Trans.Control ( MonadBaseControl )
59import Control.Monad.Trans.Control ( MonadBaseControl )
61
60
62-- rel8
61-- rel8
62+import Rel8 ( Result )
63import qualified Rel8
63import qualified Rel8
64
64
65-- scientific
65-- scientific
@@ -161,9 +161,9 @@ data TestTable f = TestTable
161 deriving anyclass Rel8.Rel8able
161 deriving anyclass Rel8.Rel8able
162
162
163
163
164−deriving stock instance Eq (TestTable Identity)
164+deriving stock instance Eq (TestTable Result)
165−deriving stock instance Ord (TestTable Identity)
165+deriving stock instance Ord (TestTable Result)
166−deriving stock instance Show (TestTable Identity)
166+deriving stock instance Show (TestTable Result)
167
167
168
168
169testTableSchema :: Rel8.TableSchema (TestTable Rel8.Name)
169testTableSchema :: Rel8.TableSchema (TestTable Rel8.Name)
@@ -543,9 +543,9 @@ data TwoTestTables f =
543 deriving anyclass Rel8.Rel8able
543 deriving anyclass Rel8.Rel8able
544
544
545
545
546−deriving stock instance Eq (TwoTestTables Identity)
546+deriving stock instance Eq (TwoTestTables Result)
547−deriving stock instance Ord (TwoTestTables Identity)
547+deriving stock instance Ord (TwoTestTables Result)
548−deriving stock instance Show (TwoTestTables Identity)
548+deriving stock instance Show (TwoTestTables Result)
549
549
550
550
551testNestedTables :: IO TmpPostgres.DB -> TestTree
551testNestedTables :: IO TmpPostgres.DB -> TestTree
@@ -578,7 +578,7 @@ testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction
578 (as, []) -> selected === (Nothing <$ as)
578 (as, []) -> selected === (Nothing <$ as)
579 (as, bs) -> sort selected === sort (Just <$> liftA2 (,) as bs)
579 (as, bs) -> sort selected === sort (Just <$> liftA2 (,) as bs)
580 where
580 where
581− genRows :: PropertyT IO [TestTable Identity]
581+ genRows :: PropertyT IO [TestTable Result]
582 genRows = forAll do
582 genRows = forAll do
583 Gen.list (Range.linear 0 10) $ liftA2 TestTable (Gen.text (Range.linear 0 10) Gen.unicode) (pure True)
583 Gen.list (Range.linear 0 10) $ liftA2 TestTable (Gen.text (Range.linear 0 10) Gen.unicode) (pure True)
584
584
@@ -591,7 +591,7 @@ rollingBack connection =
591 (liftIO (run (sql "ROLLBACK") connection))
591 (liftIO (run (sql "ROLLBACK") connection))
592
592
593
593
594−genTestTable :: Gen (TestTable Identity)
594+genTestTable :: Gen (TestTable Result)
595genTestTable = do
595genTestTable = do
596 testTableColumn1 <- Gen.text (Range.linear 0 5) Gen.alphaNum
596 testTableColumn1 <- Gen.text (Range.linear 0 5) Gen.alphaNum
597 testTableColumn2 <- Gen.bool
597 testTableColumn2 <- Gen.bool
@@ -673,9 +673,9 @@ newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) }
673 deriving stock Generic
673 deriving stock Generic
674 deriving anyclass Rel8.Rel8able
674 deriving anyclass Rel8.Rel8able
675
675
676−deriving stock instance Eq (HKNestedPair Identity)
676+deriving stock instance Eq (HKNestedPair Result)
677−deriving stock instance Ord (HKNestedPair Identity)
677+deriving stock instance Ord (HKNestedPair Result)
678−deriving stock instance Show (HKNestedPair Identity)
678+deriving stock instance Show (HKNestedPair Result)
679
679
680
680
681testSelectNestedPairs :: IO TmpPostgres.DB -> TestTree
681testSelectNestedPairs :: IO TmpPostgres.DB -> TestTree
@@ -708,9 +708,9 @@ data NestedMaybeTable f = NestedMaybeTable
708 deriving anyclass Rel8.Rel8able
708 deriving anyclass Rel8.Rel8able
709
709
710
710
711−deriving stock instance Eq (NestedMaybeTable Identity)
711+deriving stock instance Eq (NestedMaybeTable Result)
712−deriving stock instance Ord (NestedMaybeTable Identity)
712+deriving stock instance Ord (NestedMaybeTable Result)
713−deriving stock instance Show (NestedMaybeTable Identity)
713+deriving stock instance Show (NestedMaybeTable Result)
714
714
715
715
716testNestedMaybeTable :: IO TmpPostgres.DB -> TestTree
716testNestedMaybeTable :: IO TmpPostgres.DB -> TestTree