git.iko.soy/rel8
on 137ebed help sign in
rel8/src/Rel8/Schema/HTable/Vectorize.hs
151 lines 4.4 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.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
40 , hfield, htabulate, htabulateA, hspecs
41 )
42import Rel8.Schema.Null ( Unnullify, NotNull, Nullity( NotNull ) )
43import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
44import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )
45import Rel8.Type.Information ( TypeInformation )
47-- semialign
48import Data.Zip ( Unzip, Zip, Zippy(..) )
49import Rel8.FCF
50import Rel8.Schema.HTable.MapTable
51import GHC.Generics (Generic)
54class Vector list where
55 listNotNull :: proxy a -> Dict NotNull (list a)
56 vectorTypeInformation :: ()
57 => Nullity a
58 -> TypeInformation (Unnullify a)
59 -> TypeInformation (list a)
62instance Vector [] where
63 listNotNull _ = Dict
64 vectorTypeInformation = listTypeInformation
67instance Vector NonEmpty where
68 listNotNull _ = Dict
69 vectorTypeInformation = nonEmptyTypeInformation
72type HVectorize :: (Type -> Type) -> K.HTable -> K.HTable
73newtype HVectorize list table context = HVectorize (HMapTable (Vectorize list) table context)
74 deriving stock Generic
75 deriving anyclass HTable
78data Vectorize :: (Type -> Type) -> Spec -> Exp Spec
81type instance Eval (Vectorize list ('Spec labels a)) = 'Spec labels (list a)
84instance Vector list => MapSpec (Vectorize list) where
85 mapInfo = \case
86 SSpec {..} -> case listNotNull @list nullity of
87 Dict -> SSpec
88 { nullity = NotNull
89 , info = vectorTypeInformation nullity info
90 , ..
91 }
94hvectorize :: (HTable t, Unzip f, Vector list)
95 => (forall labels a. ()
96 => SSpec ('Spec labels a)
97 -> f (context ('Spec labels a))
98 -> context' ('Spec labels (list a)))
99 -> f (t context)
100 -> HVectorize list t context'
101hvectorize vectorizer as = HVectorize $ htabulate $ \(HMapTableField field) ->
102 case hfield hspecs field of
103 spec@SSpec {} -> vectorizer spec (fmap (`hfield` field) as)
104{-# INLINABLE hvectorize #-}
107hunvectorize :: (HTable t, Zip f, Vector list)
108 => (forall labels a. ()
109 => SSpec ('Spec labels a)
110 -> context ('Spec labels (list a))
111 -> f (context' ('Spec labels a)))
112 -> HVectorize list t context
113 -> f (t context')
114hunvectorize unvectorizer (HVectorize table) =
115 getZippy $ htabulateA $ \field -> case hfield hspecs field of
116 spec@SSpec{} -> case hfield table (HMapTableField field) of
117 a -> Zippy (unvectorizer spec a)
118{-# INLINABLE hunvectorize #-}
121happend :: (HTable t, Vector list) =>
122 ( forall labels a. ()
123 => Nullity a
124 -> TypeInformation (Unnullify a)
125 -> context ('Spec labels (list a))
126 -> context ('Spec labels (list a))
127 -> context ('Spec labels (list a))
128 )
129 -> HVectorize list t context
130 -> HVectorize list t context
131 -> HVectorize list t context
132happend append (HVectorize as) (HVectorize bs) = HVectorize $
133 htabulate $ \field@(HMapTableField j) -> case (hfield as field, hfield bs field) of
134 (a, b) -> case hfield hspecs j of
135 SSpec {nullity, info} -> append nullity info a b
138hempty :: HTable t =>
139 ( forall labels a. ()
140 => Nullity a
141 -> TypeInformation (Unnullify a)
142 -> context ('Spec labels [a])
143 )
144 -> HVectorize [] t context
145hempty empty = HVectorize $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of
146 SSpec {nullity, info} -> empty nullity info
149instance HLabelable g => HLabelable (Precompose (Vectorize list) g) where
150 hlabeler = Precompose . hlabeler . precomposed
151 hunlabeler = Precompose . hunlabeler . precomposed