@@ -1,318 +0,0 @@
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(..), GHKD_, construct, deconstruct )
41−
42−-- rel8
43−import Rel8.Aggregate ( Col(..), Aggregate )
44−import Rel8.Expr ( Expr )
45−import Rel8.Kind.Context ( Reifiable(..), SContext(..) )
46−import Rel8.Schema.Context.Label
47− ( Labelable
48− , HLabelable, hlabeler, hunlabeler
49− )
50−import Rel8.Schema.Dict ( Dict( Dict ) )
51−import Rel8.Schema.HTable ( HTable )
52−import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
53−import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )
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.Reify ( Reify, hreify, hunreify, NotReify, notReify )
60−import Rel8.Schema.Result ( Result )
61−import Rel8.Table
62− ( Table, Columns, Context, fromColumns, toColumns
63− , Unreify, reify, unreify
64− )
65−import Rel8.Table.Recontextualize ( Recontextualize )
66−import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
67−import Rel8.Type ( DBType )
68−
69−
70−type Column1Helper :: K.Context -> (Type -> Type) -> Type -> Constraint
71−class
72− ( Table context (f a)
73− , Context1 f ~ context
74− , Context (f a) ~ context
75− , Columns (f a) ~ HType a
76− )
77− => Column1Helper context f a | f -> context
78−instance
79− ( Table context (f a)
80− , Context1 f ~ context
81− , Context (f a) ~ context
82− , Columns (f a) ~ HType a
83− )
84− => Column1Helper context f a
85−
86−
87−type Column1 :: K.Context -> (Type -> Type) -> Constraint
88−class
89− ( forall a. Sql DBType a => Column1Helper context f a
90− , Context1 f ~ context
91− ) =>
92− Column1 context f | f -> context
93−instance
94− ( forall a. Sql DBType a => Column1Helper context f a
95− , Context1 f ~ context
96− ) =>
97− Column1 context f
98−
99−
100−type Context1 :: (Type -> Type) -> K.Context
101−type Context1 f = Context (f Bool)
102−
103−
104−toColumn1 :: forall a f context. (Column1 context f, Sql DBType a)
105− => f a -> HType a (Col context)
106−toColumn1 = case Dict @(Column1Helper context f) @a of
107− Dict -> toColumns
108−
109−
110−fromColumn1 :: forall a f context. (Column1 context f, Sql DBType a)
111− => HType a (Col context) -> f a
112−fromColumn1 = case Dict @(Column1Helper context f) @a of
113− Dict -> fromColumns
114−
115−
116−type Recontextualize1
117− :: K.Context
118− -> K.Context
119− -> (Type -> Type)
120− -> (Type -> Type)
121− -> Constraint
122−class Recontextualize context context' (f Bool) (f' Bool) =>
123− Recontextualize1 context context' f f'
124−instance Recontextualize context context' (f Bool) (f' Bool) =>
125− Recontextualize1 context context' f f'
126−
127−
128−class HTable (GColumns rep) => GTable rep where
129− toGColumns :: HLabelable context
130− => (forall a. Sql DBType a => f a -> HType a context)
131− -> GHKD_ f rep x
132− -> GColumns rep context
133− fromGColumns :: HLabelable context
134− => (forall a. Sql DBType a => HType a context -> f a)
135− -> GColumns rep context
136− -> GHKD_ f rep x
137−
138−
139−instance GTable rep => GTable (M1 D c rep) where
140− toGColumns f (M1 a) = toGColumns f a
141− {-# INLINABLE toGColumns #-}
142−
143− fromGColumns f = M1 . fromGColumns f
144− {-# INLINABLE fromGColumns #-}
145−
146−
147−instance GTable rep => GTable (M1 C c rep) where
148− toGColumns f (M1 a) = toGColumns f a
149− {-# INLINABLE toGColumns #-}
150−
151− fromGColumns f = M1 . fromGColumns f
152− {-# INLINABLE fromGColumns #-}
153−
154−
155−instance (KnownSymbol name, Sql DBType a) =>
156− GTable (M1 S ('MetaSel ('Just name) _su _ss _ds) (K1 i a))
157− where
158− toGColumns f (M1 (K1 a)) = hlabel hlabeler (f a)
159− {-# INLINABLE toGColumns #-}
160−
161− fromGColumns f a = M1 (K1 (f (hunlabel hunlabeler a)))
162− {-# INLINABLE fromGColumns #-}
163−
164−
165−instance (GTable f, GTable g) => GTable (f :*: g) where
166− toGColumns f (x :*: y) = HProduct (toGColumns f x) (toGColumns f y)
167− {-# INLINABLE toGColumns #-}
168−
169− fromGColumns f (HProduct x y) = fromGColumns f x :*: fromGColumns f y
170− {-# INLINABLE fromGColumns #-}
171−
172−
173−type GRep a = GColumns (Rep a)
174−
175−
176−type GColumns :: (Type -> Type) -> K.HTable
177−type family GColumns rep where
178− GColumns (M1 D _ f) = GColumns f
179− GColumns (M1 C _ f) = GColumns f
180− GColumns (M1 S ('MetaSel ('Just name) _ _ _) (K1 _ a)) =
181− HLabel name (HType a)
182− GColumns (f :*: g) = HProduct (GColumns f) (GColumns g)
183−
184−
185−instance
186− ( GTable (Rep a)
187− , Column1 context f
188− , Labelable context
189− , NotReify context
190− )
191− => Table context (HKD a f)
192− where
193− type Columns (HKD a f) = GRep a
194− type Context (HKD a f) = Context1 f
195−
196− toColumns = toGColumns toColumn1 . runHKD
197− fromColumns = HKD . fromGColumns fromColumn1
198− reify = notReify
199− unreify = notReify
200−
201−
202−instance
203− ( a ~ a'
204− , GTable (Rep a)
205− , NotReify context, NotReify context'
206− , Recontextualize1 context context' f f'
207− , Column1 context f, Labelable context
208− , Column1 context' f', Labelable context'
209− ) =>
210− Recontextualize
211− context
212− context'
213− (HKD a f)
214− (HKD a' f')
215−
216−
217−type Lift :: K.Context -> Type -> Type
218−type family Lift context a where
219− Lift (Reify context) a = ALift context a
220− Lift Aggregate a = HKD a (Compose Aggregate Expr)
221− Lift Expr a = HKD a Expr
222− Lift Insert a = HKD a Expr
223− Lift Name a = HKD a Name
224− Lift Result a = a
225−
226−
227−type ALift :: K.Context -> Type -> Type
228−newtype ALift context a = ALift
229− { unALift :: Lift context a
230− }
231−
232−
233−instance
234− ( Reifiable context
235− , GTable (Rep a)
236− , Construct Identity a
237− )
238− => Table (Reify context) (ALift context a)
239− where
240− type Context (ALift context a) = Reify context
241− type Columns (ALift context a) = GRep a
242− type Unreify (ALift context a) = Lift context a
243−
244− fromColumns = sfromColumnsLift contextSing
245− toColumns = stoColumnsLift contextSing
246− reify _ = ALift
247− unreify _ (ALift a) = a
248−
249−
250−instance
251− ( Reifiable context
252− , Reifiable context'
253− , GTable (Rep a)
254− , Construct Identity a
255− )
256− => Recontextualize
257− (Reify context)
258− (Reify context')
259− (ALift context a)
260− (ALift context' a)
261−
262−
263−sfromColumnsLift :: forall a context. (GTable (Rep a), Construct Identity a)
264− => SContext context
265− -> GRep a (Col (Reify context))
266− -> ALift context a
267−sfromColumnsLift = \case
268− SAggregate ->
269− ALift .
270− HKD .
271− fromGColumns (\(HType (Aggregation a)) -> Compose a) .
272− hunreify
273− SExpr -> ALift . fromColumns . hunreify
274− SInsert ->
275− ALift .
276− HKD .
277− fromGColumns (\(HType (RequiredInsert a)) -> a) .
278− hunreify
279− SName -> ALift . fromColumns . hunreify
280− SResult -> ALift . runIdentity . construct . fromColumns . hunreify
281− SReify context -> ALift . sfromColumnsLift context . hunreify
282−
283−
284−stoColumnsLift :: forall a context. (GTable (Rep a), Construct Identity a)
285− => SContext context
286− -> ALift context a
287− -> GRep a (Col (Reify context))
288−stoColumnsLift = \case
289− SAggregate ->
290− hreify .
291− toGColumns (\(Compose a) -> HType (Aggregation a)) .
292− runHKD .
293− unALift
294− SExpr -> hreify . toColumns . unALift
295− SInsert ->
296− hreify .
297− toGColumns (HType . RequiredInsert) .
298− runHKD .
299− unALift
300− SName -> hreify . toColumns . unALift
301− SResult -> hreify . toColumns . deconstruct @Identity . unALift
302− SReify context -> hreify . stoColumnsLift context . unALift
303−
304−
305−type HKDT :: Type -> Type
306−newtype HKDT a = HKDT
307− { unHKDT :: a
308− }
309−
310−
311−instance (GTable (Rep a), Construct Identity a, x ~ HKD a Expr) =>
312− ToExprs x (HKDT a)
313− where
314− toResult = toColumns . deconstruct @Identity . unHKDT
315− fromResult = HKDT . runIdentity . construct . fromColumns
316−
317−
318−type instance FromExprs (HKD a Expr) = a