git.iko.soy/rel8
on 97d89cf help sign in
rel8/src/Rel8/Generic/Rel8able.hs
196 lines 5.4 kB history raw
1{-# language AllowAmbiguousTypes #-}
2{-# language ConstraintKinds #-}
3{-# language DataKinds #-}
4{-# language DefaultSignatures #-}
5{-# language FlexibleContexts #-}
6{-# language LambdaCase #-}
7{-# language ScopedTypeVariables #-}
8{-# language StandaloneKindSignatures #-}
9{-# language TypeApplications #-}
10{-# language TypeFamilies #-}
11{-# language TypeFamilyDependencies #-}
12{-# language UndecidableInstances #-}
14module Rel8.Generic.Rel8able
15 ( KRel8able, Rel8able
16 , Algebra
17 , GRep
18 , GColumns, gfromColumns, gtoColumns
19 , GFromExprs, gfromResult, gtoResult
20 )
21where
23-- base
24import Data.Kind ( Constraint, Type )
25import GHC.Generics ( Generic, Rep, from, to )
26import Prelude
28-- rel8
29import Rel8.Aggregate ( Aggregate )
30import Rel8.Expr ( Expr )
31import Rel8.Generic.Map ( GMap )
32import Rel8.Generic.Record ( Record(..) )
33import Rel8.Generic.Table ( GAlgebra )
34import qualified Rel8.Generic.Table.Record as G
35import qualified Rel8.Kind.Algebra as K ( Algebra(..) )
36import Rel8.Schema.Context.Virtual ( Abstract(..) )
37import Rel8.Schema.HTable ( HTable )
38import qualified Rel8.Schema.Kind as K
39import Rel8.Schema.Name ( Name )
40import Rel8.Schema.Result ( Result )
41import Rel8.Table
42 ( fromColumns, toColumns, fromResult, toResult
43 , TTable, TColumns, TFromExprs
44 )
47-- | The kind of 'Rel8able' types
48type KRel8able :: Type
49type KRel8able = K.Rel8able
52-- | This type class allows you to define custom 'Table's using higher-kinded
53-- data types. Higher-kinded data types are data types of the pattern:
54--
55-- @
56-- data MyType f =
57-- MyType { field1 :: Column f T1 OR HK1 f
58-- , field2 :: Column f T2 OR HK2 f
59-- , ...
60-- , fieldN :: Column f Tn OR HKn f
61-- }
62-- @
63--
64-- where @Tn@ is any Haskell type, and @HKn@ is any higher-kinded type.
65--
66-- That is, higher-kinded data are records where all fields in the record are
67-- all either of the type @Column f T@ (for any @T@), or are themselves
68-- higher-kinded data:
69--
70-- [Nested]
71--
72-- @
73-- data Nested f =
74-- Nested { nested1 :: MyType f
75-- , nested2 :: MyType f
76-- }
77-- @
78--
79-- The @Rel8able@ type class is used to give us a special mapping operation
80-- that lets us change the type parameter @f@.
81--
82-- [Supplying @Rel8able@ instances]
83--
84-- This type class should be derived generically for all table types in your
85-- project. To do this, enable the @DeriveAnyType@ and @DeriveGeneric@ language
86-- extensions:
87--
88-- @
89-- \{\-\# LANGUAGE DeriveAnyClass, DeriveGeneric #-\}
90--
91-- data MyType f = MyType { fieldA :: Column f T }
92-- deriving ( GHC.Generics.Generic, Rel8able )
93-- @
94type Rel8able :: K.Rel8able -> Constraint
95class HTable (GColumns t) => Rel8able t where
96 type GColumns t :: K.HTable
97 type GFromExprs t :: Type
99 gfromColumns :: Abstract context -> GColumns t context -> t context
100 gtoColumns :: Abstract context -> t context -> GColumns t context
102 gfromResult :: GColumns t Result -> GFromExprs t
103 gtoResult :: GFromExprs t -> GColumns t Result
105 type GColumns t = G.GColumns TColumns (GRep t Expr)
106 type GFromExprs t = t Result
108 default gfromColumns :: forall context.
109 ( VRel8able t Aggregate
110 , VRel8able t Expr
111 , VRel8able t Name
112 )
113 => Abstract context -> GColumns t context -> t context
114 gfromColumns = \case
115 VAggregate -> vfromColumns
116 VExpr -> vfromColumns
117 VName -> vfromColumns
119 default gtoColumns :: forall context.
120 ( VRel8able t Aggregate
121 , VRel8able t Expr
122 , VRel8able t Name
123 )
124 => Abstract context -> t context -> GColumns t context
125 gtoColumns = \case
126 VAggregate -> vtoColumns
127 VExpr -> vtoColumns
128 VName -> vtoColumns
130 default gfromResult ::
131 ( Generic (Record (t Result))
132 , G.GTable (TTable Expr) TColumns TFromExprs (GRep t Expr)
133 , G.GColumns TColumns (GRep t Expr) ~ GColumns t
134 , Rep (Record (t Result)) ~ GMap TFromExprs (GRep t Expr)
135 , GFromExprs t ~ t Result
136 )
137 => GColumns t Result -> GFromExprs t
138 gfromResult =
139 unrecord .
140 to .
141 G.gfromResult
142 @(TTable Expr)
143 @TColumns
144 @TFromExprs
145 @(GRep t Expr)
146 (\(_ :: proxy x) -> fromResult @Expr @x)
148 default gtoResult ::
149 ( Generic (Record (t Result))
150 , G.GTable (TTable Expr) TColumns TFromExprs (GRep t Expr)
151 , G.GColumns TColumns (GRep t Expr) ~ GColumns t
152 , Rep (Record (t Result)) ~ GMap TFromExprs (GRep t Expr)
153 , GFromExprs t ~ t Result
154 )
155 => GFromExprs t -> GColumns t Result
156 gtoResult =
157 G.gtoResult
158 @(TTable Expr)
159 @TColumns
160 @TFromExprs
161 @(GRep t Expr)
162 (\(_ :: proxy x) -> toResult @Expr @x) .
163 from .
164 Record
167type Algebra :: K.Rel8able -> K.Algebra
168type Algebra t = GAlgebra (GRep t Expr)
171type GRep :: K.Rel8able -> K.Context -> Type -> Type
172type GRep t context = Rep (Record (t context))
175type VRel8able :: K.Rel8able -> K.Context -> Constraint
176type VRel8able t context =
177 ( Generic (Record (t context))
178 , G.GTable (TTable context) TColumns TFromExprs (GRep t context)
179 , G.GColumns TColumns (GRep t context) ~ GColumns t
180 )
183vfromColumns :: forall t context. VRel8able t context
184 => GColumns t context -> t context
185vfromColumns =
186 unrecord .
187 to .
188 G.gfromColumns @(TTable context) @TColumns @TFromExprs fromColumns
191vtoColumns :: forall t context. VRel8able t context
192 => t context -> GColumns t context
193vtoColumns =
194 G.gtoColumns @(TTable context) @TColumns @TFromExprs toColumns .
195 from .
196 Record