git.iko.soy/rel8
on 00a36f5 help sign in
rel8/src/Rel8/Schema/HTable/Vectorize.hs
213 lines 7.0 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 ( HLabelable, hlabeler, hunlabeler )
36import Rel8.Schema.Dict ( Dict( Dict ) )
37import qualified Rel8.Schema.Kind as K
38import Rel8.Schema.HTable
39 ( HTable, HConstrainTable, HField
40 , hfield, htabulate, htabulateA, htraverse, hdicts, hspecs
41 )
42import Rel8.Schema.Nullability ( IsMaybe, Nullability( NonNullable ) )
43import Rel8.Schema.Spec ( 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) -> K.HTable -> K.HTable
70newtype HVectorize list table context =
71 HVectorize (table (VectorizeSpec list context))
74type HVectorizeField :: (Type -> Type) -> K.HTable -> Spec -> Type
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
84 type HField (HVectorize list table) = HVectorizeField list table
85 type HConstrainTable (HVectorize list table) c =
86 HConstrainTable table (VectorizeSpecC list c)
88 hfield (HVectorize table) (HVectorizeField field) =
89 getVectorizeSpec (hfield table field)
91 htabulate f = HVectorize $ htabulate $ \field -> case hfield hspecs field of
92 SSpec {} -> VectorizeSpec (f (HVectorizeField field))
93 htraverse f (HVectorize t) = HVectorize <$> htraverse (traverseVectorizeSpec f) t
95 hdicts :: forall c. HConstrainTable table (VectorizeSpecC list c) =>
96 HVectorize list table (Dict c)
97 hdicts = HVectorize $ htabulate $ \field -> case hfield hspecs field of
98 SSpec {} -> case hfield (hdicts @_ @(VectorizeSpecC list c)) field of
99 Dict -> VectorizeSpec Dict
101 hspecs = HVectorize $ htabulate $ \field -> case hfield hspecs field of
102 SSpec {..} -> case listIsn'tMaybe @list nullability of
103 Refl -> VectorizeSpec SSpec
104 { nullability = NonNullable
105 , info = vectorTypeInformation nullability info
106 , ..
107 }
109 {-# INLINABLE hfield #-}
110 {-# INLINABLE htabulate #-}
111 {-# INLINABLE htraverse #-}
112 {-# INLINABLE hdicts #-}
113 {-# INLINABLE hspecs #-}
116type VectorizingSpec :: Type -> Type
117type VectorizingSpec r = (Type -> Type) -> (Spec -> r) -> Spec -> r
120type VectorizeSpec :: VectorizingSpec Type
121data VectorizeSpec list context spec where
122 VectorizeSpec ::
123 { getVectorizeSpec :: context ('Spec labels necessity (list a) (list a))
124 } -> VectorizeSpec list context ('Spec labels necessity db a)
127instance HLabelable context => HLabelable (VectorizeSpec list context) where
128 hlabeler (VectorizeSpec a) = VectorizeSpec (hlabeler a)
129 hunlabeler (VectorizeSpec a) = VectorizeSpec (hunlabeler a)
132type VectorizeSpecC :: VectorizingSpec Constraint
133class
134 ( forall labels necessity db a.
135 ( spec ~ 'Spec labels necessity db a
136 => constraint ('Spec labels necessity (list a) (list a))
137 )
138 )
139 => VectorizeSpecC list constraint spec
140instance
141 ( spec ~ 'Spec labels necessity db a
142 , constraint ('Spec labels necessity (list a) (list a))
143 )
144 => VectorizeSpecC list constraint spec
147traverseVectorizeSpec :: forall context context' list spec m. Functor m
148 => (forall x. context x -> m (context' x))
149 -> VectorizeSpec list context spec
150 -> m (VectorizeSpec list context' spec)
151traverseVectorizeSpec f (VectorizeSpec a) = VectorizeSpec <$> f a
154hvectorize :: (HTable t, Unzip f)
155 => (forall labels necessity db a. ()
156 => SSpec ('Spec labels necessity db a)
157 -> f (context ('Spec labels necessity db a))
158 -> context' ('Spec labels necessity (list a) (list a)))
159 -> f (t context)
160 -> HVectorize list t context'
161hvectorize vectorizer as = HVectorize $ htabulate $ \field ->
162 case hfield hspecs field of
163 spec@SSpec {} -> VectorizeSpec (vectorizer spec (fmap (`hfield` field) as))
164{-# INLINABLE hvectorize #-}
167hunvectorize :: (HTable t, Repeat f)
168 => (forall labels necessity db a. ()
169 => SSpec ('Spec labels necessity db a)
170 -> context ('Spec labels necessity (list a) (list a))
171 -> f (context' ('Spec labels necessity db a)))
172 -> HVectorize list t context
173 -> f (t context')
174hunvectorize unvectorizer (HVectorize table) =
175 getZippy $ htabulateA $ \field -> case hfield hspecs field of
176 spec -> case hfield table field of
177 VectorizeSpec a -> Zippy (unvectorizer spec a)
178{-# INLINABLE hunvectorize #-}
181happend :: HTable t =>
182 ( forall labels necessity db a. ()
183 => Nullability db a
184 -> TypeInformation db
185 -> context ('Spec labels necessity (list a) (list a))
186 -> context ('Spec labels necessity (list a) (list a))
187 -> context ('Spec labels necessity (list a) (list a))
188 )
189 -> HVectorize list t context
190 -> HVectorize list t context
191 -> HVectorize list t context
192happend append (HVectorize as) (HVectorize bs) = HVectorize $
193 htabulate $ \field -> case (hfield as field, hfield bs field) of
194 (VectorizeSpec a, VectorizeSpec b) -> case hfield hspecs field of
195 SSpec {nullability, info} -> VectorizeSpec $ append nullability info a b
198hempty :: HTable t =>
199 ( forall labels necessity db a. ()
200 => Nullability db a
201 -> TypeInformation db
202 -> context ('Spec labels necessity [a] [a])
203 )
204 -> HVectorize [] t context
205hempty empty = HVectorize $ htabulate $ \field -> case hfield hspecs field of
206 SSpec {nullability, info} -> VectorizeSpec (empty nullability info)
209hrelabel :: HLabelable context
210 => (forall ctx. HLabelable ctx => t ctx -> u ctx)
211 -> HVectorize list t context
212 -> HVectorize list u context
213hrelabel f (HVectorize table) = HVectorize (f table)