git.iko.soy/rel8
on ba684c0 help sign in
rel8/src/Rel8/Schema/Generic.hs
194 lines 5.9 kB history raw
1{-# language AllowAmbiguousTypes #-}
2{-# language DataKinds #-}
3{-# language DisambiguateRecordFields #-}
4{-# language DefaultSignatures #-}
5{-# language FlexibleContexts #-}
6{-# language FlexibleInstances #-}
7{-# language GADTs #-}
8{-# language MultiParamTypeClasses #-}
9{-# language QuantifiedConstraints #-}
10{-# language ScopedTypeVariables #-}
11{-# language StandaloneKindSignatures #-}
12{-# language TypeApplications #-}
13{-# language TypeFamilies #-}
14{-# language TypeOperators #-}
15{-# language UndecidableInstances #-}
17{-# options_ghc -fno-warn-orphans #-}
19module Rel8.Schema.Generic
20 ( Rel8able
21 )
22where
24-- base
25import Data.Kind ( Constraint, Type )
26import GHC.Generics
27 ( Generic, Rep, from, to
28 , (:*:)( (:*:) ), K1( K1 ), M1( M1 )
29 , D, S
30 , Meta( MetaSel )
31 )
32import qualified GHC.Generics as G ( C )
33import GHC.TypeLits ( KnownSymbol )
34import Prelude
35import Unsafe.Coerce ( unsafeCoerce )
37-- rel8
38import Rel8.Schema.Context ( Col )
39import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
40import Rel8.Schema.Field ( Reify, Reifiable, hreify, hunreify )
41import Rel8.Schema.HTable ( HTable )
42import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
43import Rel8.Schema.HTable.Pair ( HPair(..) )
44import qualified Rel8.Schema.Kind as K
45import Rel8.Schema.Name ( Name )
46import Rel8.Schema.Spec ( KTable )
47import Rel8.Table
48 ( Table, Columns, Context, fromColumns, toColumns
49 )
52instance
53 ( Rel8able t
54 , Labelable context
55 , Reifiable context
56 ) => Table context (t context)
57 where
58 type Columns (t context) = GRep t
59 type Context (t context) = context
61 fromColumns = unreify . gfromColumns . hreify
62 toColumns = hunreify . gtoColumns . reify
65-- | This type class allows you to define custom 'Table's using higher-kinded
66-- data types. Higher-kinded data types are data types of the pattern:
67--
68-- @
69-- data MyType f =
70-- MyType { field1 :: Column f T1 OR HK1 f
71-- , field2 :: Column f T2 OR HK2 f
72-- , ...
73-- , fieldN :: Column f Tn OR HKn f
74-- }
75-- @
76--
77-- where @Tn@ is any Haskell type, and @HKn@ is any higher-kinded type.
78--
79-- That is, higher-kinded data are records where all fields in the record are
80-- all either of the type @Column f T@ (for any @T@), or are themselves
81-- higher-kinded data:
82--
83-- [Nested]
84--
85-- @
86-- data Nested f =
87-- Nested { nested1 :: MyType f
88-- , nested2 :: MyType f
89-- }
90-- @
91--
92-- The @Rel8able@ type class is used to give us a special mapping operation
93-- that lets us change the type parameter @f@.
94--
95-- [Supplying @Rel8able@ instances]
96--
97-- This type class should be derived generically for all table types in your
98-- project. To do this, enable the @DeriveAnyType@ and @DeriveGeneric@ language
99-- extensions:
100--
101-- @
102-- \{\-\# LANGUAGE DeriveAnyClass, DeriveGeneric #-\}
103--
104-- data MyType f = MyType { fieldA :: Column f T }
105-- deriving ( GHC.Generics.Generic, Rel8able )
106-- @
107type Rel8able :: KTable -> Constraint
108class HTable (GRep t) => Rel8able t where
109 gfromColumns :: (Labelable context, Reifiable context)
110 => GRep t (Col (Reify context)) -> t (Reify context)
112 gtoColumns :: (Labelable context, Reifiable context)
113 => t (Reify context) -> GRep t (Col (Reify context))
115 default gfromColumns :: forall context.
116 ( Generic (t (Reify context))
117 , GColumns (Rep (t (Reify context))) ~ GRep t
118 , GRel8able context (Rep (t (Reify context)))
119 ) => GRep t (Col (Reify context)) -> t (Reify context)
120 gfromColumns = to . fromGColumns @_ @(Rep (t (Reify context)))
122 default gtoColumns :: forall context.
123 ( Generic (t (Reify context))
124 , GColumns (Rep (t (Reify context))) ~ GRep t
125 , GRel8able context (Rep (t (Reify context)))
126 ) => t (Reify context) -> GRep t (Col (Reify context))
127 gtoColumns = toGColumns @_ @(Rep (t (Reify context))) . from
130type GRep :: K.Table -> K.HTable
131type GRep t = GColumns (Rep (t (Reify Name)))
134type GColumns :: (Type -> Type) -> K.HTable
135type family GColumns rep where
136 GColumns (M1 D _ rep) = GColumns rep
137 GColumns (M1 G.C _ rep) = GColumns rep
138 GColumns (rep1 :*: rep2) = HPair (GColumns rep1) (GColumns rep2)
139 GColumns (M1 S ('MetaSel ('Just label) _ _ _) (K1 _ a)) =
140 HLabel label (Columns a)
143type GRel8able :: K.Context -> (Type -> Type) -> Constraint
144class GRel8able context rep where
145 fromGColumns :: GColumns rep (Col (Reify context)) -> rep x
146 toGColumns :: rep x -> GColumns rep (Col (Reify context))
149instance GRel8able context rep => GRel8able context (M1 D c rep) where
150 fromGColumns = M1 . fromGColumns @context @rep
151 toGColumns (M1 a) = toGColumns @context @rep a
154instance GRel8able context rep => GRel8able context (M1 G.C c rep) where
155 fromGColumns = M1 . fromGColumns @context @rep
156 toGColumns (M1 a) = toGColumns @context @rep a
159instance (GRel8able context rep1, GRel8able context rep2) =>
160 GRel8able context (rep1 :*: rep2)
161 where
162 fromGColumns (HPair a b) =
163 fromGColumns @context @rep1 a :*: fromGColumns @context @rep2 b
164 toGColumns (a :*: b) =
165 HPair (toGColumns @context @rep1 a) (toGColumns @context @rep2 b)
168instance
169 ( Table (Reify context) a
170 , Labelable context
171 , KnownSymbol label
172 , GColumns (M1 S meta k1) ~ HLabel label (Columns a)
173 , meta ~ 'MetaSel ('Just label) _su _ss _ds
174 , k1 ~ K1 i a
175 ) => GRel8able context (M1 S meta k1)
176 where
177 fromGColumns = M1 . K1 . fromColumns . hunlabel unlabeler
178 toGColumns (M1 (K1 a)) = hlabel labeler (toColumns a)
181reify ::
182 (-- Rel8able t
183 --, forall necessity a. Coercible (Field context necessity a) (AField context necessity a) => Coercible (t context) (t (Reify context))
184 )
185 => t context -> t (Reify context)
186reify = unsafeCoerce
189unreify ::
190 (-- Rel8able t
191 --, forall necessity a. Coercible (AField context necessity a) (Field context necessity a) => Coercible (t (Reify context)) (t context)
192 )
193 => t (Reify context) -> t context
194unreify = unsafeCoerce