git.iko.soy/rel8
on 93168af help sign in
rel8/src/Rel8/Schema/HTable/Vectorize.hs
220 lines 7.3 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.Kind.Bool ( IsList, SBool( STrue ) )
36import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
37import Rel8.Schema.Dict ( Dict( Dict ) )
38import Rel8.Schema.HTable
39 ( HTable, HConstrainTable, HField
40 , hfield, htabulate, htabulateA, htraverse, hdicts, hspecs
41 )
42import Rel8.Schema.HTable.Context ( H, HKTable )
43import Rel8.Schema.Nullability ( IsMaybe, Nullability( NonNullable ) )
44import Rel8.Schema.Spec ( Context, Spec( Spec ), SSpec(..) )
45import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )
46import Rel8.Type.Information ( TypeInformation )
48-- semialign
49import Data.Zip ( Unzip, Repeat, Zippy(..) )
52class Vector list where
53 listIsList :: proxy a -> IsList (list a) :~: 'True
54 listIsn'tMaybe :: proxy a -> IsMaybe (list a) :~: 'False
55 vectorTypeInformation :: ()
56 => Nullability a ma
57 -> TypeInformation a
58 -> TypeInformation (list ma)
61instance Vector [] where
62 listIsList _ = Refl
63 listIsn'tMaybe _ = Refl
64 vectorTypeInformation = listTypeInformation
67instance Vector NonEmpty where
68 listIsList _ = Refl
69 listIsn'tMaybe _ = Refl
70 vectorTypeInformation = nonEmptyTypeInformation
73type HVectorize :: (Type -> Type) -> HKTable -> HKTable
74data HVectorize list table context where
75 HVectorize :: table (H (VectorizeSpec list context)) -> HVectorize list table (H context)
78type HVectorizeField :: (Type -> Type) -> HKTable -> Context
79data HVectorizeField list table spec where
80 HVectorizeField
81 :: HField table ('Spec labels necessity db a)
82 -> HVectorizeField list table
83 ('Spec labels necessity (list a) (list a)
84 )
87instance (HTable table, Vector list) => HTable (HVectorize list table) where
89 type HField (HVectorize list table) = HVectorizeField list table
90 type HConstrainTable (HVectorize list table) c =
91 HConstrainTable table (VectorizeSpecC list c)
93 hfield (HVectorize table) (HVectorizeField field) =
94 getVectorizeSpec (hfield table field)
96 htabulate f = HVectorize $ htabulate $ \field -> case hfield hspecs field of
97 SSpec {} -> VectorizeSpec (f (HVectorizeField field))
98 htraverse f (HVectorize t) = HVectorize <$> htraverse (traverseVectorizeSpec f) t
100 hdicts :: forall c. HConstrainTable table (VectorizeSpecC list c) =>
101 HVectorize list table (H (Dict c))
102 hdicts = HVectorize $ htabulate $ \field -> case hfield hspecs field of
103 SSpec {} -> case hfield (hdicts @_ @(VectorizeSpecC list c)) field of
104 Dict -> VectorizeSpec Dict
106 hspecs = HVectorize $ htabulate $ \field -> case hfield hspecs field of
107 SSpec {..} -> case listIsList @list nullability of
108 Refl -> case listIsn'tMaybe @list nullability of
109 Refl -> VectorizeSpec SSpec
110 { nullability = NonNullable
111 , info = vectorTypeInformation nullability info
112 , isList = STrue
113 , ..
114 }
116 {-# INLINABLE hfield #-}
117 {-# INLINABLE htabulate #-}
118 {-# INLINABLE htraverse #-}
119 {-# INLINABLE hdicts #-}
120 {-# INLINABLE hspecs #-}
123type VectorizingSpec :: Type -> Type
124type VectorizingSpec r = (Type -> Type) -> (Spec -> r) -> Spec -> r
127type VectorizeSpec :: VectorizingSpec Type
128data VectorizeSpec list context spec where
129 VectorizeSpec ::
130 { getVectorizeSpec :: context ('Spec labels necessity (list a) (list a))
131 } -> VectorizeSpec list context ('Spec labels necessity db a)
134instance Labelable context => Labelable (VectorizeSpec list context) where
135 labeler (VectorizeSpec a) = VectorizeSpec (labeler a)
136 unlabeler (VectorizeSpec a) = VectorizeSpec (unlabeler a)
139type VectorizeSpecC :: VectorizingSpec Constraint
140class
141 ( forall labels necessity db a.
142 ( spec ~ 'Spec labels necessity db a
143 => constraint ('Spec labels necessity (list a) (list a))
144 )
145 )
146 => VectorizeSpecC list constraint spec
147instance
148 ( spec ~ 'Spec labels necessity db a
149 , constraint ('Spec labels necessity (list a) (list a))
150 )
151 => VectorizeSpecC list constraint spec
154traverseVectorizeSpec :: forall context context' list spec m. Functor m
155 => (forall x. context x -> m (context' x))
156 -> VectorizeSpec list context spec
157 -> m (VectorizeSpec list context' spec)
158traverseVectorizeSpec f (VectorizeSpec a) = VectorizeSpec <$> f a
161hvectorize :: (HTable t, Unzip f)
162 => (forall labels necessity db a. ()
163 => SSpec ('Spec labels necessity db a)
164 -> f (context ('Spec labels necessity db a))
165 -> context' ('Spec labels necessity (list a) (list a)))
166 -> f (t (H context))
167 -> HVectorize list t (H context')
168hvectorize vectorizer as = HVectorize $ htabulate $ \field ->
169 case hfield hspecs field of
170 spec@SSpec {} -> VectorizeSpec (vectorizer spec (fmap (`hfield` field) as))
171{-# INLINABLE hvectorize #-}
174hunvectorize :: (HTable t, Repeat f)
175 => (forall labels necessity db a. ()
176 => SSpec ('Spec labels necessity db a)
177 -> context ('Spec labels necessity (list a) (list a))
178 -> f (context' ('Spec labels necessity db a)))
179 -> HVectorize list t (H context)
180 -> f (t (H context'))
181hunvectorize unvectorizer (HVectorize table) =
182 getZippy $ htabulateA $ \field -> case hfield hspecs field of
183 spec -> case hfield table field of
184 VectorizeSpec a -> Zippy (unvectorizer spec a)
185{-# INLINABLE hunvectorize #-}
188happend :: HTable t =>
189 ( forall labels necessity db a. ()
190 => Nullability db a
191 -> TypeInformation db
192 -> context ('Spec labels necessity (list a) (list a))
193 -> context ('Spec labels necessity (list a) (list a))
194 -> context ('Spec labels necessity (list a) (list a))
195 )
196 -> HVectorize list t (H context)
197 -> HVectorize list t (H context)
198 -> HVectorize list t (H context)
199happend append (HVectorize as) (HVectorize bs) = HVectorize $
200 htabulate $ \field -> case (hfield as field, hfield bs field) of
201 (VectorizeSpec a, VectorizeSpec b) -> case hfield hspecs field of
202 SSpec {nullability, info} -> VectorizeSpec $ append nullability info a b
205hempty :: HTable t =>
206 ( forall labels necessity db a. ()
207 => Nullability db a
208 -> TypeInformation db
209 -> context ('Spec labels necessity [a] [a])
210 )
211 -> HVectorize [] t (H context)
212hempty empty = HVectorize $ htabulate $ \field -> case hfield hspecs field of
213 SSpec {nullability, info} -> VectorizeSpec (empty nullability info)
216hrelabel :: Labelable context
217 => (forall ctx. Labelable ctx => t (H ctx) -> u (H ctx))
218 -> HVectorize list t (H context)
219 -> HVectorize list u (H context)
220hrelabel f (HVectorize table) = HVectorize (f table)