git.iko.soy/rel8
on f47423e help sign in
rel8/src/Rel8/Generic/Table/Record.hs
153 lines 5.3 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
17 , gfromColumns, gtoColumns, gfromResult, gtoResult, gtable
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.Generic.Map ( GMap )
34import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
35import Rel8.Schema.HTable.Product ( HProduct(..) )
36import qualified Rel8.Schema.Kind as K
39type GColumns :: (Type -> Exp K.HTable) -> (Type -> Type) -> K.HTable
40type family GColumns _Columns rep where
41 GColumns _Columns (M1 D _ rep) = GColumns _Columns rep
42 GColumns _Columns (M1 C _ rep) = GColumns _Columns rep
43 GColumns _Columns (rep1 :*: rep2) =
44 HProduct (GColumns _Columns rep1) (GColumns _Columns rep2)
45 GColumns _Columns (M1 S ('MetaSel ('Just label) _ _ _) (K1 _ a)) =
46 HLabel label (Eval (_Columns a))
49type GContext :: (Type -> Exp K.Context) -> (Type -> Type) -> K.Context
50type family GContext _Context rep where
51 GContext _Context (M1 _ _ rep) = GContext _Context rep
52 GContext _Context (rep1 :*: _rep2) = GContext _Context rep1
53 GContext _Context (K1 _ a) = Eval (_Context a)
56type GTable
57 :: (Type -> Exp Constraint)
58 -> (Type -> Exp K.HTable)
59 -> (Type -> Exp Type)
60 -> (Type -> Type) -> Constraint
61class GTable _Table _Columns _FromExprs rep
62 where
63 gfromColumns :: ()
64 => (forall a. Eval (_Table a) => Eval (_Columns a) context -> a)
65 -> GColumns _Columns rep context
66 -> rep x
68 gtoColumns :: ()
69 => (forall a. Eval (_Table a) => a -> Eval (_Columns a) context)
70 -> rep x
71 -> GColumns _Columns rep context
73 gfromResult :: ()
74 => (forall a proxy. Eval (_Table a)
75 => proxy a -> Eval (_Columns a) context -> Eval (_FromExprs a))
76 -> GColumns _Columns rep context
77 -> GMap _FromExprs rep x
79 gtoResult :: ()
80 => (forall a proxy. Eval (_Table a)
81 => proxy a -> Eval (_FromExprs a) -> Eval (_Columns a) context)
82 -> GMap _FromExprs rep x
83 -> GColumns _Columns rep context
85 gtable :: ()
86 => (forall a proxy. Eval (_Table a) => proxy a -> Eval (_Columns a) context)
87 -> GColumns _Columns rep context
90instance GTable _Table _Columns _FromExprs rep =>
91 GTable _Table _Columns _FromExprs (M1 D c rep)
92 where
93 gfromColumns fromColumns =
94 M1 . gfromColumns @_Table @_Columns @_FromExprs @rep fromColumns
95 gtoColumns toColumns (M1 a) =
96 gtoColumns @_Table @_Columns @_FromExprs @rep toColumns a
97 gfromResult fromResult =
98 M1 . gfromResult @_Table @_Columns @_FromExprs @rep fromResult
99 gtoResult toResult (M1 a) =
100 gtoResult @_Table @_Columns @_FromExprs @rep toResult a
101 gtable = gtable @_Table @_Columns @_FromExprs @rep
104instance GTable _Table _Columns _FromExprs rep =>
105 GTable _Table _Columns _FromExprs (M1 C c rep)
106 where
107 gfromColumns fromColumns =
108 M1 . gfromColumns @_Table @_Columns @_FromExprs @rep fromColumns
109 gtoColumns toColumns (M1 a) =
110 gtoColumns @_Table @_Columns @_FromExprs @rep toColumns a
111 gfromResult fromResult =
112 M1 . gfromResult @_Table @_Columns @_FromExprs @rep fromResult
113 gtoResult toResult (M1 a) =
114 gtoResult @_Table @_Columns @_FromExprs @rep toResult a
115 gtable = gtable @_Table @_Columns @_FromExprs @rep
118instance
119 ( GTable _Table _Columns _FromExprs rep1
120 , GTable _Table _Columns _FromExprs rep2
121 )
122 => GTable _Table _Columns _FromExprs (rep1 :*: rep2)
123 where
124 gfromColumns fromColumns (HProduct a b) =
125 gfromColumns @_Table @_Columns @_FromExprs @rep1 fromColumns a :*:
126 gfromColumns @_Table @_Columns @_FromExprs @rep2 fromColumns b
127 gtoColumns toColumns (a :*: b) = HProduct
128 (gtoColumns @_Table @_Columns @_FromExprs @rep1 toColumns a)
129 (gtoColumns @_Table @_Columns @_FromExprs @rep2 toColumns b)
130 gfromResult fromResult (HProduct a b) =
131 gfromResult @_Table @_Columns @_FromExprs @rep1 fromResult a :*:
132 gfromResult @_Table @_Columns @_FromExprs @rep2 fromResult b
133 gtoResult toResult (a :*: b) =
134 HProduct
135 (gtoResult @_Table @_Columns @_FromExprs @rep1 toResult a)
136 (gtoResult @_Table @_Columns @_FromExprs @rep2 toResult b)
137 gtable table = HProduct
138 (gtable @_Table @_Columns @_FromExprs @rep1 table)
139 (gtable @_Table @_Columns @_FromExprs @rep2 table)
142instance
143 ( Eval (_Table a)
144 , meta ~ 'MetaSel ('Just label) _su _ss _ds
145 , k1 ~ K1 i a
146 )
147 => GTable _Table _Columns _FromExprs (M1 S meta k1)
148 where
149 gfromColumns fromColumns = M1 . K1 . fromColumns . hunlabel
150 gtoColumns toColumns (M1 (K1 a)) = hlabel (toColumns a)
151 gfromResult fromResult = M1 . K1 . fromResult (Proxy @a) . hunlabel
152 gtoResult toResult (M1 (K1 a)) = hlabel (toResult (Proxy @a) a)
153 gtable table = hlabel (table (Proxy @a))