git.iko.soy/rel8
on d919181 help sign in
rel8/src/Rel8/Schema/HTable/Vectorize.hs
214 lines 7.1 kB history raw
1{-# language AllowAmbiguousTypes #-}
2{-# language ConstraintKinds #-}
3{-# language DataKinds #-}
4{-# language FlexibleContexts #-}
5{-# language FlexibleInstances #-}
6{-# language GADTs #-}
7{-# language InstanceSigs #-}
8{-# language MultiParamTypeClasses #-}
9{-# language NamedFieldPuns #-}
10{-# language QuantifiedConstraints #-}
11{-# language RankNTypes #-}
12{-# language RecordWildCards #-}
13{-# language ScopedTypeVariables #-}
14{-# language StandaloneKindSignatures #-}
15{-# language TypeApplications #-}
16{-# language TypeFamilies #-}
17{-# language TypeOperators #-}
18{-# language UndecidableInstances #-}
20module Rel8.Schema.HTable.Vectorize
21 ( HVectorize( HVectorize )
22 , hvectorize, hunvectorize
23 , happend, hempty
24 , hrelabel
25 )
26where
28-- base
29import Data.Kind ( Constraint, Type )
30import Data.List.NonEmpty ( NonEmpty )
31import Data.Type.Equality ( (:~:)( Refl ) )
32import Prelude
34-- rel8
35import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
36import Rel8.Schema.Dict ( Dict( Dict ) )
37import Rel8.Schema.HTable
38 ( HTable, HConstrainTable, HField
39 , hfield, htabulate, htabulateA, htraverse, hdicts, hspecs
40 )
41import Rel8.Schema.HTable.Context ( H, HKTable )
42import Rel8.Schema.Nullability ( IsMaybe, Nullability( NonNullable ) )
43import Rel8.Schema.Spec ( Context, Spec( Spec ), SSpec(..) )
44import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )
45import Rel8.Type.Information ( TypeInformation )
47-- semialign
48import Data.Zip ( Unzip, Repeat, Zippy(..) )
51class Vector list where
52 listIsn'tMaybe :: proxy a -> IsMaybe (list a) :~: 'False
53 vectorTypeInformation :: ()
54 => Nullability a ma
55 -> TypeInformation a
56 -> TypeInformation (list ma)
59instance Vector [] where
60 listIsn'tMaybe _ = Refl
61 vectorTypeInformation = listTypeInformation
64instance Vector NonEmpty where
65 listIsn'tMaybe _ = Refl
66 vectorTypeInformation = nonEmptyTypeInformation
69type HVectorize :: (Type -> Type) -> HKTable -> HKTable
70data HVectorize list table context where
71 HVectorize :: table (H (VectorizeSpec list context)) -> HVectorize list table (H context)
74type HVectorizeField :: (Type -> Type) -> HKTable -> Context
75data HVectorizeField list table spec where
76 HVectorizeField
77 :: HField table ('Spec labels necessity db a)
78 -> HVectorizeField list table
79 ('Spec labels necessity (list a) (list a)
80 )
83instance (HTable table, Vector list) => HTable (HVectorize list table) where
85 type HField (HVectorize list table) = HVectorizeField list table
86 type HConstrainTable (HVectorize list table) c =
87 HConstrainTable table (VectorizeSpecC list c)
89 hfield (HVectorize table) (HVectorizeField field) =
90 getVectorizeSpec (hfield table field)
92 htabulate f = HVectorize $ htabulate $ \field -> case hfield hspecs field of
93 SSpec {} -> VectorizeSpec (f (HVectorizeField field))
94 htraverse f (HVectorize t) = HVectorize <$> htraverse (traverseVectorizeSpec f) t
96 hdicts :: forall c. HConstrainTable table (VectorizeSpecC list c) =>
97 HVectorize list table (H (Dict c))
98 hdicts = HVectorize $ htabulate $ \field -> case hfield hspecs field of
99 SSpec {} -> case hfield (hdicts @_ @(VectorizeSpecC list c)) field of
100 Dict -> VectorizeSpec Dict
102 hspecs = HVectorize $ htabulate $ \field -> case hfield hspecs field of
103 SSpec {..} -> case listIsn'tMaybe @list nullability of
104 Refl -> VectorizeSpec SSpec
105 { nullability = NonNullable
106 , info = vectorTypeInformation nullability info
107 , ..
108 }
110 {-# INLINABLE hfield #-}
111 {-# INLINABLE htabulate #-}
112 {-# INLINABLE htraverse #-}
113 {-# INLINABLE hdicts #-}
114 {-# INLINABLE hspecs #-}
117type VectorizingSpec :: Type -> Type
118type VectorizingSpec r = (Type -> Type) -> (Spec -> r) -> Spec -> r
121type VectorizeSpec :: VectorizingSpec Type
122data VectorizeSpec list context spec where
123 VectorizeSpec ::
124 { getVectorizeSpec :: context ('Spec labels necessity (list a) (list a))
125 } -> VectorizeSpec list context ('Spec labels necessity db a)
128instance Labelable context => Labelable (VectorizeSpec list context) where
129 labeler (VectorizeSpec a) = VectorizeSpec (labeler a)
130 unlabeler (VectorizeSpec a) = VectorizeSpec (unlabeler a)
133type VectorizeSpecC :: VectorizingSpec Constraint
134class
135 ( forall labels necessity db a.
136 ( spec ~ 'Spec labels necessity db a
137 => constraint ('Spec labels necessity (list a) (list a))
138 )
139 )
140 => VectorizeSpecC list constraint spec
141instance
142 ( spec ~ 'Spec labels necessity db a
143 , constraint ('Spec labels necessity (list a) (list a))
144 )
145 => VectorizeSpecC list constraint spec
148traverseVectorizeSpec :: forall context context' list spec m. Functor m
149 => (forall x. context x -> m (context' x))
150 -> VectorizeSpec list context spec
151 -> m (VectorizeSpec list context' spec)
152traverseVectorizeSpec f (VectorizeSpec a) = VectorizeSpec <$> f a
155hvectorize :: (HTable t, Unzip f)
156 => (forall labels necessity db a. ()
157 => SSpec ('Spec labels necessity db a)
158 -> f (context ('Spec labels necessity db a))
159 -> context' ('Spec labels necessity (list a) (list a)))
160 -> f (t (H context))
161 -> HVectorize list t (H context')
162hvectorize vectorizer as = HVectorize $ htabulate $ \field ->
163 case hfield hspecs field of
164 spec@SSpec {} -> VectorizeSpec (vectorizer spec (fmap (`hfield` field) as))
165{-# INLINABLE hvectorize #-}
168hunvectorize :: (HTable t, Repeat f)
169 => (forall labels necessity db a. ()
170 => SSpec ('Spec labels necessity db a)
171 -> context ('Spec labels necessity (list a) (list a))
172 -> f (context' ('Spec labels necessity db a)))
173 -> HVectorize list t (H context)
174 -> f (t (H context'))
175hunvectorize unvectorizer (HVectorize table) =
176 getZippy $ htabulateA $ \field -> case hfield hspecs field of
177 spec -> case hfield table field of
178 VectorizeSpec a -> Zippy (unvectorizer spec a)
179{-# INLINABLE hunvectorize #-}
182happend :: HTable t =>
183 ( forall labels necessity db a. ()
184 => Nullability db a
185 -> TypeInformation db
186 -> context ('Spec labels necessity (list a) (list a))
187 -> context ('Spec labels necessity (list a) (list a))
188 -> context ('Spec labels necessity (list a) (list a))
189 )
190 -> HVectorize list t (H context)
191 -> HVectorize list t (H context)
192 -> HVectorize list t (H context)
193happend append (HVectorize as) (HVectorize bs) = HVectorize $
194 htabulate $ \field -> case (hfield as field, hfield bs field) of
195 (VectorizeSpec a, VectorizeSpec b) -> case hfield hspecs field of
196 SSpec {nullability, info} -> VectorizeSpec $ append nullability info a b
199hempty :: HTable t =>
200 ( forall labels necessity db a. ()
201 => Nullability db a
202 -> TypeInformation db
203 -> context ('Spec labels necessity [a] [a])
204 )
205 -> HVectorize [] t (H context)
206hempty empty = HVectorize $ htabulate $ \field -> case hfield hspecs field of
207 SSpec {nullability, info} -> VectorizeSpec (empty nullability info)
210hrelabel :: Labelable context
211 => (forall ctx. Labelable ctx => t (H ctx) -> u (H ctx))
212 -> HVectorize list t (H context)
213 -> HVectorize list u (H context)
214hrelabel f (HVectorize table) = HVectorize (f table)