@@ -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 #-}
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 #-}
21−{-# options -Wno-orphans #-}
23−module Rel8.Schema.HKD
29−import Data.Functor.Compose ( Compose(..) )
30−import Data.Functor.Identity ( Identity(..), runIdentity )
31−import Data.Kind ( Constraint, Type )
33− ( (:*:)( (:*:) ), K1( K1 ), M1( M1 ), C, D, S, Meta( MetaSel )
36−import GHC.TypeLits ( KnownSymbol )
40−import Data.Generic.HKD ( Construct, HKD(..), GHKD_, construct, deconstruct )
43−import Rel8.Aggregate ( Col(..), Aggregate )
44−import Rel8.Expr ( Expr )
45−import Rel8.Kind.Context ( Reifiable(..), SContext(..) )
46−import Rel8.Schema.Context.Label
48− , HLabelable, hlabeler, hunlabeler
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 )
62− ( Table, Columns, Context, fromColumns, toColumns
63− , Unreify, reify, unreify
65−import Rel8.Table.Recontextualize ( Recontextualize )
66−import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
67−import Rel8.Type ( DBType )
70−type Column1Helper :: K.Context -> (Type -> Type) -> Type -> Constraint
72− ( Table context (f a)
73− , Context1 f ~ context
74− , Context (f a) ~ context
75− , Columns (f a) ~ HType a
77− => Column1Helper context f a | f -> context
79− ( Table context (f a)
80− , Context1 f ~ context
81− , Context (f a) ~ context
82− , Columns (f a) ~ HType a
84− => Column1Helper context f a
87−type Column1 :: K.Context -> (Type -> Type) -> Constraint
89− ( forall a. Sql DBType a => Column1Helper context f a
90− , Context1 f ~ context
92− Column1 context f | f -> context
94− ( forall a. Sql DBType a => Column1Helper context f a
95− , Context1 f ~ context
100−type Context1 :: (Type -> Type) -> K.Context
101−type Context1 f = Context (f Bool)
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
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
116−type Recontextualize1
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'
128−class HTable (GColumns rep) => GTable rep where
129− toGColumns :: HLabelable context
130− => (forall a. Sql DBType a => f a -> HType a context)
132− -> GColumns rep context
133− fromGColumns :: HLabelable context
134− => (forall a. Sql DBType a => HType a context -> f a)
135− -> GColumns rep context
139−instance GTable rep => GTable (M1 D c rep) where
140− toGColumns f (M1 a) = toGColumns f a
141− {-# INLINABLE toGColumns #-}
143− fromGColumns f = M1 . fromGColumns f
144− {-# INLINABLE fromGColumns #-}
147−instance GTable rep => GTable (M1 C c rep) where
148− toGColumns f (M1 a) = toGColumns f a
149− {-# INLINABLE toGColumns #-}
151− fromGColumns f = M1 . fromGColumns f
152− {-# INLINABLE fromGColumns #-}
155−instance (KnownSymbol name, Sql DBType a) =>
156− GTable (M1 S ('MetaSel ('Just name) _su _ss _ds) (K1 i a))
158− toGColumns f (M1 (K1 a)) = hlabel hlabeler (f a)
159− {-# INLINABLE toGColumns #-}
161− fromGColumns f a = M1 (K1 (f (hunlabel hunlabeler a)))
162− {-# INLINABLE fromGColumns #-}
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 #-}
169− fromGColumns f (HProduct x y) = fromGColumns f x :*: fromGColumns f y
170− {-# INLINABLE fromGColumns #-}
173−type GRep a = GColumns (Rep a)
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)
191− => Table context (HKD a f)
193− type Columns (HKD a f) = GRep a
194− type Context (HKD a f) = Context1 f
196− toColumns = toGColumns toColumn1 . runHKD
197− fromColumns = HKD . fromGColumns fromColumn1
205− , NotReify context, NotReify context'
206− , Recontextualize1 context context' f f'
207− , Column1 context f, Labelable context
208− , Column1 context' f', Labelable context'
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
227−type ALift :: K.Context -> Type -> Type
228−newtype ALift context a = ALift
229− { unALift :: Lift context a
236− , Construct Identity a
238− => Table (Reify context) (ALift context a)
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
244− fromColumns = sfromColumnsLift contextSing
245− toColumns = stoColumnsLift contextSing
247− unreify _ (ALift a) = a
252− , Reifiable context'
254− , Construct Identity a
263−sfromColumnsLift :: forall a context. (GTable (Rep a), Construct Identity a)
265− -> GRep a (Col (Reify context))
267−sfromColumnsLift = \case
271− fromGColumns (\(HType (Aggregation a)) -> Compose a) .
273− SExpr -> ALift . fromColumns . hunreify
277− fromGColumns (\(HType (RequiredInsert a)) -> a) .
279− SName -> ALift . fromColumns . hunreify
280− SResult -> ALift . runIdentity . construct . fromColumns . hunreify
281− SReify context -> ALift . sfromColumnsLift context . hunreify
284−stoColumnsLift :: forall a context. (GTable (Rep a), Construct Identity a)
287− -> GRep a (Col (Reify context))
288−stoColumnsLift = \case
291− toGColumns (\(Compose a) -> HType (Aggregation a)) .
294− SExpr -> hreify . toColumns . unALift
297− toGColumns (HType . RequiredInsert) .
300− SName -> hreify . toColumns . unALift
301− SResult -> hreify . toColumns . deconstruct @Identity . unALift
302− SReify context -> hreify . stoColumnsLift context . unALift
305−type HKDT :: Type -> Type
306−newtype HKDT a = HKDT
311−instance (GTable (Rep a), Construct Identity a, x ~ HKD a Expr) =>
314− toResult = toColumns . deconstruct @Identity . unHKDT
315− fromResult = HKDT . runIdentity . construct . fromColumns
318−type instance FromExprs (HKD a Expr) = a