git.iko.soy/rel8
on 55fef87 help sign in
rel8/src/Rel8/Table.hs
194 lines 5.8 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
88instance
89 ( Table context a, Table context b
90 , Labelable context
91 ) =>
92 Table context (a, b)
93 where
94 type Columns (a, b) =
95 HPair
96 (HLabel "fst" (Columns a))
97 (HLabel "snd" (Columns b))
98 type Context (a, b) = Context a
100 toColumns (a, b) = HPair
101 { hfst = hlabel labeler $ toColumns a
102 , hsnd = hlabel labeler $ toColumns b
103 }
104 fromColumns (HPair a b) =
105 ( fromColumns $ hunlabel unlabeler a
106 , fromColumns $ hunlabel unlabeler b
107 )
110instance
111 ( Table context a, Table context b, Table context c
112 , Labelable context
113 ) => Table context (a, b, c)
114 where
115 type Columns (a, b, c) =
116 HTrio
117 (HLabel "fst" (Columns a))
118 (HLabel "snd" (Columns b))
119 (HLabel "trd" (Columns c))
120 type Context (a, b, c) = Context a
122 toColumns (a, b, c) = HTrio
123 { hfst = hlabel labeler $ toColumns a
124 , hsnd = hlabel labeler $ toColumns b
125 , htrd = hlabel labeler $ toColumns c
126 }
127 fromColumns (HTrio a b c) =
128 ( fromColumns $ hunlabel unlabeler a
129 , fromColumns $ hunlabel unlabeler b
130 , fromColumns $ hunlabel unlabeler c
131 )
134instance
135 ( Table context a, Table context b, Table context c, Table context d
136 , Labelable context
137 ) => Table context (a, b, c, d)
138 where
139 type Columns (a, b, c, d) =
140 HQuartet
141 (HLabel "fst" (Columns a))
142 (HLabel "snd" (Columns b))
143 (HLabel "trd" (Columns c))
144 (HLabel "frt" (Columns d))
145 type Context (a, b, c, d) = Context a
147 toColumns (a, b, c, d) = HQuartet
148 { hfst = hlabel labeler $ toColumns a
149 , hsnd = hlabel labeler $ toColumns b
150 , htrd = hlabel labeler $ toColumns c
151 , hfrt = hlabel labeler $ toColumns d
152 }
153 fromColumns (HQuartet a b c d) =
154 ( fromColumns $ hunlabel unlabeler a
155 , fromColumns $ hunlabel unlabeler b
156 , fromColumns $ hunlabel unlabeler c
157 , fromColumns $ hunlabel unlabeler d
158 )
161instance
162 ( Table context a, Table context b, Table context c, Table context d
163 , Table context e
164 , Labelable context
165 ) => Table context (a, b, c, d, e)
166 where
167 type Columns (a, b, c, d, e) =
168 HQuintet
169 (HLabel "fst" (Columns a))
170 (HLabel "snd" (Columns b))
171 (HLabel "trd" (Columns c))
172 (HLabel "frt" (Columns d))
173 (HLabel "fft" (Columns e))
174 type Context (a, b, c, d, e) = Context a
176 toColumns (a, b, c, d, e) = HQuintet
177 { hfst = hlabel labeler $ toColumns a
178 , hsnd = hlabel labeler $ toColumns b
179 , htrd = hlabel labeler $ toColumns c
180 , hfrt = hlabel labeler $ toColumns d
181 , hfft = hlabel labeler $ toColumns e
182 }
183 fromColumns (HQuintet a b c d e) =
184 ( fromColumns $ hunlabel unlabeler a
185 , fromColumns $ hunlabel unlabeler b
186 , fromColumns $ hunlabel unlabeler c
187 , fromColumns $ hunlabel unlabeler d
188 , fromColumns $ hunlabel unlabeler e
189 )
192type Congruent :: Type -> Type -> Constraint
193class Columns a ~ Columns b => Congruent a b
194instance Columns a ~ Columns b => Congruent a b