git.iko.soy/rel8
on fadfc3e help sign in
rel8/src/Rel8/Schema/HTable.hs
173 lines 5.5 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, Context )
40import Rel8.Schema.HTable.Context ( HKTable, H )
41import Rel8.Schema.HTable.Pair ( HPair( HPair ) )
43-- semigroupoids
44import Data.Functor.Apply ( Apply, (<.>) )
47type HTable :: HKTable -> Constraint
48class HTable t where
49 type HField t = (field :: Context) | field -> t
50 type HConstrainTable t (c :: Spec -> Constraint) :: Constraint
52 hfield :: t (H context) -> HField t spec -> context spec
53 htabulate :: (forall spec. HField t spec -> context spec) -> t (H context)
54 htraverse :: Apply m => (forall spec. f spec -> m (g spec)) -> t (H f) -> m (t (H g))
55 hdicts :: HConstrainTable t c => t (H (Dict c))
56 hspecs :: t (H SSpec)
58 type HField t = GHField t
59 type HConstrainTable t c = HConstrainTable (GHColumns (Rep (t (H Proxy)))) c
61 default hfield ::
62 ( Generic (t (H context))
63 , HField t ~ GHField t
64 , HField (GHColumns (Rep (t (H Proxy)))) ~ HField (GHColumns (Rep (t (H context))))
65 , GHTable context (Rep (t (H context)))
66 )
67 => t (H context) -> HField t spec -> context spec
68 hfield table (GHField field) = hfield (toGHColumns (from table)) field
70 default htabulate ::
71 ( Generic (t (H context))
72 , HField t ~ GHField t
73 , HField (GHColumns (Rep (t (H Proxy)))) ~ HField (GHColumns (Rep (t (H context))))
74 , GHTable context (Rep (t (H context)))
75 )
76 => (forall spec. HField t spec -> context spec) -> t (H context)
77 htabulate f = to $ fromGHColumns $ htabulate (f . GHField)
79 default htraverse
80 :: forall f g m
81 . ( Apply m
82 , Generic (t (H f)), GHTable f (Rep (t (H f)))
83 , Generic (t (H g)), GHTable g (Rep (t (H g)))
84 , GHColumns (Rep (t (H f))) ~ GHColumns (Rep (t (H g)))
85 )
86 => (forall spec. f spec -> m (g spec)) -> t (H f) -> m (t (H g))
87 htraverse f = fmap (to . fromGHColumns) . htraverse f . toGHColumns . from
89 default hdicts
90 :: forall c
91 . ( Generic (t (H (Dict c)))
92 , GHTable (Dict c) (Rep (t (H (Dict c))))
93 , GHColumns (Rep (t (H Proxy))) ~ GHColumns (Rep (t (H (Dict c))))
94 , HConstrainTable (GHColumns (Rep (t (H Proxy)))) c
95 )
96 => t (H (Dict c))
97 hdicts = to $ fromGHColumns (hdicts @(GHColumns (Rep (t (H Proxy)))) @c)
99 default hspecs ::
100 ( Generic (t (H SSpec))
101 , GHTable SSpec (Rep (t (H SSpec)))
102 )
103 => t (H SSpec)
104 hspecs = to $ fromGHColumns hspecs
106 {-# INLINABLE hfield #-}
107 {-# INLINABLE htabulate #-}
108 {-# INLINABLE htraverse #-}
109 {-# INLINABLE hdicts #-}
110 {-# INLINABLE hspecs #-}
113htabulateA :: (HTable t, Apply m)
114 => (forall spec. HField t spec -> m (context spec))
115 -> m (t (H context))
116htabulateA f = htraverse getCompose $ htabulate $ Compose . f
117{-# INLINABLE htabulateA #-}
120type GHField :: HKTable -> Context
121newtype GHField t spec = GHField (HField (GHColumns (Rep (t (H Proxy)))) spec)
124type GHTable :: Context -> (Type -> Type) -> Constraint
125class HTable (GHColumns rep) => GHTable context rep | rep -> context where
126 type GHColumns rep :: HKTable
127 toGHColumns :: rep x -> GHColumns rep (H context)
128 fromGHColumns :: GHColumns rep (H context) -> rep x
131instance GHTable context rep => GHTable context (M1 i c rep) where
132 type GHColumns (M1 i c rep) = GHColumns rep
133 toGHColumns (M1 a) = toGHColumns a
134 fromGHColumns = M1 . fromGHColumns
137instance HTable table => GHTable context (K1 i (table (H context))) where
138 type GHColumns (K1 i (table (H context))) = table
139 toGHColumns (K1 a) = a
140 fromGHColumns = K1
143instance (GHTable context a, GHTable context b) => GHTable context (a :*: b) where
144 type GHColumns (a :*: b) = HPair (GHColumns a) (GHColumns b)
145 toGHColumns (a :*: b) = HPair (toGHColumns a) (toGHColumns b)
146 fromGHColumns (HPair a b) = fromGHColumns a :*: fromGHColumns b
149-- | A HField type for indexing into HPair.
150type HPairField :: HKTable -> HKTable -> Context
151data HPairField x y spec
152 = HFst (HField x spec)
153 | HSnd (HField y spec)
156instance (HTable x, HTable y) => HTable (HPair x y) where
157 type HConstrainTable (HPair x y) c = (HConstrainTable x c, HConstrainTable y c)
158 type HField (HPair x y) = HPairField x y
160 hfield (HPair l r) = \case
161 HFst i -> hfield l i
162 HSnd i -> hfield r i
164 htabulate f = HPair (htabulate (f . HFst)) (htabulate (f . HSnd))
165 htraverse f (HPair x y) = HPair <$> htraverse f x <.> htraverse f y
166 hdicts = HPair hdicts hdicts
167 hspecs = HPair hspecs hspecs
169 {-# INLINABLE hfield #-}
170 {-# INLINABLE htabulate #-}
171 {-# INLINABLE htraverse #-}
172 {-# INLINABLE hdicts #-}
173 {-# INLINABLE hspecs #-}