git.iko.soy/rel8
on master help sign in
Sketch of HKD-lifting of Generic types
47e7842Shane O'Brien
cabal.project.haskell-nix+6
compare with master
unifiedsplit
@@ -2,3 +2,9 @@
2-- will interpret them as local packages, and try to build them when we cabal
2-- will interpret them as local packages, and try to build them when we cabal
3-- build. The only reason we have to specify these is for Haskell.nix to know to
3-- build. The only reason we have to specify these is for Haskell.nix to know to
4-- override these packages by fetching them rather than using Hackage.
4-- override these packages by fetching them rather than using Hackage.
5+
6+source-repository-package
7+ type: git
8+ location: git://github.com/jcpetruzza/barbies
9+ tag: f99b05454874192e3511bd133555dfb6cc6a6ecb
10+ --sha256: 0yy2i2jbllwavv5d2176rf8lmm4l1ws90lxkmdlfgvfzqxidx0gi
default.nix+1−1
@@ -5,7 +5,7 @@ let
5
5
6 nixpkgsArgs = haskellNix.nixpkgsArgs;
6 nixpkgsArgs = haskellNix.nixpkgsArgs;
7
7
8− compiler-nix-name = "ghc901";
8+ compiler-nix-name = "ghc8104";
9
9
10 pkgs = import nixpkgsSrc nixpkgsArgs;
10 pkgs = import nixpkgsSrc nixpkgsArgs;
11
11
rel8.cabal+2
@@ -17,6 +17,7 @@ library
17 , casing
17 , casing
18 , contravariant
18 , contravariant
19 , hasql ^>= 1.4.5.1
19 , hasql ^>= 1.4.5.1
20+ , higgledy
20 , opaleye ^>= 0.7.1.0
21 , opaleye ^>= 0.7.1.0
21 , profunctors
22 , profunctors
22 , scientific
23 , scientific
@@ -93,6 +94,7 @@ library
93 Rel8.Schema.Field
94 Rel8.Schema.Field
94 Rel8.Schema.Generic
95 Rel8.Schema.Generic
95 Rel8.Schema.Generic.Test
96 Rel8.Schema.Generic.Test
97+ Rel8.Schema.HKD
96 Rel8.Schema.HTable
98 Rel8.Schema.HTable
97 Rel8.Schema.HTable.Either
99 Rel8.Schema.HTable.Either
98 Rel8.Schema.HTable.Identity
100 Rel8.Schema.HTable.Identity
src/Rel8.hs+4
@@ -29,10 +29,12 @@ module Rel8
29 , Rel8able, KRel8able
29 , Rel8able, KRel8able
30 , Column, Field, Necessity( Required, Optional )
30 , Column, Field, Necessity( Required, Optional )
31 , Default
31 , Default
32+ , HEither
32 , HMaybe
33 , HMaybe
33 , HList
34 , HList
34 , HNonEmpty
35 , HNonEmpty
35 , HThese
36 , HThese
37+ , Lift
36
38
37 , Table(..)
39 , Table(..)
38 , AltTable((<|>:))
40 , AltTable((<|>:))
@@ -236,6 +238,7 @@ module Rel8
236 , ToExprs(..)
238 , ToExprs(..)
237 , FromExprs
239 , FromExprs
238 , Result
240 , Result
241+ , HKDT(..)
239 ) where
242 ) where
240
243
241-- base
244-- base
@@ -275,6 +278,7 @@ import Rel8.Schema.Column
275import Rel8.Schema.Context.Label
278import Rel8.Schema.Context.Label
276import Rel8.Schema.Field
279import Rel8.Schema.Field
277import Rel8.Schema.Generic
280import Rel8.Schema.Generic
281+import Rel8.Schema.HKD
278import Rel8.Schema.HTable
282import Rel8.Schema.HTable
279import Rel8.Schema.Name
283import Rel8.Schema.Name
280import Rel8.Schema.Null hiding ( nullable )
284import Rel8.Schema.Null hiding ( nullable )
src/Rel8/Schema/Field.hs+2−1
@@ -11,9 +11,10 @@ module Rel8.Schema.Field
11 ( Field
11 ( Field
12 , HEither, HList, HMaybe, HNonEmpty, HThese
12 , HEither, HList, HMaybe, HNonEmpty, HThese
13 , Reify, hreify, hunreify
13 , Reify, hreify, hunreify
14− , Reifiable
14+ , Reifiable(..)
15 , AField(..)
15 , AField(..)
16 , AHEither(..), AHList(..), AHMaybe(..), AHNonEmpty(..), AHThese(..)
16 , AHEither(..), AHList(..), AHMaybe(..), AHNonEmpty(..), AHThese(..)
17+ , SContext(..)
17 )
18 )
18where
19where
19
20
src/Rel8/Schema/Generic/Test.hs+26−4
@@ -1,8 +1,12 @@
1{-# language DataKinds #-}
1{-# language DataKinds #-}
2{-# language DeriveAnyClass #-}
2{-# language DeriveAnyClass #-}
3{-# language DeriveGeneric #-}
3{-# language DeriveGeneric #-}
4−{-# language DerivingStrategies #-}
4+{-# language DerivingVia #-}
5{-# language DuplicateRecordFields #-}
5{-# language DuplicateRecordFields #-}
6+{-# language FlexibleInstances #-}
7+{-# language MultiParamTypeClasses #-}
8+{-# language StandaloneDeriving #-}
9+{-# language TypeFamilies #-}
6
10
7module Rel8.Schema.Generic.Test
11module Rel8.Schema.Generic.Test
8 ( module Rel8.Schema.Generic.Test
12 ( module Rel8.Schema.Generic.Test
@@ -13,10 +17,11 @@ where
13import GHC.Generics ( Generic )
17import GHC.Generics ( Generic )
14import Prelude
18import Prelude
15
19
20+-- higgledy
21+import Data.Generic.HKD ( HKD )
22+
16-- rel8
23-- rel8
17−import Rel8.Schema.Column
24+import Rel8
18−import Rel8.Schema.Field
19−import Rel8.Schema.Generic
20
25
21-- text
26-- text
22import Data.Text ( Text )
27import Data.Text ( Text )
@@ -76,3 +81,20 @@ data TableNonEmpty f = TableNonEmpty
76 }
81 }
77 deriving stock Generic
82 deriving stock Generic
78 deriving anyclass Rel8able
83 deriving anyclass Rel8able
84+
85+
86+data S3Object = S3Object
87+ { bucketName :: Text
88+ , objectKey :: Text
89+ } deriving stock Generic
90+
91+
92+deriving via HKDT S3Object
93+ instance x ~ HKD S3Object Expr => ToExprs x S3Object
94+
95+
96+data HKDTest f = HKDTest
97+ { s3Object :: Lift f S3Object
98+ }
99+ deriving stock Generic
100+ deriving anyclass Rel8able
src/Rel8/Schema/HKD.hsnew file+303
@@ -0,0 +1,303 @@
1+{-# language AllowAmbiguousTypes #-}
2+{-# language BlockArguments #-}
3+{-# language ConstraintKinds #-}
4+{-# language DataKinds #-}
5+{-# language FlexibleContexts #-}
6+{-# language FlexibleInstances #-}
7+{-# language FunctionalDependencies #-}
8+{-# language GADTs #-}
9+{-# language LambdaCase #-}
10+{-# language QuantifiedConstraints #-}
11+{-# language PolyKinds #-}
12+{-# language RankNTypes #-}
13+{-# language ScopedTypeVariables #-}
14+{-# language StandaloneKindSignatures #-}
15+{-# language TypeApplications #-}
16+{-# language TypeFamilyDependencies #-}
17+{-# language TypeOperators #-}
18+{-# language UndecidableInstances #-}
19+{-# language UndecidableSuperClasses #-}
20+
21+{-# options -Wno-orphans #-}
22+
23+module Rel8.Schema.HKD
24+ ( Lift
25+ , HKDT(..)
26+ ) where
27+
28+-- base
29+import Data.Functor.Compose ( Compose(..) )
30+import Data.Functor.Identity ( Identity(..), runIdentity )
31+import Data.Kind ( Constraint, Type )
32+import GHC.Generics
33+ ( (:*:)( (:*:) ), K1( K1 ), M1( M1 ), C, D, S, Meta( MetaSel )
34+ , Rep
35+ )
36+import GHC.TypeLits ( KnownSymbol )
37+import Prelude
38+
39+-- higgledy
40+import Data.Generic.HKD ( Construct, HKD( HKD, runHKD ), GHKD_, construct, deconstruct )
41+
42+-- rel8
43+import Rel8.Aggregate ( Col(..), Aggregate )
44+import Rel8.Expr ( Expr )
45+import Rel8.Schema.Context.Label
46+ ( Labelable
47+ , HLabelable, hlabeler, hunlabeler
48+ )
49+import Rel8.Schema.Dict ( Dict( Dict ) )
50+import Rel8.Schema.Field ( Reify, Reifiable(..), SContext(..), hunreify, hreify )
51+import Rel8.Schema.HTable ( HTable )
52+import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
53+import Rel8.Schema.HTable.Pair ( HPair( HPair ) )
54+import Rel8.Schema.HTable.Type ( HType( HType ) )
55+import Rel8.Schema.Insert ( Insert, Col(..) )
56+import qualified Rel8.Schema.Kind as K
57+import Rel8.Schema.Name ( Name(..) )
58+import Rel8.Schema.Null ( Sql )
59+import Rel8.Schema.Result ( Result )
60+import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
61+import Rel8.Table.Recontextualize ( Recontextualize )
62+import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
63+import Rel8.Type ( DBType )
64+
65+
66+type Column1Helper :: K.Context -> (Type -> Type) -> Type -> Constraint
67+class
68+ ( Table context (f a)
69+ , Context1 f ~ context
70+ , Context (f a) ~ context
71+ , Columns (f a) ~ HType a
72+ )
73+ => Column1Helper context f a | f -> context
74+instance
75+ ( Table context (f a)
76+ , Context1 f ~ context
77+ , Context (f a) ~ context
78+ , Columns (f a) ~ HType a
79+ )
80+ => Column1Helper context f a
81+
82+
83+type Column1 :: K.Context -> (Type -> Type) -> Constraint
84+class
85+ ( forall a. Sql DBType a => Column1Helper context f a
86+ , Context1 f ~ context
87+ ) =>
88+ Column1 context f | f -> context
89+instance
90+ ( forall a. Sql DBType a => Column1Helper context f a
91+ , Context1 f ~ context
92+ ) =>
93+ Column1 context f
94+
95+
96+type Context1 :: (Type -> Type) -> K.Context
97+type Context1 f = Context (f Bool)
98+
99+
100+toColumn1 :: forall a f context. (Column1 context f, Sql DBType a)
101+ => f a -> HType a (Col context)
102+toColumn1 = case Dict @(Column1Helper context f) @a of
103+ Dict -> toColumns
104+
105+
106+fromColumn1 :: forall a f context. (Column1 context f, Sql DBType a)
107+ => HType a (Col context) -> f a
108+fromColumn1 = case Dict @(Column1Helper context f) @a of
109+ Dict -> fromColumns
110+
111+
112+type Recontextualize1
113+ :: K.Context
114+ -> K.Context
115+ -> (Type -> Type)
116+ -> (Type -> Type)
117+ -> Constraint
118+class Recontextualize context context' (f Bool) (f' Bool) =>
119+ Recontextualize1 context context' f f'
120+instance Recontextualize context context' (f Bool) (f' Bool) =>
121+ Recontextualize1 context context' f f'
122+
123+
124+class HTable (GColumns rep) => GTable rep where
125+ toGColumns :: HLabelable context
126+ => (forall a. Sql DBType a => f a -> HType a context)
127+ -> GHKD_ f rep x
128+ -> GColumns rep context
129+ fromGColumns :: HLabelable context
130+ => (forall a. Sql DBType a => HType a context -> f a)
131+ -> GColumns rep context
132+ -> GHKD_ f rep x
133+
134+
135+instance GTable rep => GTable (M1 D c rep) where
136+ toGColumns f (M1 a) = toGColumns f a
137+ {-# INLINABLE toGColumns #-}
138+
139+ fromGColumns f = M1 . fromGColumns f
140+ {-# INLINABLE fromGColumns #-}
141+
142+
143+instance GTable rep => GTable (M1 C c rep) where
144+ toGColumns f (M1 a) = toGColumns f a
145+ {-# INLINABLE toGColumns #-}
146+
147+ fromGColumns f = M1 . fromGColumns f
148+ {-# INLINABLE fromGColumns #-}
149+
150+
151+instance (KnownSymbol name, Sql DBType a) =>
152+ GTable (M1 S ('MetaSel ('Just name) _su _ss _ds) (K1 i a))
153+ where
154+ toGColumns f (M1 (K1 a)) = hlabel hlabeler (f a)
155+ {-# INLINABLE toGColumns #-}
156+
157+ fromGColumns f a = M1 (K1 (f (hunlabel hunlabeler a)))
158+ {-# INLINABLE fromGColumns #-}
159+
160+
161+instance (GTable f, GTable g) => GTable (f :*: g) where
162+ toGColumns f (x :*: y) = HPair (toGColumns f x) (toGColumns f y)
163+ {-# INLINABLE toGColumns #-}
164+
165+ fromGColumns f (HPair x y) = fromGColumns f x :*: fromGColumns f y
166+ {-# INLINABLE fromGColumns #-}
167+
168+
169+type GRep a = GColumns (Rep a)
170+
171+
172+type GColumns :: (Type -> Type) -> K.HTable
173+type family GColumns rep where
174+ GColumns (M1 D _ f) = GColumns f
175+ GColumns (M1 C _ f) = GColumns f
176+ GColumns (M1 S ('MetaSel ('Just name) _ _ _) (K1 _ a)) =
177+ HLabel name (HType a)
178+ GColumns (f :*: g) = HPair (GColumns f) (GColumns g)
179+
180+
181+instance (GTable (Rep a), Column1 context f, Labelable context) =>
182+ Table context (HKD a f)
183+ where
184+ type Columns (HKD a f) = GRep a
185+ type Context (HKD a f) = Context1 f
186+
187+ toColumns = toGColumns toColumn1 . runHKD
188+ fromColumns = HKD . fromGColumns fromColumn1
189+
190+
191+instance
192+ ( a ~ a'
193+ , GTable (Rep a)
194+ , Recontextualize1 context context' f f'
195+ , Column1 context f, Labelable context
196+ , Column1 context' f', Labelable context'
197+ ) =>
198+ Recontextualize
199+ context
200+ context'
201+ (HKD a f)
202+ (HKD a' f')
203+
204+
205+type Lift :: K.Context -> Type -> Type
206+type family Lift context a where
207+ Lift (Reify context) a = ALift context a
208+ Lift Aggregate a = HKD a (Compose Aggregate Expr)
209+ Lift Expr a = HKD a Expr
210+ Lift Insert a = HKD a Expr
211+ Lift Name a = HKD a Name
212+ Lift Result a = a
213+
214+
215+type ALift :: K.Context -> Type -> Type
216+newtype ALift context a = ALift
217+ { unALift :: Lift context a
218+ }
219+
220+
221+instance
222+ ( Reifiable context
223+ , GTable (Rep a)
224+ , Construct Identity a
225+ )
226+ => Table (Reify context) (ALift context a)
227+ where
228+ type Context (ALift context a) = Reify context
229+ type Columns (ALift context a) = GRep a
230+
231+ fromColumns = sfromColumnsLift contextSing
232+ toColumns = stoColumnsLift contextSing
233+
234+
235+instance
236+ ( Reifiable context
237+ , Reifiable context'
238+ , GTable (Rep a)
239+ , Construct Identity a
240+ )
241+ => Recontextualize
242+ (Reify context)
243+ (Reify context')
244+ (ALift context a)
245+ (ALift context' a)
246+
247+
248+sfromColumnsLift :: forall a context. (GTable (Rep a), Construct Identity a)
249+ => SContext context
250+ -> GRep a (Col (Reify context))
251+ -> ALift context a
252+sfromColumnsLift = \case
253+ SAggregate ->
254+ ALift .
255+ HKD .
256+ fromGColumns (\(HType (Aggregation a)) -> Compose a) .
257+ hunreify
258+ SExpr -> ALift . fromColumns . hunreify
259+ SInsert ->
260+ ALift .
261+ HKD .
262+ fromGColumns (\(HType (RequiredInsert a)) -> a) .
263+ hunreify
264+ SName -> ALift . fromColumns . hunreify
265+ SResult -> ALift . runIdentity . construct . fromColumns . hunreify
266+ SReify context -> ALift . sfromColumnsLift context . hunreify
267+
268+
269+stoColumnsLift :: forall a context. (GTable (Rep a), Construct Identity a)
270+ => SContext context
271+ -> ALift context a
272+ -> GRep a (Col (Reify context))
273+stoColumnsLift = \case
274+ SAggregate ->
275+ hreify .
276+ toGColumns (\(Compose a) -> HType (Aggregation a)) .
277+ runHKD .
278+ unALift
279+ SExpr -> hreify . toColumns . unALift
280+ SInsert ->
281+ hreify .
282+ toGColumns (HType . RequiredInsert) .
283+ runHKD .
284+ unALift
285+ SName -> hreify . toColumns . unALift
286+ SResult -> hreify . toColumns . deconstruct @Identity . unALift
287+ SReify context -> hreify . stoColumnsLift context . unALift
288+
289+
290+type HKDT :: Type -> Type
291+newtype HKDT a = HKDT
292+ { unHKDT :: a
293+ }
294+
295+
296+instance (GTable (Rep a), Construct Identity a, x ~ HKD a Expr) =>
297+ ToExprs x (HKDT a)
298+ where
299+ toResult = toColumns . deconstruct @Identity . unHKDT
300+ fromResult = HKDT . runIdentity . construct . fromColumns
301+
302+
303+type instance FromExprs (HKD a Expr) = a
src/Rel8/Table/Serialize.hs+74−82
@@ -59,175 +59,167 @@ import Data.Functor.Apply ( WrappedApplicative(..) )
59import Data.These ( These )
59import Data.These ( These )
60
60
61
61
62−fromResult' :: forall exprs a. ToExprs a exprs => Columns exprs (Col Result) -> a
63−fromResult' = fromResult @_ @exprs
64−
65−
66−toResult' :: forall exprs a. ToExprs a exprs => a -> Columns exprs (Col Result)
67−toResult' = toResult @_ @exprs
68−
69−
70type ToExprs :: Type -> Type -> Constraint
62type ToExprs :: Type -> Type -> Constraint
71−class Table Expr exprs => ToExprs a exprs where
63+class Table Expr exprs => ToExprs exprs a where
72 fromResult :: Columns exprs (Col Result) -> a
64 fromResult :: Columns exprs (Col Result) -> a
73 toResult :: a -> Columns exprs (Col Result)
65 toResult :: a -> Columns exprs (Col Result)
74
66
75
67
76−instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs a x where
68+instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs x a where
77 fromResult (HType (Result a)) = a
69 fromResult (HType (Result a)) = a
78 toResult = HType . Result
70 toResult = HType . Result
79
71
80
72
81−instance (Sql DBType a, x ~ [a]) => ToExprs [a] (Expr x) where
73+instance (Sql DBType a, x ~ [a]) => ToExprs (Expr x) [a] where
82 fromResult (HType (Result a)) = a
74 fromResult (HType (Result a)) = a
83 toResult = HType . Result
75 toResult = HType . Result
84
76
85
77
86−instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Maybe a) (Expr x)
78+instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Expr x) (Maybe a)
87 where
79 where
88 fromResult (HType (Result a)) = a
80 fromResult (HType (Result a)) = a
89 toResult = HType . Result
81 toResult = HType . Result
90
82
91
83
92−instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (NonEmpty a) (Expr x)
84+instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (Expr x) (NonEmpty a)
93 where
85 where
94 fromResult (HType (Result a)) = a
86 fromResult (HType (Result a)) = a
95 toResult = HType . Result
87 toResult = HType . Result
96
88
97
89
98−instance (ToExprs a exprs1, ToExprs b exprs2, x ~ EitherTable exprs1 exprs2) =>
90+instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable exprs1 exprs2) =>
99− ToExprs (Either a b) x
91+ ToExprs x (Either a b)
100 where
92 where
101 fromResult =
93 fromResult =
102− bimap (fromResult' @exprs1) (fromResult' @exprs2) .
94+ bimap (fromResult @exprs1) (fromResult @exprs2) .
103 fromColumns
95 fromColumns
104 toResult =
96 toResult =
105 toColumns .
97 toColumns .
106− bimap (toResult' @exprs1) (toResult' @exprs2)
98+ bimap (toResult @exprs1) (toResult @exprs2)
107
99
108
100
109−instance ToExprs a exprs => ToExprs [a] (ListTable exprs) where
101+instance ToExprs exprs a => ToExprs (ListTable exprs) [a] where
110− fromResult = fmap (fromResult' @exprs) . fromColumns
102+ fromResult = fmap (fromResult @exprs) . fromColumns
111− toResult = toColumns . fmap (toResult' @exprs)
103+ toResult = toColumns . fmap (toResult @exprs)
112
104
113
105
114−instance ToExprs a exprs => ToExprs (Maybe a) (MaybeTable exprs) where
106+instance ToExprs exprs a => ToExprs (MaybeTable exprs) (Maybe a) where
115− fromResult = fmap (fromResult' @exprs) . fromColumns
107+ fromResult = fmap (fromResult @exprs) . fromColumns
116− toResult = toColumns . fmap (toResult' @exprs)
108+ toResult = toColumns . fmap (toResult @exprs)
117
109
118
110
119−instance ToExprs a exprs => ToExprs (NonEmpty a) (NonEmptyTable exprs)
111+instance ToExprs exprs a => ToExprs (NonEmptyTable exprs) (NonEmpty a)
120 where
112 where
121− fromResult = fmap (fromResult' @exprs) . fromColumns
113+ fromResult = fmap (fromResult @exprs) . fromColumns
122− toResult = toColumns . fmap (toResult' @exprs)
114+ toResult = toColumns . fmap (toResult @exprs)
123
115
124
116
125−instance (ToExprs a exprs1, ToExprs b exprs2, x ~ TheseTable exprs1 exprs2) =>
117+instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable exprs1 exprs2) =>
126− ToExprs (These a b) x
118+ ToExprs x (These a b)
127 where
119 where
128 fromResult =
120 fromResult =
129− bimap (fromResult' @exprs1) (fromResult' @exprs2) .
121+ bimap (fromResult @exprs1) (fromResult @exprs2) .
130 fromColumns
122 fromColumns
131 toResult =
123 toResult =
132 toColumns .
124 toColumns .
133− bimap (toResult' @exprs1) (toResult' @exprs2)
125+ bimap (toResult @exprs1) (toResult @exprs2)
134
126
135
127
136−instance (ToExprs a exprs1, ToExprs b exprs2, x ~ (exprs1, exprs2)) =>
128+instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ (exprs1, exprs2)) =>
137− ToExprs (a, b) x
129+ ToExprs x (a, b)
138 where
130 where
139 fromResult (HPair a b) =
131 fromResult (HPair a b) =
140− ( fromResult' @exprs1 $ hunlabel unlabeler a
132+ ( fromResult @exprs1 $ hunlabel unlabeler a
141− , fromResult' @exprs2 $ hunlabel unlabeler b
133+ , fromResult @exprs2 $ hunlabel unlabeler b
142 )
134 )
143 toResult (a, b) = HPair
135 toResult (a, b) = HPair
144− { hfst = hlabel labeler $ toResult' @exprs1 a
136+ { hfst = hlabel labeler $ toResult @exprs1 a
145− , hsnd = hlabel labeler $ toResult' @exprs2 b
137+ , hsnd = hlabel labeler $ toResult @exprs2 b
146 }
138 }
147
139
148
140
149instance
141instance
150− ( ToExprs a exprs1
142+ ( ToExprs exprs1 a
151− , ToExprs b exprs2
143+ , ToExprs exprs2 b
152− , ToExprs c exprs3
144+ , ToExprs exprs3 c
153 , x ~ (exprs1, exprs2, exprs3)
145 , x ~ (exprs1, exprs2, exprs3)
154− ) => ToExprs (a, b, c) x
146+ ) => ToExprs x (a, b, c)
155 where
147 where
156 fromResult (HTrio a b c) =
148 fromResult (HTrio a b c) =
157− ( fromResult' @exprs1 $ hunlabel unlabeler a
149+ ( fromResult @exprs1 $ hunlabel unlabeler a
158− , fromResult' @exprs2 $ hunlabel unlabeler b
150+ , fromResult @exprs2 $ hunlabel unlabeler b
159− , fromResult' @exprs3 $ hunlabel unlabeler c
151+ , fromResult @exprs3 $ hunlabel unlabeler c
160 )
152 )
161 toResult (a, b, c) = HTrio
153 toResult (a, b, c) = HTrio
162− { hfst = hlabel labeler $ toResult' @exprs1 a
154+ { hfst = hlabel labeler $ toResult @exprs1 a
163− , hsnd = hlabel labeler $ toResult' @exprs2 b
155+ , hsnd = hlabel labeler $ toResult @exprs2 b
164− , htrd = hlabel labeler $ toResult' @exprs3 c
156+ , htrd = hlabel labeler $ toResult @exprs3 c
165 }
157 }
166
158
167
159
168instance
160instance
169− ( ToExprs a exprs1
161+ ( ToExprs exprs1 a
170− , ToExprs b exprs2
162+ , ToExprs exprs2 b
171− , ToExprs c exprs3
163+ , ToExprs exprs3 c
172− , ToExprs d exprs4
164+ , ToExprs exprs4 d
173 , x ~ (exprs1, exprs2, exprs3, exprs4)
165 , x ~ (exprs1, exprs2, exprs3, exprs4)
174− ) => ToExprs (a, b, c, d) x
166+ ) => ToExprs x (a, b, c, d)
175 where
167 where
176 fromResult (HQuartet a b c d) =
168 fromResult (HQuartet a b c d) =
177− ( fromResult' @exprs1 $ hunlabel unlabeler a
169+ ( fromResult @exprs1 $ hunlabel unlabeler a
178− , fromResult' @exprs2 $ hunlabel unlabeler b
170+ , fromResult @exprs2 $ hunlabel unlabeler b
179− , fromResult' @exprs3 $ hunlabel unlabeler c
171+ , fromResult @exprs3 $ hunlabel unlabeler c
180− , fromResult' @exprs4 $ hunlabel unlabeler d
172+ , fromResult @exprs4 $ hunlabel unlabeler d
181 )
173 )
182 toResult (a, b, c, d) = HQuartet
174 toResult (a, b, c, d) = HQuartet
183− { hfst = hlabel labeler $ toResult' @exprs1 a
175+ { hfst = hlabel labeler $ toResult @exprs1 a
184− , hsnd = hlabel labeler $ toResult' @exprs2 b
176+ , hsnd = hlabel labeler $ toResult @exprs2 b
185− , htrd = hlabel labeler $ toResult' @exprs3 c
177+ , htrd = hlabel labeler $ toResult @exprs3 c
186− , hfrt = hlabel labeler $ toResult' @exprs4 d
178+ , hfrt = hlabel labeler $ toResult @exprs4 d
187 }
179 }
188
180
189
181
190instance
182instance
191− ( ToExprs a exprs1
183+ ( ToExprs exprs1 a
192− , ToExprs b exprs2
184+ , ToExprs exprs2 b
193− , ToExprs c exprs3
185+ , ToExprs exprs3 c
194− , ToExprs d exprs4
186+ , ToExprs exprs4 d
195− , ToExprs e exprs5
187+ , ToExprs exprs5 e
196 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5)
188 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5)
197− ) => ToExprs (a, b, c, d, e) x
189+ ) => ToExprs x (a, b, c, d, e)
198 where
190 where
199 fromResult (HQuintet a b c d e) =
191 fromResult (HQuintet a b c d e) =
200− ( fromResult' @exprs1 $ hunlabel unlabeler a
192+ ( fromResult @exprs1 $ hunlabel unlabeler a
201− , fromResult' @exprs2 $ hunlabel unlabeler b
193+ , fromResult @exprs2 $ hunlabel unlabeler b
202− , fromResult' @exprs3 $ hunlabel unlabeler c
194+ , fromResult @exprs3 $ hunlabel unlabeler c
203− , fromResult' @exprs4 $ hunlabel unlabeler d
195+ , fromResult @exprs4 $ hunlabel unlabeler d
204− , fromResult' @exprs5 $ hunlabel unlabeler e
196+ , fromResult @exprs5 $ hunlabel unlabeler e
205 )
197 )
206 toResult (a, b, c, d, e) = HQuintet
198 toResult (a, b, c, d, e) = HQuintet
207− { hfst = hlabel labeler $ toResult' @exprs1 a
199+ { hfst = hlabel labeler $ toResult @exprs1 a
208− , hsnd = hlabel labeler $ toResult' @exprs2 b
200+ , hsnd = hlabel labeler $ toResult @exprs2 b
209− , htrd = hlabel labeler $ toResult' @exprs3 c
201+ , htrd = hlabel labeler $ toResult @exprs3 c
210− , hfrt = hlabel labeler $ toResult' @exprs4 d
202+ , hfrt = hlabel labeler $ toResult @exprs4 d
211− , hfft = hlabel labeler $ toResult' @exprs5 e
203+ , hfft = hlabel labeler $ toResult @exprs5 e
212 }
204 }
213
205
214
206
215instance (HTable t, result ~ Col Result, x ~ t (Col Expr)) =>
207instance (HTable t, result ~ Col Result, x ~ t (Col Expr)) =>
216− ToExprs (t result) x
208+ ToExprs x (t result)
217 where
209 where
218 fromResult = id
210 fromResult = id
219 toResult = id
211 toResult = id
220
212
221
213
222instance (Recontextualize Result Expr (t Result) (t Expr), result ~ Result, x ~ t Expr) =>
214instance (Recontextualize Result Expr (t Result) (t Expr), result ~ Result, x ~ t Expr) =>
223− ToExprs (t result) x
215+ ToExprs x (t result)
224 where
216 where
225 fromResult = fromColumns
217 fromResult = fromColumns
226 toResult = toColumns
218 toResult = toColumns
227
219
228
220
229instance (KnownSpec spec, x ~ Col Expr spec) =>
221instance (KnownSpec spec, x ~ Col Expr spec) =>
230− ToExprs (Col Result spec) x
222+ ToExprs x (Col Result spec)
231 where
223 where
232 fromResult = fromColumns
224 fromResult = fromColumns
233 toResult = toColumns
225 toResult = toColumns
@@ -256,19 +248,19 @@ type instance FromExprs (t (Col Expr)) = t (Col Result)
256-- @sql@, which contains SQL expressions, and the type @haskell@, which
248-- @sql@, which contains SQL expressions, and the type @haskell@, which
257-- contains the Haskell decoding of rows containing @sql@ SQL expressions.
249-- contains the Haskell decoding of rows containing @sql@ SQL expressions.
258type Serializable :: Type -> Type -> Constraint
250type Serializable :: Type -> Type -> Constraint
259−class (ToExprs a exprs, a ~ FromExprs exprs) => Serializable exprs a | exprs -> a
251+class (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a | exprs -> a
260−instance (ToExprs a exprs, a ~ FromExprs exprs) => Serializable exprs a
252+instance (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a
261instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a
253instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a
262
254
263
255
264-- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is
256-- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is
265-- capable of lifting single @Expr@s to full tables.
257-- capable of lifting single @Expr@s to full tables.
266lit :: forall exprs a. Serializable exprs a => a -> exprs
258lit :: forall exprs a. Serializable exprs a => a -> exprs
267−lit = fromColumns . litHTable . toResult' @exprs
259+lit = fromColumns . litHTable . toResult @exprs
268
260
269
261
270parse :: forall exprs a. Serializable exprs a => Hasql.Row a
262parse :: forall exprs a. Serializable exprs a => Hasql.Row a
271−parse = fromResult' @exprs <$> parseHTable
263+parse = fromResult @exprs <$> parseHTable
272
264
273
265
274type Encodes :: Type -> Type -> Constraint
266type Encodes :: Type -> Type -> Constraint