git.iko.soy/rel8
on f1e287e help sign in
rel8/src/Rel8/Table.hs
204 lines 6.1 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.Schema.Context ( Col(..) )
24import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
25import Rel8.Schema.HTable ( HTable )
26import Rel8.Schema.HTable.Identity ( HIdentity(..) )
27import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
28import Rel8.Schema.HTable.Pair ( HPair(..) )
29import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
30import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
31import Rel8.Schema.HTable.Trio ( HTrio(..) )
32import Rel8.Schema.HTable.Type ( HType( HType ) )
33import qualified Rel8.Schema.Kind as K
34import Rel8.Schema.Null ( Sql )
35import Rel8.Schema.Spec ( KnownSpec )
36import Rel8.Type ( DBType )
39-- | @Table@s are one of the foundational elements of Rel8, and describe data
40-- types that have a finite number of columns. Each of these columns contains
41-- data under a shared context, and contexts describe how to interpret the
42-- metadata about a column to a particular Haskell type. In Rel8, we have
43-- contexts for expressions (the 'Rel8.Expr' context), aggregations (the
44-- 'Rel8.Aggregate' context), insert values (the 'Rel8.Insert' contex), among
45-- others.
46--
47-- In typical usage of Rel8 you don't need to derive instances of 'Table'
48-- yourself, as anything that's an instance of 'Rel8.Rel8able' is always a
49-- '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 )
202type Congruent :: Type -> Type -> Constraint
203class Columns a ~ Columns b => Congruent a b
204instance Columns a ~ Columns b => Congruent a b