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