git.iko.soy/rel8
on 23bb65b help sign in
rel8/src/Rel8/Column/Lift.hs
129 lines 3.5 kB history raw
1{-# language DataKinds #-}
2{-# language FlexibleContexts #-}
3{-# language LambdaCase #-}
4{-# language MultiParamTypeClasses #-}
5{-# language ScopedTypeVariables #-}
6{-# language StandaloneKindSignatures #-}
7{-# language TypeApplications #-}
8{-# language TypeFamilies #-}
9{-# language UndecidableInstances #-}
11module Rel8.Column.Lift
12 ( Lift, ALift(..)
13 )
14where
16-- base
17import Data.Functor.Compose ( Compose(..) )
18import Data.Functor.Identity ( Identity(..), runIdentity )
19import Data.Kind ( Type )
20import GHC.Generics ( Rep )
21import Prelude
23-- higgledy
24import Data.Generic.HKD ( Construct, HKD(..), construct, deconstruct )
26-- rel8
27import Rel8.Aggregate ( Col(..), Aggregate )
28import Rel8.Expr ( Expr )
29import Rel8.Generic.HKD ( GTable, GColumns, gfromColumns, gtoColumns )
30import Rel8.Kind.Context ( Reifiable(..), SContext(..) )
31import Rel8.Schema.HTable.Type ( HType( HType ) )
32import Rel8.Schema.Insert ( Insert, Col(..) )
33import qualified Rel8.Schema.Kind as K
34import Rel8.Schema.Name ( Name(..) )
35import Rel8.Schema.Reify ( Reify, hreify, hunreify )
36import Rel8.Schema.Result ( Result )
37import Rel8.Table
38 ( Table, Columns, Context, fromColumns, toColumns
39 , Unreify, reify, unreify
40 )
41import Rel8.Table.Recontextualize ( Recontextualize )
44type Lift :: K.Context -> Type -> Type
45type family Lift context a where
46 Lift (Reify context) a = ALift context a
47 Lift Aggregate a = HKD a (Compose Aggregate Expr)
48 Lift Expr a = HKD a Expr
49 Lift Insert a = HKD a Expr
50 Lift Name a = HKD a Name
51 Lift Result a = a
54type ALift :: K.Context -> Type -> Type
55newtype ALift context a = ALift
56 { unALift :: Lift context a
57 }
60instance
61 ( Reifiable context
62 , GTable (Rep a)
63 , Construct Identity a
64 )
65 => Table (Reify context) (ALift context a)
66 where
67 type Context (ALift context a) = Reify context
68 type Columns (ALift context a) = GColumns (Rep a)
69 type Unreify (ALift context a) = Lift context a
71 fromColumns = sfromColumnsLift contextSing
72 toColumns = stoColumnsLift contextSing
73 reify _ = ALift
74 unreify _ (ALift a) = a
77instance
78 ( Reifiable context
79 , Reifiable context'
80 , GTable (Rep a)
81 , Construct Identity a
82 )
83 => Recontextualize
84 (Reify context)
85 (Reify context')
86 (ALift context a)
87 (ALift context' a)
90sfromColumnsLift :: forall a context. (GTable (Rep a), Construct Identity a)
91 => SContext context
92 -> GColumns (Rep a) (Col (Reify context))
93 -> ALift context a
94sfromColumnsLift = \case
95 SAggregate ->
96 ALift .
97 HKD .
98 gfromColumns (\(HType (Aggregation a)) -> Compose a) .
99 hunreify
100 SExpr -> ALift . fromColumns . hunreify
101 SInsert ->
102 ALift .
103 HKD .
104 gfromColumns (\(HType (RequiredInsert a)) -> a) .
105 hunreify
106 SName -> ALift . fromColumns . hunreify
107 SResult -> ALift . runIdentity . construct . fromColumns . hunreify
108 SReify context -> ALift . sfromColumnsLift context . hunreify
111stoColumnsLift :: forall a context. (GTable (Rep a), Construct Identity a)
112 => SContext context
113 -> ALift context a
114 -> GColumns (Rep a) (Col (Reify context))
115stoColumnsLift = \case
116 SAggregate ->
117 hreify .
118 gtoColumns (\(Compose a) -> HType (Aggregation a)) .
119 runHKD .
120 unALift
121 SExpr -> hreify . toColumns . unALift
122 SInsert ->
123 hreify .
124 gtoColumns (HType . RequiredInsert) .
125 runHKD .
126 unALift
127 SName -> hreify . toColumns . unALift
128 SResult -> hreify . toColumns . deconstruct @Identity . unALift
129 SReify context -> hreify . stoColumnsLift context . unALift