git.iko.soy/rel8
on 4e90af3 help sign in
rel8/src/Rel8/Schema/HTable/Vectorize.hs
159 lines 4.8 kB history raw
1{-# language AllowAmbiguousTypes #-}
2{-# language ConstraintKinds #-}
3{-# language DataKinds #-}
4{-# language DeriveAnyClass #-}
5{-# language DeriveGeneric #-}
6{-# language DerivingStrategies #-}
7{-# language FlexibleContexts #-}
8{-# language FlexibleInstances #-}
9{-# language GADTs #-}
10{-# language LambdaCase #-}
11{-# language MultiParamTypeClasses #-}
12{-# language NamedFieldPuns #-}
13{-# language QuantifiedConstraints #-}
14{-# language RankNTypes #-}
15{-# language RecordWildCards #-}
16{-# language ScopedTypeVariables #-}
17{-# language StandaloneKindSignatures #-}
18{-# language TypeApplications #-}
19{-# language TypeFamilies #-}
20{-# language UndecidableInstances #-}
22module Rel8.Schema.HTable.Vectorize
23 ( HVectorize
24 , hvectorize, hunvectorize
25 , happend, hempty
26 , hrelabel
27 )
28where
30-- base
31import Data.Kind ( Type )
32import Data.List.NonEmpty ( NonEmpty )
33import Prelude
35-- rel8
36import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler )
37import Rel8.Schema.Dict ( Dict( Dict ) )
38import qualified Rel8.Schema.Kind as K
39import Rel8.Schema.HTable
40 ( HTable
41 , hfield, htabulate, htabulateA, hspecs
42 )
43import Rel8.Schema.Null ( Unnullify, NotNull, Nullity( NotNull ) )
44import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
45import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )
46import Rel8.Type.Information ( TypeInformation )
48-- semialign
49import Data.Zip ( Unzip, Repeat, Zippy(..) )
50import Rel8.FCF
51import Rel8.Schema.HTable.MapTable
52import GHC.Generics (Generic)
55class Vector list where
56 listNotNull :: proxy a -> Dict NotNull (list a)
57 vectorTypeInformation :: ()
58 => Nullity a
59 -> TypeInformation (Unnullify a)
60 -> TypeInformation (list a)
63instance Vector [] where
64 listNotNull _ = Dict
65 vectorTypeInformation = listTypeInformation
68instance Vector NonEmpty where
69 listNotNull _ = Dict
70 vectorTypeInformation = nonEmptyTypeInformation
73type HVectorize :: (Type -> Type) -> K.HTable -> K.HTable
74newtype HVectorize list table context = HVectorize (HMapTable (Vectorize list) table context)
75 deriving stock Generic
76 deriving anyclass HTable
79data Vectorize :: (Type -> Type) -> Spec -> Exp Spec
82type instance Eval (Vectorize list ('Spec labels necessity a)) = 'Spec labels necessity (list a)
85instance Vector list => MapSpec (Vectorize list) where
86 mapInfo = \case
87 SSpec {..} -> case listNotNull @list nullity of
88 Dict -> SSpec
89 { nullity = NotNull
90 , info = vectorTypeInformation nullity info
91 , ..
92 }
95hvectorize :: (HTable t, Unzip f, Vector list)
96 => (forall labels necessity a. ()
97 => SSpec ('Spec labels necessity a)
98 -> f (context ('Spec labels necessity a))
99 -> context' ('Spec labels necessity (list a)))
100 -> f (t context)
101 -> HVectorize list t context'
102hvectorize vectorizer as = HVectorize $ htabulate $ \(HMapTableField field) ->
103 case hfield hspecs field of
104 spec@SSpec {} -> vectorizer spec (fmap (`hfield` field) as)
105{-# INLINABLE hvectorize #-}
108hunvectorize :: (HTable t, Repeat f, Vector list)
109 => (forall labels necessity a. ()
110 => SSpec ('Spec labels necessity a)
111 -> context ('Spec labels necessity (list a))
112 -> f (context' ('Spec labels necessity a)))
113 -> HVectorize list t context
114 -> f (t context')
115hunvectorize unvectorizer (HVectorize table) =
116 getZippy $ htabulateA $ \field -> case hfield hspecs field of
117 spec@SSpec{} -> case hfield table (HMapTableField field) of
118 a -> Zippy (unvectorizer spec a)
119{-# INLINABLE hunvectorize #-}
122happend :: (HTable t, Vector list) =>
123 ( forall labels necessity a. ()
124 => Nullity a
125 -> TypeInformation (Unnullify a)
126 -> context ('Spec labels necessity (list a))
127 -> context ('Spec labels necessity (list a))
128 -> context ('Spec labels necessity (list a))
129 )
130 -> HVectorize list t context
131 -> HVectorize list t context
132 -> HVectorize list t context
133happend append (HVectorize as) (HVectorize bs) = HVectorize $
134 htabulate $ \field@(HMapTableField j) -> case (hfield as field, hfield bs field) of
135 (a, b) -> case hfield hspecs j of
136 SSpec {nullity, info} -> append nullity info a b
139hempty :: HTable t =>
140 ( forall labels necessity a. ()
141 => Nullity a
142 -> TypeInformation (Unnullify a)
143 -> context ('Spec labels necessity [a])
144 )
145 -> HVectorize [] t context
146hempty empty = HVectorize $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of
147 SSpec {nullity, info} -> empty nullity info
150instance HLabelable g => HLabelable (Precompose (Vectorize list) g) where
151 hlabeler = Precompose . hlabeler . precomposed
152 hunlabeler = Precompose . hunlabeler . precomposed
155hrelabel :: HLabelable context
156 => (forall ctx. HLabelable ctx => t ctx -> u ctx)
157 -> HVectorize list t context
158 -> HVectorize list u context
159hrelabel f (HVectorize (HMapTable table)) = HVectorize (HMapTable (f table))