git.iko.soy/rel8
on 37a8567 help sign in
rel8/src/Rel8/Table.hs
222 lines 6.6 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 {-# SOURCE #-} Rel8.Expr ( Expr )
24import Rel8.Opaque ( Opaque )
25import Rel8.Schema.Context ( Col(..) )
26import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
27import Rel8.Schema.HTable ( HTable )
28import Rel8.Schema.HTable.Identity ( HIdentity(..) )
29import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
30import Rel8.Schema.HTable.Pair ( HPair(..) )
31import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
32import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
33import Rel8.Schema.HTable.Trio ( HTrio(..) )
34import Rel8.Schema.HTable.Type ( HType( HType ) )
35import qualified Rel8.Schema.Kind as K
36import Rel8.Schema.Nullability ( Sql )
37import Rel8.Schema.Spec ( KnownSpec )
38import Rel8.Type ( DBType )
41-- | @Table@s are one of the foundational elements of Rel8, and describe data
42-- types that have a finite number of columns. Each of these columns contains
43-- data under a shared context, and contexts describe how to interpret the
44-- metadata about a column to a particular Haskell type. In Rel8, we have
45-- contexts for expressions (the 'Rel8.Expr' context), aggregations (the
46-- 'Rel8.Aggregate' context), insert values (the 'Rel8.Insert' contex), among
47-- others.
48--
49-- In typical usage of Rel8 you don't need to derive instances of 'Table'
50-- yourself, as anything that's an instance of 'Rel8.Rel8able' is always a
51-- 'Table'.
52type Table :: K.Context -> Type -> Constraint
53class (HTable (Columns a), context ~ Context a) => Table context a | a -> context where
54 -- | The 'HTable' functor that describes the schema of this table.
55 type Columns a :: K.HTable
57 -- | The common context that all columns use as an interpretation.
58 type Context a :: K.Context
60 toColumns :: a -> Columns a (Col (Context a))
61 fromColumns :: Columns a (Col (Context a)) -> a
64-- | Any 'HTable' is also a 'Table'.
65instance HTable t => Table context (t (Col context)) where
66 type Columns (t (Col context)) = t
67 type Context (t (Col context)) = context
69 toColumns = id
70 fromColumns = id
73-- | Any context is trivially a table.
74instance KnownSpec spec => Table context (Col context spec) where
75 type Columns (Col context spec) = HIdentity spec
76 type Context (Col context spec) = context
78 toColumns = HIdentity
79 fromColumns = unHIdentity
82instance Sql DBType a => Table Identity (Identity a) where
83 type Columns (Identity a) = HType a
84 type Context (Identity a) = Identity
86 toColumns (Identity a) = HType (Result a)
87 fromColumns (HType (Result a)) = Identity a
90{-}
91instance Sql DBType a => Table Insertion (Insertion a) where
92 type Columns (Insertion a) = HType a
93 type Context (Insertion a) = Insertion
95 toColumns (Insertion a) = HType (RequiredInsert a)
96 fromColumns (HType (RequiredInsert a)) = Insertion a
97-}
100instance
101 ( Table context a, Table context b
102 , Labelable context
103 ) =>
104 Table context (a, b)
105 where
106 type Columns (a, b) =
107 HPair
108 (HLabel "fst" (Columns a))
109 (HLabel "snd" (Columns b))
110 type Context (a, b) = Context a
112 toColumns (a, b) = HPair
113 { hfst = hlabel labeler $ toColumns a
114 , hsnd = hlabel labeler $ toColumns b
115 }
116 fromColumns (HPair a b) =
117 ( fromColumns $ hunlabel unlabeler a
118 , fromColumns $ hunlabel unlabeler b
119 )
122instance
123 ( Table context a, Table context b, Table context c
124 , Labelable context
125 ) => Table context (a, b, c)
126 where
127 type Columns (a, b, c) =
128 HTrio
129 (HLabel "fst" (Columns a))
130 (HLabel "snd" (Columns b))
131 (HLabel "trd" (Columns c))
132 type Context (a, b, c) = Context a
134 toColumns (a, b, c) = HTrio
135 { hfst = hlabel labeler $ toColumns a
136 , hsnd = hlabel labeler $ toColumns b
137 , htrd = hlabel labeler $ toColumns c
138 }
139 fromColumns (HTrio a b c) =
140 ( fromColumns $ hunlabel unlabeler a
141 , fromColumns $ hunlabel unlabeler b
142 , fromColumns $ hunlabel unlabeler c
143 )
146instance
147 ( Table context a, Table context b, Table context c, Table context d
148 , Labelable context
149 ) => Table context (a, b, c, d)
150 where
151 type Columns (a, b, c, d) =
152 HQuartet
153 (HLabel "fst" (Columns a))
154 (HLabel "snd" (Columns b))
155 (HLabel "trd" (Columns c))
156 (HLabel "frt" (Columns d))
157 type Context (a, b, c, d) = Context a
159 toColumns (a, b, c, d) = HQuartet
160 { hfst = hlabel labeler $ toColumns a
161 , hsnd = hlabel labeler $ toColumns b
162 , htrd = hlabel labeler $ toColumns c
163 , hfrt = hlabel labeler $ toColumns d
164 }
165 fromColumns (HQuartet a b c d) =
166 ( fromColumns $ hunlabel unlabeler a
167 , fromColumns $ hunlabel unlabeler b
168 , fromColumns $ hunlabel unlabeler c
169 , fromColumns $ hunlabel unlabeler d
170 )
173instance
174 ( Table context a, Table context b, Table context c, Table context d
175 , Table context e
176 , Labelable context
177 ) => Table context (a, b, c, d, e)
178 where
179 type Columns (a, b, c, d, e) =
180 HQuintet
181 (HLabel "fst" (Columns a))
182 (HLabel "snd" (Columns b))
183 (HLabel "trd" (Columns c))
184 (HLabel "frt" (Columns d))
185 (HLabel "fft" (Columns e))
186 type Context (a, b, c, d, e) = Context a
188 toColumns (a, b, c, d, e) = HQuintet
189 { hfst = hlabel labeler $ toColumns a
190 , hsnd = hlabel labeler $ toColumns b
191 , htrd = hlabel labeler $ toColumns c
192 , hfrt = hlabel labeler $ toColumns d
193 , hfft = hlabel labeler $ toColumns e
194 }
195 fromColumns (HQuintet a b c d e) =
196 ( fromColumns $ hunlabel unlabeler a
197 , fromColumns $ hunlabel unlabeler b
198 , fromColumns $ hunlabel unlabeler c
199 , fromColumns $ hunlabel unlabeler d
200 , fromColumns $ hunlabel unlabeler e
201 )
204instance Table Expr Opaque where
205 type Columns Opaque = HType Opaque
206 type Context Opaque = Expr
208 fromColumns = error "opaque"
209 toColumns = error "opaque"
212instance Table context (Opaque context a) where
213 type Columns (Opaque context a) = HType Opaque
214 type Context (Opaque context a) = context
216 fromColumns = error "opaque"
217 toColumns = error "opaque"
220type Congruent :: Type -> Type -> Constraint
221class Columns a ~ Columns b => Congruent a b
222instance Columns a ~ Columns b => Congruent a b