git.iko.soy/rel8
on 6ecc65f help sign in
rel8/src/Rel8/Generic/Rel8able.hs
265 lines 8.1 kB history raw
1{-# language AllowAmbiguousTypes #-}
2{-# language ConstraintKinds #-}
3{-# language DataKinds #-}
4{-# language DefaultSignatures #-}
5{-# language FlexibleContexts #-}
6{-# language FlexibleInstances #-}
7{-# language MultiParamTypeClasses #-}
8{-# language ScopedTypeVariables #-}
9{-# language StandaloneKindSignatures #-}
10{-# language TypeApplications #-}
11{-# language TypeFamilies #-}
12{-# language UndecidableInstances #-}
14{-# options_ghc -fno-warn-orphans #-}
16module Rel8.Generic.Rel8able
17 ( KRel8able, Rel8able
18 , GColumns, GContext, gfromColumns, gtoColumns, greify, gunreify
19 , Algebra
20 )
21where
23-- base
24import Data.Kind ( Constraint, Type )
25import Data.Proxy ( Proxy( Proxy ) )
26import Data.Type.Equality ( (:~:)( Refl ) )
27import GHC.Generics ( Generic, Rep, from, to )
28import Prelude
30-- rel8
31import Rel8.Kind.Context
32 ( SContext( SReify )
33 , Reifiable, contextSing
34 , sLabelable, sReifiable
35 )
36import Rel8.FCF ( Eval, Exp )
37import Rel8.Generic.Map ( GMap, GMappable, gmap, gunmap )
38import Rel8.Generic.Record ( Record(..) )
39import Rel8.Generic.Table
40 ( GGTable, GGColumns, GGContext, ggfromColumns, ggtoColumns
41 , GAlgebra
42 )
43import Rel8.Kind.Algebra
44 ( SAlgebra( SProduct, SSum )
45 , KnownAlgebra, algebraSing
46 )
47import qualified Rel8.Kind.Algebra as K ( Algebra(..) )
48import Rel8.Schema.Context ( Col )
49import Rel8.Schema.Context.Label ( Labelable )
50import Rel8.Schema.Dict ( Dict( Dict ) )
51import Rel8.Schema.HTable ( HTable )
52import qualified Rel8.Schema.Kind as K
53import Rel8.Schema.Name ( Name )
54import Rel8.Schema.Reify
55 ( Col( Reify ), Reify, hreify, hunreify
56 , UnwrapReify
57 )
58import Rel8.Schema.Result ( Result )
59import Rel8.Table
60 ( Table, Columns, Context, fromColumns, toColumns
61 , Unreify, reify, unreify
62 , TTable, TColumns, TContext, TUnreify
63 )
66instance
67 ( Rel8able t
68 , GContext t context ~ context
69 , Labelable context
70 , Reifiable context
71 )
72 => Table context (t context)
73 where
74 type Columns (t context) = GColumns t
75 type Context (t context) = context
76 type Unreify (t context) = t (UnwrapReify context)
78 fromColumns = gunreify . gfromColumns . hreify
79 toColumns = hunreify . gtoColumns . greify
81 reify Refl = case contextSing @context of
82 SReify context -> case sLabelable context of
83 Dict -> case sReifiable context of
84 Dict -> greify
86 unreify Refl = case contextSing @context of
87 SReify context -> case sLabelable context of
88 Dict -> case sReifiable context of
89 Dict -> gunreify
92type KRel8able :: Type
93type KRel8able = K.Rel8able
96-- | This type class allows you to define custom 'Table's using higher-kinded
97-- data types. Higher-kinded data types are data types of the pattern:
98--
99-- @
100-- data MyType f =
101-- MyType { field1 :: Column f T1 OR HK1 f
102-- , field2 :: Column f T2 OR HK2 f
103-- , ...
104-- , fieldN :: Column f Tn OR HKn f
105-- }
106-- @
107--
108-- where @Tn@ is any Haskell type, and @HKn@ is any higher-kinded type.
109--
110-- That is, higher-kinded data are records where all fields in the record are
111-- all either of the type @Column f T@ (for any @T@), or are themselves
112-- higher-kinded data:
113--
114-- [Nested]
115--
116-- @
117-- data Nested f =
118-- Nested { nested1 :: MyType f
119-- , nested2 :: MyType f
120-- }
121-- @
122--
123-- The @Rel8able@ type class is used to give us a special mapping operation
124-- that lets us change the type parameter @f@.
125--
126-- [Supplying @Rel8able@ instances]
127--
128-- This type class should be derived generically for all table types in your
129-- project. To do this, enable the @DeriveAnyType@ and @DeriveGeneric@ language
130-- extensions:
131--
132-- @
133-- \{\-\# LANGUAGE DeriveAnyClass, DeriveGeneric #-\}
134--
135-- data MyType f = MyType { fieldA :: Column f T }
136-- deriving ( GHC.Generics.Generic, Rel8able )
137-- @
138type Rel8able :: K.Rel8able -> Constraint
139class HTable (GColumns t) => Rel8able t where
140 type Algebra t :: K.Algebra
141 type GColumns t :: K.HTable
142 type GContext t (context :: K.Context) :: K.Context
144 gfromColumns :: (Labelable context, Reifiable context, GContext t context ~ context)
145 => GColumns t (Col (Reify context)) -> t (Reify context)
147 gtoColumns :: (Labelable context, Reifiable context, GContext t context ~ context)
148 => t (Reify context) -> GColumns t (Col (Reify context))
150 greify :: (Labelable context, Reifiable context)
151 => t context -> t (Reify context)
153 gunreify :: (Labelable context, Reifiable context)
154 => t (Reify context) -> t context
156 type Algebra t = GAlgebra (Rep (Record (t (Reify Name))))
157 type GColumns t = Eval (GGColumns (Algebra t) TColumns (Rep (Record (t (Reify Name)))))
158 type GContext t context = Eval (GGContext (Algebra t) TUnreifyContext (Rep (Record (t (Reify context)))))
160 default gfromColumns :: forall context.
161 ( Generic (Record (t (Reify context)))
162 , KnownAlgebra (Algebra t)
163 , Eval (GGTable (Algebra t) (TTable (Reify context)) TColumns (Col (Reify context)) (Rep (Record (t (Reify context)))))
164 , Eval (GGColumns (Algebra t) TColumns (Rep (Record (t (Reify context))))) ~ GColumns t
165 , Constraints t context
166 )
167 => GColumns t (Col (Reify context)) -> t (Reify context)
168 gfromColumns =
169 unrecord .
170 to .
171 ggfromColumns
172 @(Algebra t)
173 @(TTable (Reify context))
174 @TColumns
175 @TContext
176 (fromContext @t @context)
177 (toContext @t @context)
178 fromColumns
180 default gtoColumns :: forall context.
181 ( Generic (Record (t (Reify context)))
182 , KnownAlgebra (Algebra t)
183 , Eval (GGTable (Algebra t) (TTable (Reify context)) TColumns (Col (Reify context)) (Rep (Record (t (Reify context)))))
184 , Eval (GGColumns (Algebra t) TColumns (Rep (Record (t (Reify context))))) ~ GColumns t
185 , Constraints t context
186 )
187 => t (Reify context) -> GColumns t (Col (Reify context))
188 gtoColumns =
189 ggtoColumns
190 @(Algebra t)
191 @(TTable (Reify context))
192 @TColumns
193 @TContext
194 (fromContext @t @context)
195 (toContext @t @context)
196 toColumns .
197 from .
198 Record
200 default greify :: forall context.
201 ( Generic (Record (t context))
202 , Generic (Record (t (Reify context)))
203 , GMappable (TTable (Reify context)) (Rep (Record (t (Reify context))))
204 , Rep (Record (t context)) ~ GMap TUnreify (Rep (Record (t (Reify context))))
205 )
206 => t context -> t (Reify context)
207 greify =
208 unrecord .
209 to .
210 gunmap @(TTable (Reify context)) (Proxy @TUnreify) (reify Refl) .
211 from .
212 Record
214 default gunreify :: forall context.
215 ( Generic (Record (t context))
216 , Generic (Record (t (Reify context)))
217 , GMappable (TTable (Reify context)) (Rep (Record (t (Reify context))))
218 , Rep (Record (t context)) ~ GMap TUnreify (Rep (Record (t (Reify context))))
219 )
220 => t (Reify context) -> t context
221 gunreify =
222 unrecord .
223 to .
224 gmap @(TTable (Reify context)) (Proxy @TUnreify) (unreify Refl) .
225 from .
226 Record
229data TUnreifyContext :: Type -> Exp K.Context
230type instance Eval (TUnreifyContext a) = UnwrapReify (Eval (TContext a))
233type Constraints :: K.Rel8able -> K.Context -> Constraint
234type Constraints t context = Constraints' (Algebra t) t context
237type Constraints' :: K.Algebra -> K.Rel8able -> K.Context -> Constraint
238type family Constraints' algebra t context where
239 Constraints' 'K.Product t context =
240 ( Eval (GGContext 'K.Product TContext (Rep (Record (t (Reify context))))) ~
241 Reify context
242 )
243 Constraints' 'K.Sum _ context = context ~ Result
246fromContext :: forall t context spec.
247 ( KnownAlgebra (Algebra t)
248 , Constraints t context
249 )
250 => Col (Reify context) spec
251 -> Col (Eval (GGContext (Algebra t) TContext (Rep (Record (t (Reify context)))))) spec
252fromContext = case algebraSing @(Algebra t) of
253 SProduct -> id
254 SSum -> \(Reify a) -> a
257toContext :: forall t context spec.
258 ( KnownAlgebra (Algebra t)
259 , Constraints t context
260 )
261 => Col (Eval (GGContext (Algebra t) TContext (Rep (Record (t (Reify context)))))) spec
262 -> Col (Reify context) spec
263toContext = case algebraSing @(Algebra t) of
264 SProduct -> id
265 SSum -> Reify