git.iko.soy/rel8
on 8cf243e help sign in
rel8/src/Rel8/Generic/Table.hs
126 lines 4.1 kB history raw
1{-# language AllowAmbiguousTypes #-}
2{-# language DataKinds #-}
3{-# language FlexibleInstances #-}
4{-# language MultiParamTypeClasses #-}
5{-# language PolyKinds #-}
6{-# language RankNTypes #-}
7{-# language ScopedTypeVariables #-}
8{-# language StandaloneKindSignatures #-}
9{-# language TypeApplications #-}
10{-# language TypeFamilies #-}
11{-# language TypeOperators #-}
12{-# language UndecidableInstances #-}
14module Rel8.Generic.Table
15 ( GTable, GColumns, GContext, fromGColumns, toGColumns, gtable
16 )
17where
19-- base
20import Data.Kind ( Constraint, Type )
21import Data.Proxy ( Proxy( Proxy ) )
22import GHC.Generics
23 ( (:*:)( (:*:) ), K1( K1 ), M1( M1 )
24 , C, D, S
25 , Meta( MetaSel )
26 )
27import GHC.TypeLits ( KnownSymbol )
28import Prelude hiding ( null )
30-- rel8
31import Rel8.FCF ( Eval, Exp )
32import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler )
33import Rel8.Schema.HTable ( HTable )
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 a) -> (Type -> Type) -> a
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 -> K.HContext -> (Type -> Type) -> Constraint
60class GTable _Table _Columns context rep
61 where
62 fromGColumns :: ()
63 => (forall a. Eval (_Table a) => Eval (_Columns a) context -> a)
64 -> GColumns _Columns rep context
65 -> rep x
67 toGColumns :: ()
68 => (forall a. Eval (_Table a) => a -> Eval (_Columns a) context)
69 -> rep x
70 -> GColumns _Columns rep context
72 gtable :: ()
73 => (forall a. Eval (_Table a) => Proxy a -> Eval (_Columns a) context)
74 -> GColumns _Columns rep context
77instance GTable _Table _Columns context rep =>
78 GTable _Table _Columns context (M1 D c rep)
79 where
80 fromGColumns fromColumns =
81 M1 . fromGColumns @_Table @_Columns @context @rep fromColumns
82 toGColumns toColumns (M1 a) =
83 toGColumns @_Table @_Columns @context @rep toColumns a
84 gtable = gtable @_Table @_Columns @context @rep
87instance GTable _Table _Columns context rep =>
88 GTable _Table _Columns context (M1 C c rep)
89 where
90 fromGColumns fromColumns =
91 M1 . fromGColumns @_Table @_Columns @context @rep fromColumns
92 toGColumns toColumns (M1 a) =
93 toGColumns @_Table @_Columns @context @rep toColumns a
94 gtable = gtable @_Table @_Columns @context @rep
97instance
98 ( GTable _Table _Columns context rep1
99 , GTable _Table _Columns context rep2
100 )
101 => GTable _Table _Columns context (rep1 :*: rep2)
102 where
103 fromGColumns fromColumns (HProduct a b) =
104 fromGColumns @_Table @_Columns @context @rep1 fromColumns a :*:
105 fromGColumns @_Table @_Columns @context @rep2 fromColumns b
106 toGColumns toColumns (a :*: b) = HProduct
107 (toGColumns @_Table @_Columns @context @rep1 toColumns a)
108 (toGColumns @_Table @_Columns @context @rep2 toColumns b)
109 gtable table = HProduct
110 (gtable @_Table @_Columns @context @rep1 table)
111 (gtable @_Table @_Columns @context @rep2 table)
114instance
115 ( HTable (Eval (_Columns a))
116 , Eval (_Table a)
117 , HLabelable context
118 , KnownSymbol label
119 , meta ~ 'MetaSel ('Just label) _su _ss _ds
120 , k1 ~ K1 i a
121 )
122 => GTable _Table _Columns context (M1 S meta k1)
123 where
124 fromGColumns fromColumns = M1 . K1 . fromColumns . hunlabel hunlabeler
125 toGColumns toColumns (M1 (K1 a)) = hlabel hlabeler (toColumns a)
126 gtable table = hlabel hlabeler (table (Proxy @a))