git.iko.soy/rel8
on fb3d2d9 help sign in
rel8/src/Rel8/Generic/Table/Record.hs
206 lines 6.4 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 GHC.TypeLits ( KnownSymbol )
30import Prelude hiding ( null )
32-- rel8
33import Rel8.FCF ( Eval, Exp )
34import Rel8.Schema.Context ( Col )
35import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler )
36import Rel8.Schema.HTable ( HTable )
37import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
38import Rel8.Schema.HTable.Product ( HProduct(..) )
39import qualified Rel8.Schema.Kind as K
40import Rel8.Schema.Result ( Result )
43type GColumns :: (Type -> Exp K.HTable) -> (Type -> Type) -> K.HTable
44type family GColumns _Columns rep where
45 GColumns _Columns (M1 D _ rep) = GColumns _Columns rep
46 GColumns _Columns (M1 C _ rep) = GColumns _Columns rep
47 GColumns _Columns (rep1 :*: rep2) =
48 HProduct (GColumns _Columns rep1) (GColumns _Columns rep2)
49 GColumns _Columns (M1 S ('MetaSel ('Just label) _ _ _) (K1 _ a)) =
50 HLabel label (Eval (_Columns a))
53type GContext :: (Type -> Exp K.Context) -> (Type -> Type) -> K.Context
54type family GContext _Context rep where
55 GContext _Context (M1 _ _ rep) = GContext _Context rep
56 GContext _Context (rep1 :*: _rep2) = GContext _Context rep1
57 GContext _Context (K1 _ a) = Eval (_Context a)
60type GTable
61 :: (Type -> Exp Constraint)
62 -> (Type -> Exp K.HTable)
63 -> K.HContext -> (Type -> Type) -> Constraint
64class GTable _Table _Columns context rep
65 where
66 gfromColumns :: ()
67 => (forall a. Eval (_Table a) => Eval (_Columns a) context -> a)
68 -> GColumns _Columns rep context
69 -> rep x
71 gtoColumns :: ()
72 => (forall a. Eval (_Table a) => a -> Eval (_Columns a) context)
73 -> rep x
74 -> GColumns _Columns rep context
76 gtable :: ()
77 => (forall a proxy. Eval (_Table a) => proxy a -> Eval (_Columns a) context)
78 -> GColumns _Columns rep context
81instance GTable _Table _Columns context rep =>
82 GTable _Table _Columns context (M1 D c rep)
83 where
84 gfromColumns fromColumns =
85 M1 . gfromColumns @_Table @_Columns @context @rep fromColumns
86 gtoColumns toColumns (M1 a) =
87 gtoColumns @_Table @_Columns @context @rep toColumns a
88 gtable = gtable @_Table @_Columns @context @rep
91instance GTable _Table _Columns context rep =>
92 GTable _Table _Columns context (M1 C c rep)
93 where
94 gfromColumns fromColumns =
95 M1 . gfromColumns @_Table @_Columns @context @rep fromColumns
96 gtoColumns toColumns (M1 a) =
97 gtoColumns @_Table @_Columns @context @rep toColumns a
98 gtable = gtable @_Table @_Columns @context @rep
101instance
102 ( GTable _Table _Columns context rep1
103 , GTable _Table _Columns context rep2
104 )
105 => GTable _Table _Columns context (rep1 :*: rep2)
106 where
107 gfromColumns fromColumns (HProduct a b) =
108 gfromColumns @_Table @_Columns @context @rep1 fromColumns a :*:
109 gfromColumns @_Table @_Columns @context @rep2 fromColumns b
110 gtoColumns toColumns (a :*: b) = HProduct
111 (gtoColumns @_Table @_Columns @context @rep1 toColumns a)
112 (gtoColumns @_Table @_Columns @context @rep2 toColumns b)
113 gtable table = HProduct
114 (gtable @_Table @_Columns @context @rep1 table)
115 (gtable @_Table @_Columns @context @rep2 table)
118instance
119 ( HTable (Eval (_Columns a))
120 , Eval (_Table a)
121 , HLabelable context
122 , KnownSymbol label
123 , meta ~ 'MetaSel ('Just label) _su _ss _ds
124 , k1 ~ K1 i a
125 )
126 => GTable _Table _Columns context (M1 S meta k1)
127 where
128 gfromColumns fromColumns = M1 . K1 . fromColumns . hunlabel hunlabeler
129 gtoColumns toColumns (M1 (K1 a)) = hlabel hlabeler (toColumns a)
130 gtable table = hlabel hlabeler (table (Proxy @a))
133type GToExprs
134 :: (Type -> Type -> Exp Constraint)
135 -> (Type -> Exp K.HTable)
136 -> (Type -> Type) -> (Type -> Type) -> Constraint
137class GToExprs _ToExprs _Columns exprs rep where
138 gfromResult :: ()
139 => (forall expr a proxy.
140 ( Eval (_ToExprs expr a)
141 , HTable (Eval (_Columns expr))
142 )
143 => proxy expr
144 -> Eval (_Columns expr) (Col Result)
145 -> a)
146 -> GColumns _Columns exprs (Col Result)
147 -> rep x
148 gtoResult :: ()
149 => (forall expr a proxy.
150 ( Eval (_ToExprs expr a)
151 , HTable (Eval (_Columns expr))
152 )
153 => proxy expr
154 -> a
155 -> Eval (_Columns expr) (Col Result))
156 -> rep x
157 -> GColumns _Columns exprs (Col Result)
160instance GToExprs _ToExprs _Columns exprs rep =>
161 GToExprs _ToExprs _Columns (M1 D c exprs) (M1 D c rep)
162 where
163 gfromResult fromResult =
164 M1 . gfromResult @_ToExprs @_Columns @exprs fromResult
165 gtoResult toResult (M1 a) =
166 gtoResult @_ToExprs @_Columns @exprs toResult a
169instance GToExprs _ToExprs _Columns exprs rep =>
170 GToExprs _ToExprs _Columns (M1 C c exprs) (M1 C c rep)
171 where
172 gfromResult fromResult =
173 M1 . gfromResult @_ToExprs @_Columns @exprs fromResult
174 gtoResult toResult (M1 a) =
175 gtoResult @_ToExprs @_Columns @exprs toResult a
178instance
179 ( GToExprs _ToExprs _Columns exprs1 rep1
180 , GToExprs _ToExprs _Columns exprs2 rep2
181 )
182 => GToExprs _ToExprs _Columns (exprs1 :*: exprs2) (rep1 :*: rep2)
183 where
184 gfromResult fromResult (HProduct a b) =
185 gfromResult @_ToExprs @_Columns @exprs1 fromResult a :*:
186 gfromResult @_ToExprs @_Columns @exprs2 fromResult b
187 gtoResult toResult (a :*: b) =
188 HProduct
189 (gtoResult @_ToExprs @_Columns @exprs1 toResult a)
190 (gtoResult @_ToExprs @_Columns @exprs2 toResult b)
193instance
194 ( Eval (_ToExprs exprs a)
195 , HTable (Eval (_Columns exprs))
196 , KnownSymbol label
197 , meta ~ 'MetaSel ('Just label) _su _ss _ds
198 , k1 ~ K1 i exprs
199 , k1' ~ K1 i a
200 )
201 => GToExprs _ToExprs _Columns (M1 S meta k1) (M1 S meta k1')
202 where
203 gfromResult fromResult =
204 M1 . K1 . fromResult (Proxy @exprs) . hunlabel hunlabeler
205 gtoResult toResult (M1 (K1 a)) =
206 hlabel hlabeler (toResult (Proxy @exprs) a)