git.iko.soy/rel8
on 6fad4d1 help sign in
rel8/src/Rel8/Generic/Rel8able.hs
276 lines 7.4 kB history raw
1{-# language AllowAmbiguousTypes #-}
2{-# language ConstraintKinds #-}
3{-# language DataKinds #-}
4{-# language DefaultSignatures #-}
5{-# language FlexibleContexts #-}
6{-# language FlexibleInstances #-}
7{-# language LambdaCase #-}
8{-# language MultiParamTypeClasses #-}
9{-# language PolyKinds #-}
10{-# language QuantifiedConstraints #-}
11{-# language ScopedTypeVariables #-}
12{-# language StandaloneKindSignatures #-}
13{-# language TypeApplications #-}
14{-# language TypeFamilyDependencies #-}
15{-# language TypeOperators #-}
16{-# language UndecidableInstances #-}
18module Rel8.Generic.Rel8able
19 ( KRel8able, Rel8able
20 , Algebra
21 , GRep
22 , GColumns, gfromColumns, gtoColumns
23 , GFromExprs, gfromResult, gtoResult
24 , TSerialize, serialize, deserialize
25 )
26where
28-- base
29import Data.Functor.Identity ( Identity )
30import Data.Kind ( Constraint, Type )
31import Data.Type.Bool ( type (&&) )
32import GHC.Generics ( Generic, Rep, from, to )
33import Prelude
35-- rel8
36import Rel8.Aggregate ( Aggregate )
37import Rel8.Expr ( Expr )
38import Rel8.FCF ( Exp, Eval )
39import Rel8.Generic.Record ( Record(..) )
40import Rel8.Generic.Table ( GAlgebra )
41import qualified Rel8.Generic.Table.Record as G
42import qualified Rel8.Kind.Algebra as K ( Algebra(..) )
43import Rel8.Kind.Context ( SContext(..) )
44import Rel8.Schema.Field ( Field )
45import Rel8.Schema.HTable ( HTable )
46import qualified Rel8.Schema.Kind as K
47import Rel8.Schema.Name ( Name )
48import Rel8.Schema.Result ( Result )
49import Rel8.Table
50 ( Table, Columns, Context, fromColumns, toColumns
51 , FromExprs, fromResult, toResult
52 , Transpose
53 , TTable, TColumns
54 )
55import Rel8.Table.Transpose ( Transposes )
58-- | The kind of 'Rel8able' types
59type KRel8able :: Type
60type KRel8able = K.Rel8able
63-- This is almost 'Data.Type.Equality.==', but we add an extra case.
64type (==) :: k -> k -> Bool
65type family a == b where
66 -- This extra case is needed to solve the equation "a == Identity a",
67 -- which occurs when we have polymorphic Rel8ables
68 -- (e.g., newtype T a f = T { x :: Column f a })
69 a == Identity a = 'False
71 -- These cases are exactly the same as those in 'Data.Type.Equality.==.
72 f a == g b = f == g && a == b
73 a == a = 'True
74 _ == _ = 'False
77type Serialize :: Bool -> Type -> Type -> Constraint
78class transposition ~ (a == Transpose Result expr) =>
79 Serialize transposition expr a
80 where
81 serialize :: a -> Columns expr Result
82 deserialize :: Columns expr Result -> a
85instance
86 ( (a == Transpose Result expr) ~ 'True
87 , Transposes Expr Result expr a
88 )
89 => Serialize 'True expr a
90 where
91 serialize = toColumns
92 deserialize = fromColumns
95instance
96 ( (a == Transpose Result expr) ~ 'False
97 , Table (Context expr) expr
98 , FromExprs expr ~ a
99 )
100 => Serialize 'False expr a
101 where
102 serialize = toResult @_ @expr
103 deserialize = fromResult @_ @expr
106data TSerialize :: Type -> Type -> Exp Constraint
107type instance Eval (TSerialize expr a) =
108 Serialize (a == Transpose Result expr) expr a
111-- | This type class allows you to define custom 'Table's using higher-kinded
112-- data types. Higher-kinded data types are data types of the pattern:
113--
114-- @
115-- data MyType f =
116-- MyType { field1 :: Column f T1 OR HK1 f
117-- , field2 :: Column f T2 OR HK2 f
118-- , ...
119-- , fieldN :: Column f Tn OR HKn f
120-- }
121-- @
122--
123-- where @Tn@ is any Haskell type, and @HKn@ is any higher-kinded type.
124--
125-- That is, higher-kinded data are records where all fields in the record are
126-- all either of the type @Column f T@ (for any @T@), or are themselves
127-- higher-kinded data:
128--
129-- [Nested]
130--
131-- @
132-- data Nested f =
133-- Nested { nested1 :: MyType f
134-- , nested2 :: MyType f
135-- }
136-- @
137--
138-- The @Rel8able@ type class is used to give us a special mapping operation
139-- that lets us change the type parameter @f@.
140--
141-- [Supplying @Rel8able@ instances]
142--
143-- This type class should be derived generically for all table types in your
144-- project. To do this, enable the @DeriveAnyType@ and @DeriveGeneric@ language
145-- extensions:
146--
147-- @
148-- \{\-\# LANGUAGE DeriveAnyClass, DeriveGeneric #-\}
149--
150-- data MyType f = MyType { fieldA :: Column f T }
151-- deriving ( GHC.Generics.Generic, Rel8able )
152-- @
153type Rel8able :: K.Rel8able -> Constraint
154class HTable (GColumns t) => Rel8able t where
155 type GColumns t :: K.HTable
156 type GFromExprs t :: Type
158 gfromColumns :: SContext context -> GColumns t context -> t context
159 gtoColumns :: SContext context -> t context -> GColumns t context
161 gfromResult :: GColumns t Result -> GFromExprs t
162 gtoResult :: GFromExprs t -> GColumns t Result
164 type GColumns t = G.GColumns TColumns (GRep t Expr)
165 type GFromExprs t = t Result
167 default gfromColumns :: forall context.
168 ( SRel8able t Aggregate
169 , SRel8able t Expr
170 , forall table. SRel8able t (Field table)
171 , SRel8able t Name
172 , SSerialize t
173 )
174 => SContext context -> GColumns t context -> t context
175 gfromColumns = \case
176 SAggregate -> sfromColumns
177 SExpr -> sfromColumns
178 SField -> sfromColumns
179 SName -> sfromColumns
180 SResult -> sfromResult
182 default gtoColumns :: forall context.
183 ( SRel8able t Aggregate
184 , SRel8able t Expr
185 , forall table. SRel8able t (Field table)
186 , SRel8able t Name
187 , SSerialize t
188 )
189 => SContext context -> t context -> GColumns t context
190 gtoColumns = \case
191 SAggregate -> stoColumns
192 SExpr -> stoColumns
193 SField -> stoColumns
194 SName -> stoColumns
195 SResult -> stoResult
197 default gfromResult :: (SSerialize t, GFromExprs t ~ t Result)
198 => GColumns t Result -> GFromExprs t
199 gfromResult = sfromResult
201 default gtoResult :: (SSerialize t, GFromExprs t ~ t Result)
202 => GFromExprs t -> GColumns t Result
203 gtoResult = stoResult
206type Algebra :: K.Rel8able -> K.Algebra
207type Algebra t = GAlgebra (GRep t Expr)
210type GRep :: K.Rel8able -> K.Context -> Type -> Type
211type GRep t context = Rep (Record (t context))
214type SRel8able :: K.Rel8able -> K.Context -> Constraint
215class
216 ( Generic (Record (t context))
217 , G.GTable (TTable context) TColumns (GRep t context)
218 , G.GColumns TColumns (GRep t context) ~ GColumns t
219 )
220 => SRel8able t context
221instance
222 ( Generic (Record (t context))
223 , G.GTable (TTable context) TColumns (GRep t context)
224 , G.GColumns TColumns (GRep t context) ~ GColumns t
225 )
226 => SRel8able t context
229type SSerialize :: K.Rel8able -> Constraint
230type SSerialize t =
231 ( Generic (Record (t Result))
232 , G.GSerialize TSerialize TColumns (GRep t Expr) (GRep t Result)
233 , G.GColumns TColumns (GRep t Expr) ~ GColumns t
234 )
237sfromColumns :: forall t context. SRel8able t context
238 => GColumns t context -> t context
239sfromColumns =
240 unrecord .
241 to .
242 G.gfromColumns @(TTable context) @TColumns fromColumns
245stoColumns :: forall t context. SRel8able t context
246 => t context -> GColumns t context
247stoColumns =
248 G.gtoColumns @(TTable context) @TColumns toColumns .
249 from .
250 Record
253sfromResult :: forall t. SSerialize t
254 => GColumns t Result -> t Result
255sfromResult =
256 unrecord .
257 to .
258 G.gfromResult
259 @TSerialize
260 @TColumns
261 @(GRep t Expr)
262 @(GRep t Result)
263 (\(_ :: proxy x) -> deserialize @_ @x)
266stoResult :: forall t. SSerialize t
267 => t Result -> GColumns t Result
268stoResult =
269 G.gtoResult
270 @TSerialize
271 @TColumns
272 @(GRep t Expr)
273 @(GRep t Result)
274 (\(_ :: proxy x) -> serialize @_ @x) .
275 from .
276 Record