git.iko.soy/rel8
on bdb75e6 help sign in
rel8/src/Rel8/Schema/HTable/Vectorize.hs
153 lines 4.7 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 )
27where
29-- base
30import Data.Kind ( Type )
31import Data.List.NonEmpty ( NonEmpty )
32import Prelude
34-- rel8
35import Rel8.Kind.Necessity ( Necessity( Required ), SNecessity( SRequired ) )
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 'Required (list a)
85instance Vector list => MapSpec (Vectorize list) where
86 mapInfo = \case
87 SSpec {..} -> case listNotNull @list nullity of
88 Dict -> SSpec
89 { necessity = SRequired
90 , nullity = NotNull
91 , info = vectorTypeInformation nullity info
92 , ..
93 }
96hvectorize :: (HTable t, Unzip f, Vector list)
97 => (forall labels necessity a. ()
98 => SSpec ('Spec labels necessity a)
99 -> f (context ('Spec labels necessity a))
100 -> context' ('Spec labels 'Required (list a)))
101 -> f (t context)
102 -> HVectorize list t context'
103hvectorize vectorizer as = HVectorize $ htabulate $ \(HMapTableField field) ->
104 case hfield hspecs field of
105 spec@SSpec {} -> vectorizer spec (fmap (`hfield` field) as)
106{-# INLINABLE hvectorize #-}
109hunvectorize :: (HTable t, Repeat f, Vector list)
110 => (forall labels necessity a. ()
111 => SSpec ('Spec labels necessity a)
112 -> context ('Spec labels 'Required (list a))
113 -> f (context' ('Spec labels necessity a)))
114 -> HVectorize list t context
115 -> f (t context')
116hunvectorize unvectorizer (HVectorize table) =
117 getZippy $ htabulateA $ \field -> case hfield hspecs field of
118 spec@SSpec{} -> case hfield table (HMapTableField field) of
119 a -> Zippy (unvectorizer spec a)
120{-# INLINABLE hunvectorize #-}
123happend :: (HTable t, Vector list) =>
124 ( forall labels necessity a. ()
125 => Nullity a
126 -> TypeInformation (Unnullify a)
127 -> context ('Spec labels necessity (list a))
128 -> context ('Spec labels necessity (list a))
129 -> context ('Spec labels necessity (list a))
130 )
131 -> HVectorize list t context
132 -> HVectorize list t context
133 -> HVectorize list t context
134happend append (HVectorize as) (HVectorize bs) = HVectorize $
135 htabulate $ \field@(HMapTableField j) -> case (hfield as field, hfield bs field) of
136 (a, b) -> case hfield hspecs j of
137 SSpec {nullity, info} -> append nullity info a b
140hempty :: HTable t =>
141 ( forall labels necessity a. ()
142 => Nullity a
143 -> TypeInformation (Unnullify a)
144 -> context ('Spec labels necessity [a])
145 )
146 -> HVectorize [] t context
147hempty empty = HVectorize $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of
148 SSpec {nullity, info} -> empty nullity info
151instance HLabelable g => HLabelable (Precompose (Vectorize list) g) where
152 hlabeler = Precompose . hlabeler . precomposed
153 hunlabeler = Precompose . hunlabeler . precomposed