git.iko.soy/rel8
on da76712 help sign in
rel8/src/Rel8/Generic/Rel8able.hs
281 lines 7.6 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 == a" (where a is a
67 -- KRel8able), which occurs when we have polymorphic Rel8ables
68 -- (e.g., newtype T t f = T { x :: t a })
69 (a :: KRel8able) == (a :: KRel8able) = 'True
71 -- This extra case is needed to solve the equation "a == Identity a",
72 -- which occurs when we have polymorphic Rel8ables
73 -- (e.g., newtype T a f = T { x :: Column f a })
74 a == Identity a = 'False
76 -- These cases are exactly the same as those in 'Data.Type.Equality.==.
77 f a == g b = f == g && a == b
78 a == a = 'True
79 _ == _ = 'False
82type Serialize :: Bool -> Type -> Type -> Constraint
83class transposition ~ (a == Transpose Result expr) =>
84 Serialize transposition expr a
85 where
86 serialize :: a -> Columns expr Result
87 deserialize :: Columns expr Result -> a
90instance
91 ( (a == Transpose Result expr) ~ 'True
92 , Transposes Expr Result expr a
93 )
94 => Serialize 'True expr a
95 where
96 serialize = toColumns
97 deserialize = fromColumns
100instance
101 ( (a == Transpose Result expr) ~ 'False
102 , Table (Context expr) expr
103 , FromExprs expr ~ a
104 )
105 => Serialize 'False expr a
106 where
107 serialize = toResult @_ @expr
108 deserialize = fromResult @_ @expr
111data TSerialize :: Type -> Type -> Exp Constraint
112type instance Eval (TSerialize expr a) =
113 Serialize (a == Transpose Result expr) expr a
116-- | This type class allows you to define custom 'Table's using higher-kinded
117-- data types. Higher-kinded data types are data types of the pattern:
118--
119-- @
120-- data MyType f =
121-- MyType { field1 :: Column f T1 OR HK1 f
122-- , field2 :: Column f T2 OR HK2 f
123-- , ...
124-- , fieldN :: Column f Tn OR HKn f
125-- }
126-- @
127--
128-- where @Tn@ is any Haskell type, and @HKn@ is any higher-kinded type.
129--
130-- That is, higher-kinded data are records where all fields in the record are
131-- all either of the type @Column f T@ (for any @T@), or are themselves
132-- higher-kinded data:
133--
134-- [Nested]
135--
136-- @
137-- data Nested f =
138-- Nested { nested1 :: MyType f
139-- , nested2 :: MyType f
140-- }
141-- @
142--
143-- The @Rel8able@ type class is used to give us a special mapping operation
144-- that lets us change the type parameter @f@.
145--
146-- [Supplying @Rel8able@ instances]
147--
148-- This type class should be derived generically for all table types in your
149-- project. To do this, enable the @DeriveAnyClass@ and @DeriveGeneric@ language
150-- extensions:
151--
152-- @
153-- \{\-\# LANGUAGE DeriveAnyClass, DeriveGeneric #-\}
154--
155-- data MyType f = MyType { fieldA :: Column f T }
156-- deriving ( GHC.Generics.Generic, Rel8able )
157-- @
158type Rel8able :: K.Rel8able -> Constraint
159class HTable (GColumns t) => Rel8able t where
160 type GColumns t :: K.HTable
161 type GFromExprs t :: Type
163 gfromColumns :: SContext context -> GColumns t context -> t context
164 gtoColumns :: SContext context -> t context -> GColumns t context
166 gfromResult :: GColumns t Result -> GFromExprs t
167 gtoResult :: GFromExprs t -> GColumns t Result
169 type GColumns t = G.GColumns TColumns (GRep t Expr)
170 type GFromExprs t = t Result
172 default gfromColumns :: forall context.
173 ( SRel8able t Aggregate
174 , SRel8able t Expr
175 , forall table. SRel8able t (Field table)
176 , SRel8able t Name
177 , SSerialize t
178 )
179 => SContext context -> GColumns t context -> t context
180 gfromColumns = \case
181 SAggregate -> sfromColumns
182 SExpr -> sfromColumns
183 SField -> sfromColumns
184 SName -> sfromColumns
185 SResult -> sfromResult
187 default gtoColumns :: forall context.
188 ( SRel8able t Aggregate
189 , SRel8able t Expr
190 , forall table. SRel8able t (Field table)
191 , SRel8able t Name
192 , SSerialize t
193 )
194 => SContext context -> t context -> GColumns t context
195 gtoColumns = \case
196 SAggregate -> stoColumns
197 SExpr -> stoColumns
198 SField -> stoColumns
199 SName -> stoColumns
200 SResult -> stoResult
202 default gfromResult :: (SSerialize t, GFromExprs t ~ t Result)
203 => GColumns t Result -> GFromExprs t
204 gfromResult = sfromResult
206 default gtoResult :: (SSerialize t, GFromExprs t ~ t Result)
207 => GFromExprs t -> GColumns t Result
208 gtoResult = stoResult
211type Algebra :: K.Rel8able -> K.Algebra
212type Algebra t = GAlgebra (GRep t Expr)
215type GRep :: K.Rel8able -> K.Context -> Type -> Type
216type GRep t context = Rep (Record (t context))
219type SRel8able :: K.Rel8able -> K.Context -> Constraint
220class
221 ( Generic (Record (t context))
222 , G.GTable (TTable context) TColumns (GRep t context)
223 , G.GColumns TColumns (GRep t context) ~ GColumns t
224 )
225 => SRel8able t context
226instance
227 ( Generic (Record (t context))
228 , G.GTable (TTable context) TColumns (GRep t context)
229 , G.GColumns TColumns (GRep t context) ~ GColumns t
230 )
231 => SRel8able t context
234type SSerialize :: K.Rel8able -> Constraint
235type SSerialize t =
236 ( Generic (Record (t Result))
237 , G.GSerialize TSerialize TColumns (GRep t Expr) (GRep t Result)
238 , G.GColumns TColumns (GRep t Expr) ~ GColumns t
239 )
242sfromColumns :: forall t context. SRel8able t context
243 => GColumns t context -> t context
244sfromColumns =
245 unrecord .
246 to .
247 G.gfromColumns @(TTable context) @TColumns fromColumns
250stoColumns :: forall t context. SRel8able t context
251 => t context -> GColumns t context
252stoColumns =
253 G.gtoColumns @(TTable context) @TColumns toColumns .
254 from .
255 Record
258sfromResult :: forall t. SSerialize t
259 => GColumns t Result -> t Result
260sfromResult =
261 unrecord .
262 to .
263 G.gfromResult
264 @TSerialize
265 @TColumns
266 @(GRep t Expr)
267 @(GRep t Result)
268 (\(_ :: proxy x) -> deserialize @_ @x)
271stoResult :: forall t. SSerialize t
272 => t Result -> GColumns t Result
273stoResult =
274 G.gtoResult
275 @TSerialize
276 @TColumns
277 @(GRep t Expr)
278 @(GRep t Result)
279 (\(_ :: proxy x) -> serialize @_ @x) .
280 from .
281 Record