git.iko.soy/rel8
on 4e1b3b7 help sign in
rel8/src/Rel8/Generic/Table/Record.hs
200 lines 6.2 kB history raw
1{-# language AllowAmbiguousTypes #-}
2{-# language DataKinds #-}
3{-# language FlexibleContexts #-}
4{-# language FlexibleInstances #-}
5{-# language MultiParamTypeClasses #-}
6{-# language PolyKinds #-}
7{-# language RankNTypes #-}
8{-# language ScopedTypeVariables #-}
9{-# language StandaloneKindSignatures #-}
10{-# language TypeApplications #-}
11{-# language TypeFamilies #-}
12{-# language TypeOperators #-}
13{-# language UndecidableInstances #-}
15module Rel8.Generic.Table.Record
16 ( GTable, GColumns, GContext, gfromColumns, gtoColumns, gtable
17 , GToExprs, gfromResult, gtoResult
18 )
19where
21-- base
22import Data.Kind ( Constraint, Type )
23import Data.Proxy ( Proxy( Proxy ) )
24import GHC.Generics
25 ( (:*:)( (:*:) ), K1( K1 ), M1( M1 )
26 , C, D, S
27 , Meta( MetaSel )
28 )
29import Prelude hiding ( null )
31-- rel8
32import Rel8.FCF ( Eval, Exp )
33import Rel8.Schema.Context ( Col )
34import Rel8.Schema.HTable ( HTable )
35import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
36import Rel8.Schema.HTable.Product ( HProduct(..) )
37import qualified Rel8.Schema.Kind as K
38import Rel8.Schema.Result ( Result )
41type GColumns :: (Type -> Exp K.HTable) -> (Type -> Type) -> K.HTable
42type family GColumns _Columns rep where
43 GColumns _Columns (M1 D _ rep) = GColumns _Columns rep
44 GColumns _Columns (M1 C _ rep) = GColumns _Columns rep
45 GColumns _Columns (rep1 :*: rep2) =
46 HProduct (GColumns _Columns rep1) (GColumns _Columns rep2)
47 GColumns _Columns (M1 S ('MetaSel ('Just label) _ _ _) (K1 _ a)) =
48 HLabel label (Eval (_Columns a))
51type GContext :: (Type -> Exp K.Context) -> (Type -> Type) -> K.Context
52type family GContext _Context rep where
53 GContext _Context (M1 _ _ rep) = GContext _Context rep
54 GContext _Context (rep1 :*: _rep2) = GContext _Context rep1
55 GContext _Context (K1 _ a) = Eval (_Context a)
58type GTable
59 :: (Type -> Exp Constraint)
60 -> (Type -> Exp K.HTable)
61 -> K.HContext -> (Type -> Type) -> Constraint
62class GTable _Table _Columns context rep
63 where
64 gfromColumns :: ()
65 => (forall a. Eval (_Table a) => Eval (_Columns a) context -> a)
66 -> GColumns _Columns rep context
67 -> rep x
69 gtoColumns :: ()
70 => (forall a. Eval (_Table a) => a -> Eval (_Columns a) context)
71 -> rep x
72 -> GColumns _Columns rep context
74 gtable :: ()
75 => (forall a proxy. Eval (_Table a) => proxy a -> Eval (_Columns a) context)
76 -> GColumns _Columns rep context
79instance GTable _Table _Columns context rep =>
80 GTable _Table _Columns context (M1 D c rep)
81 where
82 gfromColumns fromColumns =
83 M1 . gfromColumns @_Table @_Columns @context @rep fromColumns
84 gtoColumns toColumns (M1 a) =
85 gtoColumns @_Table @_Columns @context @rep toColumns a
86 gtable = gtable @_Table @_Columns @context @rep
89instance GTable _Table _Columns context rep =>
90 GTable _Table _Columns context (M1 C c rep)
91 where
92 gfromColumns fromColumns =
93 M1 . gfromColumns @_Table @_Columns @context @rep fromColumns
94 gtoColumns toColumns (M1 a) =
95 gtoColumns @_Table @_Columns @context @rep toColumns a
96 gtable = gtable @_Table @_Columns @context @rep
99instance
100 ( GTable _Table _Columns context rep1
101 , GTable _Table _Columns context rep2
102 )
103 => GTable _Table _Columns context (rep1 :*: rep2)
104 where
105 gfromColumns fromColumns (HProduct a b) =
106 gfromColumns @_Table @_Columns @context @rep1 fromColumns a :*:
107 gfromColumns @_Table @_Columns @context @rep2 fromColumns b
108 gtoColumns toColumns (a :*: b) = HProduct
109 (gtoColumns @_Table @_Columns @context @rep1 toColumns a)
110 (gtoColumns @_Table @_Columns @context @rep2 toColumns b)
111 gtable table = HProduct
112 (gtable @_Table @_Columns @context @rep1 table)
113 (gtable @_Table @_Columns @context @rep2 table)
116instance
117 ( Eval (_Table a)
118 , meta ~ 'MetaSel ('Just label) _su _ss _ds
119 , k1 ~ K1 i a
120 )
121 => GTable _Table _Columns context (M1 S meta k1)
122 where
123 gfromColumns fromColumns = M1 . K1 . fromColumns . hunlabel
124 gtoColumns toColumns (M1 (K1 a)) = hlabel (toColumns a)
125 gtable table = hlabel (table (Proxy @a))
128type GToExprs
129 :: (Type -> Type -> Exp Constraint)
130 -> (Type -> Exp K.HTable)
131 -> (Type -> Type) -> (Type -> Type) -> Constraint
132class GToExprs _ToExprs _Columns exprs rep where
133 gfromResult :: ()
134 => (forall expr a proxy.
135 ( Eval (_ToExprs expr a)
136 , HTable (Eval (_Columns expr))
137 )
138 => proxy expr
139 -> Eval (_Columns expr) (Col Result)
140 -> a)
141 -> GColumns _Columns exprs (Col Result)
142 -> rep x
143 gtoResult :: ()
144 => (forall expr a proxy.
145 ( Eval (_ToExprs expr a)
146 , HTable (Eval (_Columns expr))
147 )
148 => proxy expr
149 -> a
150 -> Eval (_Columns expr) (Col Result))
151 -> rep x
152 -> GColumns _Columns exprs (Col Result)
155instance GToExprs _ToExprs _Columns exprs rep =>
156 GToExprs _ToExprs _Columns (M1 D c exprs) (M1 D c rep)
157 where
158 gfromResult fromResult =
159 M1 . gfromResult @_ToExprs @_Columns @exprs fromResult
160 gtoResult toResult (M1 a) =
161 gtoResult @_ToExprs @_Columns @exprs toResult a
164instance GToExprs _ToExprs _Columns exprs rep =>
165 GToExprs _ToExprs _Columns (M1 C c exprs) (M1 C c rep)
166 where
167 gfromResult fromResult =
168 M1 . gfromResult @_ToExprs @_Columns @exprs fromResult
169 gtoResult toResult (M1 a) =
170 gtoResult @_ToExprs @_Columns @exprs toResult a
173instance
174 ( GToExprs _ToExprs _Columns exprs1 rep1
175 , GToExprs _ToExprs _Columns exprs2 rep2
176 )
177 => GToExprs _ToExprs _Columns (exprs1 :*: exprs2) (rep1 :*: rep2)
178 where
179 gfromResult fromResult (HProduct a b) =
180 gfromResult @_ToExprs @_Columns @exprs1 fromResult a :*:
181 gfromResult @_ToExprs @_Columns @exprs2 fromResult b
182 gtoResult toResult (a :*: b) =
183 HProduct
184 (gtoResult @_ToExprs @_Columns @exprs1 toResult a)
185 (gtoResult @_ToExprs @_Columns @exprs2 toResult b)
188instance
189 ( Eval (_ToExprs exprs a)
190 , HTable (Eval (_Columns exprs))
191 , meta ~ 'MetaSel ('Just label) _su _ss _ds
192 , k1 ~ K1 i exprs
193 , k1' ~ K1 i a
194 )
195 => GToExprs _ToExprs _Columns (M1 S meta k1) (M1 S meta k1')
196 where
197 gfromResult fromResult =
198 M1 . K1 . fromResult (Proxy @exprs) . hunlabel
199 gtoResult toResult (M1 (K1 a)) =
200 hlabel (toResult (Proxy @exprs) a)