git.iko.soy/rel8
on db148ff help sign in
rel8/src/Rel8/Schema/HTable.hs
181 lines 5.8 kB history raw
1{-# language AllowAmbiguousTypes #-}
2{-# language DataKinds #-}
3{-# language DefaultSignatures #-}
4{-# language FlexibleContexts #-}
5{-# language FlexibleInstances #-}
6{-# language FunctionalDependencies #-}
7{-# language LambdaCase #-}
8{-# language RankNTypes #-}
9{-# language ScopedTypeVariables #-}
10{-# language StandaloneKindSignatures #-}
11{-# language TypeApplications #-}
12{-# language TypeFamilyDependencies #-}
13{-# language TypeOperators #-}
14{-# language UndecidableInstances #-}
16module Rel8.Schema.HTable
17 ( HTable (HField, HConstrainTable)
18 , hfield, htabulate, htraverse, hdicts, hspecs
19 , hmap, htabulateA
20 )
21where
23-- base
24import Data.Kind ( Constraint, Type )
25import Data.Functor.Compose ( Compose( Compose ), getCompose )
26import Data.Proxy ( Proxy )
27import GHC.Generics
28 ( (:*:)( (:*:) )
29 , Generic (Rep, from, to)
30 , K1( K1 )
31 , M1( M1 )
32 )
33import Prelude
35-- rel8
36import Rel8.Schema.Dict ( Dict )
37import Rel8.Schema.Spec ( Spec, SSpec )
38import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )
39import qualified Rel8.Schema.Kind as K
41-- semigroupoids
42import Data.Functor.Apply ( Apply, (<.>) )
45-- | A @HTable@ is a functor-indexed/higher-kinded data type that is
46-- representable ('htabulate'/'hfield'), constrainable ('hdicts'), and
47-- specified ('hspecs').
48--
49-- This is an internal concept for Rel8, and you should not need to define
50-- instances yourself or specify this constraint.
51type HTable :: K.HTable -> Constraint
52class HTable t where
53 type HField t = (field :: Spec -> Type) | field -> t
54 type HConstrainTable t (c :: Spec -> Constraint) :: Constraint
56 hfield :: t context -> HField t spec -> context spec
57 htabulate :: (forall spec. HField t spec -> context spec) -> t context
58 htraverse :: Apply m => (forall spec. f spec -> m (g spec)) -> t f -> m (t g)
59 hdicts :: HConstrainTable t c => t (Dict c)
60 hspecs :: t SSpec
62 type HField t = GHField t
63 type HConstrainTable t c = HConstrainTable (GHColumns (Rep (t Proxy))) c
65 default hfield ::
66 ( Generic (t context)
67 , HField t ~ GHField t
68 , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))
69 , GHTable context (Rep (t context))
70 )
71 => t context -> HField t spec -> context spec
72 hfield table (GHField field) = hfield (toGHColumns (from table)) field
74 default htabulate ::
75 ( Generic (t context)
76 , HField t ~ GHField t
77 , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))
78 , GHTable context (Rep (t context))
79 )
80 => (forall spec. HField t spec -> context spec) -> t context
81 htabulate f = to $ fromGHColumns $ htabulate (f . GHField)
83 default htraverse
84 :: forall f g m
85 . ( Apply m
86 , Generic (t f), GHTable f (Rep (t f))
87 , Generic (t g), GHTable g (Rep (t g))
88 , GHColumns (Rep (t f)) ~ GHColumns (Rep (t g))
89 )
90 => (forall spec. f spec -> m (g spec)) -> t f -> m (t g)
91 htraverse f = fmap (to . fromGHColumns) . htraverse f . toGHColumns . from
93 default hdicts
94 :: forall c
95 . ( Generic (t (Dict c))
96 , GHTable (Dict c) (Rep (t (Dict c)))
97 , GHColumns (Rep (t Proxy)) ~ GHColumns (Rep (t (Dict c)))
98 , HConstrainTable (GHColumns (Rep (t Proxy))) c
99 )
100 => t (Dict c)
101 hdicts = to $ fromGHColumns (hdicts @(GHColumns (Rep (t Proxy))) @c)
103 default hspecs ::
104 ( Generic (t SSpec)
105 , GHTable SSpec (Rep (t SSpec))
106 )
107 => t SSpec
108 hspecs = to $ fromGHColumns hspecs
110 {-# INLINABLE hfield #-}
111 {-# INLINABLE htabulate #-}
112 {-# INLINABLE htraverse #-}
113 {-# INLINABLE hdicts #-}
114 {-# INLINABLE hspecs #-}
117hmap :: HTable t
118 => (forall spec. context spec -> context' spec) -> t context -> t context'
119hmap f a = htabulate $ \field -> f (hfield a field)
122htabulateA :: (HTable t, Apply m)
123 => (forall spec. HField t spec -> m (context spec)) -> m (t context)
124htabulateA f = htraverse getCompose $ htabulate $ Compose . f
125{-# INLINABLE htabulateA #-}
128type GHField :: K.HTable -> Spec -> Type
129newtype GHField t spec = GHField (HField (GHColumns (Rep (t Proxy))) spec)
132type GHTable :: K.HContext -> (Type -> Type) -> Constraint
133class HTable (GHColumns rep) => GHTable context rep | rep -> context where
134 type GHColumns rep :: K.HTable
135 toGHColumns :: rep x -> GHColumns rep context
136 fromGHColumns :: GHColumns rep context -> rep x
139instance GHTable context rep => GHTable context (M1 i c rep) where
140 type GHColumns (M1 i c rep) = GHColumns rep
141 toGHColumns (M1 a) = toGHColumns a
142 fromGHColumns = M1 . fromGHColumns
145instance HTable table => GHTable context (K1 i (table context)) where
146 type GHColumns (K1 i (table context)) = table
147 toGHColumns (K1 a) = a
148 fromGHColumns = K1
151instance (GHTable context a, GHTable context b) => GHTable context (a :*: b) where
152 type GHColumns (a :*: b) = HProduct (GHColumns a) (GHColumns b)
153 toGHColumns (a :*: b) = HProduct (toGHColumns a) (toGHColumns b)
154 fromGHColumns (HProduct a b) = fromGHColumns a :*: fromGHColumns b
157-- | A HField type for indexing into HProduct.
158type HProductField :: K.HTable -> K.HTable -> Spec -> Type
159data HProductField x y spec
160 = HFst (HField x spec)
161 | HSnd (HField y spec)
164instance (HTable x, HTable y) => HTable (HProduct x y) where
165 type HConstrainTable (HProduct x y) c = (HConstrainTable x c, HConstrainTable y c)
166 type HField (HProduct x y) = HProductField x y
168 hfield (HProduct l r) = \case
169 HFst i -> hfield l i
170 HSnd i -> hfield r i
172 htabulate f = HProduct (htabulate (f . HFst)) (htabulate (f . HSnd))
173 htraverse f (HProduct x y) = HProduct <$> htraverse f x <.> htraverse f y
174 hdicts = HProduct hdicts hdicts
175 hspecs = HProduct hspecs hspecs
177 {-# INLINABLE hfield #-}
178 {-# INLINABLE htabulate #-}
179 {-# INLINABLE htraverse #-}
180 {-# INLINABLE hdicts #-}
181 {-# INLINABLE hspecs #-}