git.iko.soy/rel8
on 29cdfdb help sign in
rel8/src/Rel8/Generic/Table/Record.hs
181 lines 5.7 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 , GSerialize, 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.HTable.Label ( HLabel, hlabel, hunlabel )
34import Rel8.Schema.HTable.Product ( HProduct(..) )
35import qualified Rel8.Schema.Kind as K
38type GColumns :: (Type -> Exp K.HTable) -> (Type -> Type) -> K.HTable
39type family GColumns _Columns rep where
40 GColumns _Columns (M1 D _ rep) = GColumns _Columns rep
41 GColumns _Columns (M1 C _ rep) = GColumns _Columns rep
42 GColumns _Columns (rep1 :*: rep2) =
43 HProduct (GColumns _Columns rep1) (GColumns _Columns rep2)
44 GColumns _Columns (M1 S ('MetaSel ('Just label) _ _ _) (K1 _ a)) =
45 HLabel label (Eval (_Columns a))
48type GContext :: (Type -> Exp K.Context) -> (Type -> Type) -> K.Context
49type family GContext _Context rep where
50 GContext _Context (M1 _ _ rep) = GContext _Context rep
51 GContext _Context (rep1 :*: _rep2) = GContext _Context rep1
52 GContext _Context (K1 _ a) = Eval (_Context a)
55type GTable
56 :: (Type -> Exp Constraint)
57 -> (Type -> Exp K.HTable)
58 -> (Type -> Type) -> Constraint
59class GTable _Table _Columns rep
60 where
61 gfromColumns :: ()
62 => (forall a. Eval (_Table a) => Eval (_Columns a) context -> a)
63 -> GColumns _Columns rep context
64 -> rep x
66 gtoColumns :: ()
67 => (forall a. Eval (_Table a) => a -> Eval (_Columns a) context)
68 -> rep x
69 -> GColumns _Columns rep context
71 gtable :: ()
72 => (forall a proxy. Eval (_Table a) => proxy a -> Eval (_Columns a) context)
73 -> GColumns _Columns rep context
76type GSerialize
77 :: (Type -> Type -> Exp Constraint)
78 -> (Type -> Exp K.HTable)
79 -> (Type -> Type) -> (Type -> Type) -> Constraint
80class GSerialize _Serialize _Columns exprs rep
81 where
82 gfromResult :: ()
83 => (forall expr a proxy. Eval (_Serialize expr a)
84 => proxy expr -> Eval (_Columns expr) context -> a)
85 -> GColumns _Columns exprs context
86 -> rep x
88 gtoResult :: ()
89 => (forall expr a proxy. Eval (_Serialize expr a)
90 => proxy expr -> a -> Eval (_Columns expr) context)
91 -> rep x
92 -> GColumns _Columns exprs context
95instance GTable _Table _Columns rep => GTable _Table _Columns (M1 D c rep)
96 where
97 gfromColumns fromColumns =
98 M1 . gfromColumns @_Table @_Columns @rep fromColumns
99 gtoColumns toColumns (M1 a) =
100 gtoColumns @_Table @_Columns @rep toColumns a
101 gtable = gtable @_Table @_Columns @rep
104instance GSerialize _Serialize _Columns exprs rep =>
105 GSerialize _Serialize _Columns (M1 D c exprs) (M1 D c rep)
106 where
107 gfromResult fromResult =
108 M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult
109 gtoResult toResult (M1 a) =
110 gtoResult @_Serialize @_Columns @exprs @rep toResult a
113instance GTable _Table _Columns rep => GTable _Table _Columns (M1 C c rep)
114 where
115 gfromColumns fromColumns =
116 M1 . gfromColumns @_Table @_Columns @rep fromColumns
117 gtoColumns toColumns (M1 a) =
118 gtoColumns @_Table @_Columns @rep toColumns a
119 gtable = gtable @_Table @_Columns @rep
122instance GSerialize _Serialize _Columns exprs rep =>
123 GSerialize _Serialize _Columns (M1 C c exprs) (M1 C c rep)
124 where
125 gfromResult fromResult =
126 M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult
127 gtoResult toResult (M1 a) =
128 gtoResult @_Serialize @_Columns @exprs @rep toResult a
131instance (GTable _Table _Columns rep1, GTable _Table _Columns rep2) =>
132 GTable _Table _Columns (rep1 :*: rep2)
133 where
134 gfromColumns fromColumns (HProduct a b) =
135 gfromColumns @_Table @_Columns @rep1 fromColumns a :*:
136 gfromColumns @_Table @_Columns @rep2 fromColumns b
137 gtoColumns toColumns (a :*: b) = HProduct
138 (gtoColumns @_Table @_Columns @rep1 toColumns a)
139 (gtoColumns @_Table @_Columns @rep2 toColumns b)
140 gtable table = HProduct
141 (gtable @_Table @_Columns @rep1 table)
142 (gtable @_Table @_Columns @rep2 table)
145instance
146 ( GSerialize _Serialize _Columns expr1 rep1
147 , GSerialize _Serialize _Columns expr2 rep2
148 )
149 => GSerialize _Serialize _Columns (expr1 :*: expr2) (rep1 :*: rep2)
150 where
151 gfromResult fromResult (HProduct a b) =
152 gfromResult @_Serialize @_Columns @expr1 @rep1 fromResult a :*:
153 gfromResult @_Serialize @_Columns @expr2 @rep2 fromResult b
154 gtoResult toResult (a :*: b) =
155 HProduct
156 (gtoResult @_Serialize @_Columns @expr1 @rep1 toResult a)
157 (gtoResult @_Serialize @_Columns @expr2 @rep2 toResult b)
160instance
161 ( Eval (_Table a)
162 , meta ~ 'MetaSel ('Just label) _su _ss _ds
163 , k1 ~ K1 i a
164 )
165 => GTable _Table _Columns (M1 S meta k1)
166 where
167 gfromColumns fromColumns = M1 . K1 . fromColumns . hunlabel
168 gtoColumns toColumns (M1 (K1 a)) = hlabel (toColumns a)
169 gtable table = hlabel (table (Proxy @a))
172instance
173 ( Eval (_Serialize expr a)
174 , meta ~ 'MetaSel ('Just label) _su _ss _ds
175 , k1 ~ K1 i expr
176 , k1' ~ K1 i a
177 )
178 => GSerialize _Serialize _Columns (M1 S meta k1) (M1 S meta k1')
179 where
180 gfromResult fromResult = M1 . K1 . fromResult (Proxy @expr) . hunlabel
181 gtoResult toResult (M1 (K1 a)) = hlabel (toResult (Proxy @expr) a)