git.iko.soy/rel8
on b97cd4e help sign in
rel8/src/Rel8/Table.hs
220 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 {-# 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 'Expr' context), aggregations (the 'Aggregate'
46-- context), insert values (the 'Insert' contex), among others.
47--
48-- In typical usage of Rel8 you don't need to derive instances of 'Table'
49-- yourself, as anything that's an instance of 'Rel8able' is always a 'Table'.
50type Table :: K.Context -> Type -> Constraint
51class (HTable (Columns a), context ~ Context a) => Table context a | a -> context where
52 -- | The 'HTable' functor that describes the schema of this table.
53 type Columns a :: K.HTable
55 -- | The common context that all columns use as an interpretation.
56 type Context a :: K.Context
58 toColumns :: a -> Columns a (Col (Context a))
59 fromColumns :: Columns a (Col (Context a)) -> a
62-- | Any 'HTable' is also a 'Table'.
63instance HTable t => Table context (t (Col context)) where
64 type Columns (t (Col context)) = t
65 type Context (t (Col context)) = context
67 toColumns = id
68 fromColumns = id
71-- | Any context is trivially a table.
72instance KnownSpec spec => Table context (Col context spec) where
73 type Columns (Col context spec) = HIdentity spec
74 type Context (Col context spec) = context
76 toColumns = HIdentity
77 fromColumns = unHIdentity
80instance Sql DBType a => Table Identity (Identity a) where
81 type Columns (Identity a) = HType a
82 type Context (Identity a) = Identity
84 toColumns (Identity a) = HType (Result a)
85 fromColumns (HType (Result a)) = Identity a
88{-}
89instance Sql DBType a => Table Insertion (Insertion a) where
90 type Columns (Insertion a) = HType a
91 type Context (Insertion a) = Insertion
93 toColumns (Insertion a) = HType (RequiredInsert a)
94 fromColumns (HType (RequiredInsert a)) = Insertion a
95-}
98instance
99 ( Table context a, Table context b
100 , Labelable context
101 ) =>
102 Table context (a, b)
103 where
104 type Columns (a, b) =
105 HPair
106 (HLabel "fst" (Columns a))
107 (HLabel "snd" (Columns b))
108 type Context (a, b) = Context a
110 toColumns (a, b) = HPair
111 { hfst = hlabel labeler $ toColumns a
112 , hsnd = hlabel labeler $ toColumns b
113 }
114 fromColumns (HPair a b) =
115 ( fromColumns $ hunlabel unlabeler a
116 , fromColumns $ hunlabel unlabeler b
117 )
120instance
121 ( Table context a, Table context b, Table context c
122 , Labelable context
123 ) => Table context (a, b, c)
124 where
125 type Columns (a, b, c) =
126 HTrio
127 (HLabel "fst" (Columns a))
128 (HLabel "snd" (Columns b))
129 (HLabel "trd" (Columns c))
130 type Context (a, b, c) = Context a
132 toColumns (a, b, c) = HTrio
133 { hfst = hlabel labeler $ toColumns a
134 , hsnd = hlabel labeler $ toColumns b
135 , htrd = hlabel labeler $ toColumns c
136 }
137 fromColumns (HTrio a b c) =
138 ( fromColumns $ hunlabel unlabeler a
139 , fromColumns $ hunlabel unlabeler b
140 , fromColumns $ hunlabel unlabeler c
141 )
144instance
145 ( Table context a, Table context b, Table context c, Table context d
146 , Labelable context
147 ) => Table context (a, b, c, d)
148 where
149 type Columns (a, b, c, d) =
150 HQuartet
151 (HLabel "fst" (Columns a))
152 (HLabel "snd" (Columns b))
153 (HLabel "trd" (Columns c))
154 (HLabel "frt" (Columns d))
155 type Context (a, b, c, d) = Context a
157 toColumns (a, b, c, d) = HQuartet
158 { hfst = hlabel labeler $ toColumns a
159 , hsnd = hlabel labeler $ toColumns b
160 , htrd = hlabel labeler $ toColumns c
161 , hfrt = hlabel labeler $ toColumns d
162 }
163 fromColumns (HQuartet a b c d) =
164 ( fromColumns $ hunlabel unlabeler a
165 , fromColumns $ hunlabel unlabeler b
166 , fromColumns $ hunlabel unlabeler c
167 , fromColumns $ hunlabel unlabeler d
168 )
171instance
172 ( Table context a, Table context b, Table context c, Table context d
173 , Table context e
174 , Labelable context
175 ) => Table context (a, b, c, d, e)
176 where
177 type Columns (a, b, c, d, e) =
178 HQuintet
179 (HLabel "fst" (Columns a))
180 (HLabel "snd" (Columns b))
181 (HLabel "trd" (Columns c))
182 (HLabel "frt" (Columns d))
183 (HLabel "fft" (Columns e))
184 type Context (a, b, c, d, e) = Context a
186 toColumns (a, b, c, d, e) = HQuintet
187 { hfst = hlabel labeler $ toColumns a
188 , hsnd = hlabel labeler $ toColumns b
189 , htrd = hlabel labeler $ toColumns c
190 , hfrt = hlabel labeler $ toColumns d
191 , hfft = hlabel labeler $ toColumns e
192 }
193 fromColumns (HQuintet a b c d e) =
194 ( fromColumns $ hunlabel unlabeler a
195 , fromColumns $ hunlabel unlabeler b
196 , fromColumns $ hunlabel unlabeler c
197 , fromColumns $ hunlabel unlabeler d
198 , fromColumns $ hunlabel unlabeler e
199 )
202instance Table Expr Opaque where
203 type Columns Opaque = HType Opaque
204 type Context Opaque = Expr
206 fromColumns = error "opaque"
207 toColumns = error "opaque"
210instance Table context (Opaque context a) where
211 type Columns (Opaque context a) = HType Opaque
212 type Context (Opaque context a) = context
214 fromColumns = error "opaque"
215 toColumns = error "opaque"
218type Congruent :: Type -> Type -> Constraint
219class Columns a ~ Columns b => Congruent a b
220instance Columns a ~ Columns b => Congruent a b