git.iko.soy/rel8
on 11bcbbb help sign in
rel8/src/Rel8/Schema/HTable.hs
178 lines 5.6 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 , htabulateA
21 , HPair(..)
22 )
23where
25-- base
26import Data.Kind ( Constraint, Type )
27import Data.Functor.Compose ( Compose( Compose ), getCompose )
28import Data.Proxy ( Proxy )
29import GHC.Generics
30 ( (:*:)( (:*:) )
31 , Generic (Rep, from, to)
32 , K1( K1 )
33 , M1( M1 )
34 )
35import Prelude
37-- rel8
38import Rel8.Schema.Dict ( Dict )
39import Rel8.Schema.Spec ( Spec, SSpec )
40import Rel8.Schema.HTable.Pair ( HPair( HPair ) )
41import qualified Rel8.Schema.Kind as K
43-- semigroupoids
44import Data.Functor.Apply ( Apply, (<.>) )
47-- | A @HTable@ is a functor-indexed/higher-kinded data type that is
48-- representable ('htabulate'/'hfield'), constrainable ('hdicts'), and
49-- specified ('hspecs').
50--
51-- This is an internal concept for Rel8, and you should not need to define
52-- instances yourself or specify this constraint.
53type HTable :: K.HTable -> Constraint
54class HTable t where
55 type HField t = (field :: Spec -> Type) | field -> t
56 type HConstrainTable t (c :: Spec -> Constraint) :: Constraint
58 hfield :: t context -> HField t spec -> context spec
59 htabulate :: (forall spec. HField t spec -> context spec) -> t context
60 htraverse :: Apply m => (forall spec. f spec -> m (g spec)) -> t f -> m (t g)
61 hdicts :: HConstrainTable t c => t (Dict c)
62 hspecs :: t SSpec
64 type HField t = GHField t
65 type HConstrainTable t c = HConstrainTable (GHColumns (Rep (t Proxy))) c
67 default hfield ::
68 ( Generic (t context)
69 , HField t ~ GHField t
70 , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))
71 , GHTable context (Rep (t context))
72 )
73 => t context -> HField t spec -> context spec
74 hfield table (GHField field) = hfield (toGHColumns (from table)) field
76 default htabulate ::
77 ( Generic (t context)
78 , HField t ~ GHField t
79 , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))
80 , GHTable context (Rep (t context))
81 )
82 => (forall spec. HField t spec -> context spec) -> t context
83 htabulate f = to $ fromGHColumns $ htabulate (f . GHField)
85 default htraverse
86 :: forall f g m
87 . ( Apply m
88 , Generic (t f), GHTable f (Rep (t f))
89 , Generic (t g), GHTable g (Rep (t g))
90 , GHColumns (Rep (t f)) ~ GHColumns (Rep (t g))
91 )
92 => (forall spec. f spec -> m (g spec)) -> t f -> m (t g)
93 htraverse f = fmap (to . fromGHColumns) . htraverse f . toGHColumns . from
95 default hdicts
96 :: forall c
97 . ( Generic (t (Dict c))
98 , GHTable (Dict c) (Rep (t (Dict c)))
99 , GHColumns (Rep (t Proxy)) ~ GHColumns (Rep (t (Dict c)))
100 , HConstrainTable (GHColumns (Rep (t Proxy))) c
101 )
102 => t (Dict c)
103 hdicts = to $ fromGHColumns (hdicts @(GHColumns (Rep (t Proxy))) @c)
105 default hspecs ::
106 ( Generic (t SSpec)
107 , GHTable SSpec (Rep (t SSpec))
108 )
109 => t SSpec
110 hspecs = to $ fromGHColumns hspecs
112 {-# INLINABLE hfield #-}
113 {-# INLINABLE htabulate #-}
114 {-# INLINABLE htraverse #-}
115 {-# INLINABLE hdicts #-}
116 {-# INLINABLE hspecs #-}
119htabulateA :: (HTable t, Apply m)
120 => (forall spec. HField t spec -> m (context spec)) -> m (t context)
121htabulateA f = htraverse getCompose $ htabulate $ Compose . f
122{-# INLINABLE htabulateA #-}
125type GHField :: K.HTable -> Spec -> Type
126newtype GHField t spec = GHField (HField (GHColumns (Rep (t Proxy))) spec)
129type GHTable :: K.HContext -> (Type -> Type) -> Constraint
130class HTable (GHColumns rep) => GHTable context rep | rep -> context where
131 type GHColumns rep :: K.HTable
132 toGHColumns :: rep x -> GHColumns rep context
133 fromGHColumns :: GHColumns rep context -> rep x
136instance GHTable context rep => GHTable context (M1 i c rep) where
137 type GHColumns (M1 i c rep) = GHColumns rep
138 toGHColumns (M1 a) = toGHColumns a
139 fromGHColumns = M1 . fromGHColumns
142instance HTable table => GHTable context (K1 i (table context)) where
143 type GHColumns (K1 i (table context)) = table
144 toGHColumns (K1 a) = a
145 fromGHColumns = K1
148instance (GHTable context a, GHTable context b) => GHTable context (a :*: b) where
149 type GHColumns (a :*: b) = HPair (GHColumns a) (GHColumns b)
150 toGHColumns (a :*: b) = HPair (toGHColumns a) (toGHColumns b)
151 fromGHColumns (HPair a b) = fromGHColumns a :*: fromGHColumns b
154-- | A HField type for indexing into HPair.
155type HPairField :: K.HTable -> K.HTable -> Spec -> Type
156data HPairField x y spec
157 = HFst (HField x spec)
158 | HSnd (HField y spec)
161instance (HTable x, HTable y) => HTable (HPair x y) where
162 type HConstrainTable (HPair x y) c = (HConstrainTable x c, HConstrainTable y c)
163 type HField (HPair x y) = HPairField x y
165 hfield (HPair l r) = \case
166 HFst i -> hfield l i
167 HSnd i -> hfield r i
169 htabulate f = HPair (htabulate (f . HFst)) (htabulate (f . HSnd))
170 htraverse f (HPair x y) = HPair <$> htraverse f x <.> htraverse f y
171 hdicts = HPair hdicts hdicts
172 hspecs = HPair hspecs hspecs
174 {-# INLINABLE hfield #-}
175 {-# INLINABLE htabulate #-}
176 {-# INLINABLE htraverse #-}
177 {-# INLINABLE hdicts #-}
178 {-# INLINABLE hspecs #-}