git.iko.soy/rel8
on da76712 help sign in
rel8/src/Rel8/Schema/HTable.hs
208 lines 6.7 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 , hfoldMap, hmap, htabulateA, htraverseP, htraversePWithField
20 )
21where
23-- base
24import Data.Functor.Const ( Const( Const ), getConst )
25import Data.Kind ( Constraint, Type )
26import Data.Functor.Compose ( Compose( Compose ), getCompose )
27import Data.Proxy ( Proxy )
28import GHC.Generics
29 ( (:*:)( (:*:) )
30 , Generic (Rep, from, to)
31 , K1( K1 )
32 , M1( M1 )
33 )
34import Prelude
36-- profunctors
37import Data.Profunctor ( rmap, Profunctor (lmap) )
39-- product-profunctors
40import Data.Profunctor.Product ( ProductProfunctor ((****)) )
42-- rel8
43import Rel8.Schema.Dict ( Dict )
44import Rel8.Schema.Spec ( Spec )
45import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )
46import qualified Rel8.Schema.Kind as K
48-- semigroupoids
49import Data.Functor.Apply ( Apply, (<.>) )
51-- | A @HTable@ is a functor-indexed/higher-kinded data type that is
52-- representable ('htabulate'/'hfield'), constrainable ('hdicts'), and
53-- specified ('hspecs').
54--
55-- This is an internal concept for Rel8, and you should not need to define
56-- instances yourself or specify this constraint.
57type HTable :: K.HTable -> Constraint
58class HTable t where
59 type HField t = (field :: Type -> Type) | field -> t
60 type HConstrainTable t (c :: Type -> Constraint) :: Constraint
62 hfield :: t context -> HField t a -> context a
63 htabulate :: (forall a. HField t a -> context a) -> t context
64 htraverse :: Apply m => (forall a. f a -> m (g a)) -> t f -> m (t g)
65 hdicts :: HConstrainTable t c => t (Dict c)
66 hspecs :: t Spec
68 type HField t = GHField t
69 type HConstrainTable t c = HConstrainTable (GHColumns (Rep (t Proxy))) c
71 default hfield ::
72 ( Generic (t context)
73 , HField t ~ GHField t
74 , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))
75 , GHTable context (Rep (t context))
76 )
77 => t context -> HField t a -> context a
78 hfield table (GHField field) = hfield (toGHColumns (from table)) field
80 default htabulate ::
81 ( Generic (t context)
82 , HField t ~ GHField t
83 , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))
84 , GHTable context (Rep (t context))
85 )
86 => (forall a. HField t a -> context a) -> t context
87 htabulate f = to $ fromGHColumns $ htabulate (f . GHField)
89 default htraverse
90 :: forall f g m
91 . ( Apply m
92 , Generic (t f), GHTable f (Rep (t f))
93 , Generic (t g), GHTable g (Rep (t g))
94 , GHColumns (Rep (t f)) ~ GHColumns (Rep (t g))
95 )
96 => (forall a. f a -> m (g a)) -> t f -> m (t g)
97 htraverse f = fmap (to . fromGHColumns) . htraverse f . toGHColumns . from
99 default hdicts
100 :: forall c
101 . ( Generic (t (Dict c))
102 , GHTable (Dict c) (Rep (t (Dict c)))
103 , GHColumns (Rep (t Proxy)) ~ GHColumns (Rep (t (Dict c)))
104 , HConstrainTable (GHColumns (Rep (t Proxy))) c
105 )
106 => t (Dict c)
107 hdicts = to $ fromGHColumns (hdicts @(GHColumns (Rep (t Proxy))) @c)
109 default hspecs ::
110 ( Generic (t Spec)
111 , GHTable Spec (Rep (t Spec))
112 )
113 => t Spec
114 hspecs = to $ fromGHColumns hspecs
116 {-# INLINABLE hfield #-}
117 {-# INLINABLE htabulate #-}
118 {-# INLINABLE htraverse #-}
119 {-# INLINABLE hdicts #-}
120 {-# INLINABLE hspecs #-}
123hfoldMap :: (HTable t, Semigroup s)
124 => (forall a. context a -> s) -> t context -> s
125hfoldMap f a = getConst $ htraverse (Const . f) a
128hmap :: HTable t
129 => (forall a. context a -> context' a) -> t context -> t context'
130hmap f a = htabulate $ \field -> f (hfield a field)
133htabulateA :: (HTable t, Apply m)
134 => (forall a. HField t a -> m (context a)) -> m (t context)
135htabulateA f = htraverse getCompose $ htabulate $ Compose . f
136{-# INLINABLE htabulateA #-}
138newtype ApplyP p a b = ApplyP { unApplyP :: p a b }
140instance Profunctor p => Functor (ApplyP p a) where
141 fmap f = ApplyP . rmap f . unApplyP
143instance ProductProfunctor p => Apply (ApplyP p a) where
144 ApplyP f <.> ApplyP x = ApplyP (rmap id f **** x)
146htraverseP :: (HTable t, ProductProfunctor p)
147 => (forall a. p (f a) (g a)) -> p (t f) (t g)
148htraverseP f = htraversePWithField (const f)
150htraversePWithField :: (HTable t, ProductProfunctor p)
151 => (forall a. HField t a -> p (f a) (g a)) -> p (t f) (t g)
152htraversePWithField f = unApplyP $ htabulateA $ \field -> ApplyP $
153 lmap (flip hfield field) (f field)
155type GHField :: K.HTable -> Type -> Type
156newtype GHField t a = GHField (HField (GHColumns (Rep (t Proxy))) a)
159type GHTable :: K.Context -> (Type -> Type) -> Constraint
160class HTable (GHColumns rep) => GHTable context rep | rep -> context where
161 type GHColumns rep :: K.HTable
162 toGHColumns :: rep x -> GHColumns rep context
163 fromGHColumns :: GHColumns rep context -> rep x
166instance GHTable context rep => GHTable context (M1 i c rep) where
167 type GHColumns (M1 i c rep) = GHColumns rep
168 toGHColumns (M1 a) = toGHColumns a
169 fromGHColumns = M1 . fromGHColumns
172instance HTable table => GHTable context (K1 i (table context)) where
173 type GHColumns (K1 i (table context)) = table
174 toGHColumns (K1 a) = a
175 fromGHColumns = K1
178instance (GHTable context a, GHTable context b) => GHTable context (a :*: b) where
179 type GHColumns (a :*: b) = HProduct (GHColumns a) (GHColumns b)
180 toGHColumns (a :*: b) = HProduct (toGHColumns a) (toGHColumns b)
181 fromGHColumns (HProduct a b) = fromGHColumns a :*: fromGHColumns b
184-- | A HField type for indexing into HProduct.
185type HProductField :: K.HTable -> K.HTable -> Type -> Type
186data HProductField x y a
187 = HFst (HField x a)
188 | HSnd (HField y a)
191instance (HTable x, HTable y) => HTable (HProduct x y) where
192 type HConstrainTable (HProduct x y) c = (HConstrainTable x c, HConstrainTable y c)
193 type HField (HProduct x y) = HProductField x y
195 hfield (HProduct l r) = \case
196 HFst i -> hfield l i
197 HSnd i -> hfield r i
199 htabulate f = HProduct (htabulate (f . HFst)) (htabulate (f . HSnd))
200 htraverse f (HProduct x y) = HProduct <$> htraverse f x <.> htraverse f y
201 hdicts = HProduct hdicts hdicts
202 hspecs = HProduct hspecs hspecs
204 {-# INLINABLE hfield #-}
205 {-# INLINABLE htabulate #-}
206 {-# INLINABLE htraverse #-}
207 {-# INLINABLE hdicts #-}
208 {-# INLINABLE hspecs #-}