git.iko.soy/rel8
on 93168af help sign in
rel8/src/Rel8/Table.hs
236 lines 6.5 kB history raw
1{-# language DataKinds #-}
2{-# language DisambiguateRecordFields #-}
3{-# language FlexibleContexts #-}
4{-# language FlexibleInstances #-}
5{-# language FunctionalDependencies #-}
6{-# language StandaloneKindSignatures #-}
7{-# language TypeFamilies #-}
8{-# language UndecidableInstances #-}
10module Rel8.Table
11 ( Table (Columns, Context)
12 , toColumns, fromColumns
13 , Congruent
14 )
15where
17-- base
18import Data.Functor.Identity ( Identity( Identity ) )
19import Data.Kind ( Constraint, Type )
20import Prelude
22-- rel8
23import Rel8.Aggregate ( Aggregate )
24import Rel8.Expr ( Expr )
25import Rel8.Kind.Bool ( KnownBool, IsList )
26import Rel8.Opaque ( Opaque, Opaque1 )
27import Rel8.Schema.Context
28 ( Aggregation( Aggregation )
29 , DB( DB ), unDB
30 , Result( Result )
31 )
32import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
33import Rel8.Schema.HTable ( HTable, hfield, hspecs, htabulate, htabulateA )
34import Rel8.Schema.HTable.Context ( H, HKTable )
35import Rel8.Schema.HTable.Identity ( HIdentity(..) )
36import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
37import Rel8.Schema.HTable.Pair ( HPair(..) )
38import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
39import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
40import Rel8.Schema.HTable.Trio ( HTrio(..) )
41import Rel8.Schema.HTable.Type ( HType( HType ) )
42import Rel8.Schema.Nullability ( Nullabilizes )
43import Rel8.Schema.Spec ( SSpec( SSpec ), KnownSpec )
44import qualified Rel8.Schema.Spec as Kind ( Context )
45import Rel8.Type ( DBType )
48type Table :: Kind.Context -> Type -> Constraint
49class (HTable (Columns a), context ~ Context a) => Table context a | a -> context where
50 type Columns a :: HKTable
51 type Context a :: Kind.Context
53 toColumns :: a -> Columns a (H (Context a))
54 fromColumns :: Columns a (H (Context a)) -> a
57-- | Any 'HTable' is also a 'Table'.
58instance HTable t => Table context (t (H context)) where
59 type Columns (t (H context)) = t
60 type Context (t (H context)) = context
62 toColumns = id
63 fromColumns = id
66-- | Any context is trivially a table.
67instance KnownSpec spec => Table context (context spec) where
68 type Columns (context spec) = HIdentity spec
69 type Context (context spec) = context
71 toColumns = HIdentity
72 fromColumns = unHIdentity
75instance Table DB a => Table Aggregation (Aggregate a) where
76 type Columns (Aggregate a) = Columns a
77 type Context (Aggregate a) = Aggregation
79 toColumns a = htabulate $ \field -> case hfield hspecs field of
80 SSpec {} -> Aggregation $ unDB . (`hfield` field) . toColumns <$> a
81 fromColumns as = fmap fromColumns $ htabulateA $ \field ->
82 case hfield as field of
83 Aggregation a -> DB <$> a
86instance
87 ( DBType db
88 , Nullabilizes db a
89 , KnownBool (IsList db)
90 )
91 => Table DB (Expr a)
92 where
93 type Columns (Expr a) = HType a
94 type Context (Expr a) = DB
96 toColumns a = HType (DB a)
97 fromColumns (HType (DB a)) = a
100instance
101 ( DBType db
102 , Nullabilizes db a
103 , KnownBool (IsList db)
104 )
105 => Table Result (Identity a)
106 where
107 type Columns (Identity a) = HType a
108 type Context (Identity a) = Result
110 toColumns (Identity a) = HType (Result a)
111 fromColumns (HType (Result a)) = Identity a
114instance
115 ( Table context a, Table context b
116 , Labelable context
117 ) =>
118 Table context (a, b)
119 where
120 type Columns (a, b) =
121 HPair
122 (HLabel "fst" (Columns a))
123 (HLabel "snd" (Columns b))
124 type Context (a, b) = Context a
126 toColumns (a, b) = HPair
127 { hfst = hlabel labeler $ toColumns a
128 , hsnd = hlabel labeler $ toColumns b
129 }
130 fromColumns (HPair a b) =
131 ( fromColumns $ hunlabel unlabeler a
132 , fromColumns $ hunlabel unlabeler b
133 )
136instance
137 ( Table context a, Table context b, Table context c
138 , Labelable context
139 ) => Table context (a, b, c)
140 where
141 type Columns (a, b, c) =
142 HTrio
143 (HLabel "fst" (Columns a))
144 (HLabel "snd" (Columns b))
145 (HLabel "trd" (Columns c))
146 type Context (a, b, c) = Context a
148 toColumns (a, b, c) = HTrio
149 { hfst = hlabel labeler $ toColumns a
150 , hsnd = hlabel labeler $ toColumns b
151 , htrd = hlabel labeler $ toColumns c
152 }
153 fromColumns (HTrio a b c) =
154 ( fromColumns $ hunlabel unlabeler a
155 , fromColumns $ hunlabel unlabeler b
156 , fromColumns $ hunlabel unlabeler c
157 )
160instance
161 ( Table context a, Table context b, Table context c, Table context d
162 , Labelable context
163 ) => Table context (a, b, c, d)
164 where
165 type Columns (a, b, c, d) =
166 HQuartet
167 (HLabel "fst" (Columns a))
168 (HLabel "snd" (Columns b))
169 (HLabel "trd" (Columns c))
170 (HLabel "frt" (Columns d))
171 type Context (a, b, c, d) = Context a
173 toColumns (a, b, c, d) = HQuartet
174 { hfst = hlabel labeler $ toColumns a
175 , hsnd = hlabel labeler $ toColumns b
176 , htrd = hlabel labeler $ toColumns c
177 , hfrt = hlabel labeler $ toColumns d
178 }
179 fromColumns (HQuartet a b c d) =
180 ( fromColumns $ hunlabel unlabeler a
181 , fromColumns $ hunlabel unlabeler b
182 , fromColumns $ hunlabel unlabeler c
183 , fromColumns $ hunlabel unlabeler d
184 )
187instance
188 ( Table context a, Table context b, Table context c, Table context d
189 , Table context e
190 , Labelable context
191 ) => Table context (a, b, c, d, e)
192 where
193 type Columns (a, b, c, d, e) =
194 HQuintet
195 (HLabel "fst" (Columns a))
196 (HLabel "snd" (Columns b))
197 (HLabel "trd" (Columns c))
198 (HLabel "frt" (Columns d))
199 (HLabel "fft" (Columns e))
200 type Context (a, b, c, d, e) = Context a
202 toColumns (a, b, c, d, e) = HQuintet
203 { hfst = hlabel labeler $ toColumns a
204 , hsnd = hlabel labeler $ toColumns b
205 , htrd = hlabel labeler $ toColumns c
206 , hfrt = hlabel labeler $ toColumns d
207 , hfft = hlabel labeler $ toColumns e
208 }
209 fromColumns (HQuintet a b c d e) =
210 ( fromColumns $ hunlabel unlabeler a
211 , fromColumns $ hunlabel unlabeler b
212 , fromColumns $ hunlabel unlabeler c
213 , fromColumns $ hunlabel unlabeler d
214 , fromColumns $ hunlabel unlabeler e
215 )
218instance Table DB Opaque where
219 type Columns Opaque = HType Opaque
220 type Context Opaque = DB
222 fromColumns = error "opaque"
223 toColumns = error "opaque"
226instance Table context (Opaque1 context a) where
227 type Columns (Opaque1 context a) = HType Opaque
228 type Context (Opaque1 context a) = context
230 fromColumns = error "opaque"
231 toColumns = error "opaque"
234type Congruent :: Type -> Type -> Constraint
235class Columns a ~ Columns b => Congruent a b
236instance Columns a ~ Columns b => Congruent a b