git.iko.soy/rel8
on 97d89cf help sign in
rel8/src/Rel8/Schema/HTable/Vectorize.hs
144 lines 4.0 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 RankNTypes #-}
14{-# language RecordWildCards #-}
15{-# language ScopedTypeVariables #-}
16{-# language StandaloneKindSignatures #-}
17{-# language TypeApplications #-}
18{-# language TypeFamilies #-}
19{-# language UndecidableInstances #-}
21module Rel8.Schema.HTable.Vectorize
22 ( HVectorize
23 , hvectorize, hunvectorize
24 , happend, hempty
25 )
26where
28-- base
29import Data.Kind ( Type )
30import Data.List.NonEmpty ( NonEmpty )
31import Prelude
33-- rel8
34import Rel8.Schema.Dict ( Dict( Dict ) )
35import qualified Rel8.Schema.Kind as K
36import Rel8.Schema.HTable
37 ( HTable
38 , hfield, htabulate, htabulateA, hspecs
39 )
40import Rel8.Schema.Null ( Unnullify, NotNull, Nullity( NotNull ) )
41import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
42import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )
43import Rel8.Type.Information ( TypeInformation )
45-- semialign
46import Data.Zip ( Unzip, Zip, Zippy(..) )
47import Rel8.FCF
48import Rel8.Schema.HTable.MapTable
49import GHC.Generics (Generic)
52class Vector list where
53 listNotNull :: proxy a -> Dict NotNull (list a)
54 vectorTypeInformation :: ()
55 => Nullity a
56 -> TypeInformation (Unnullify a)
57 -> TypeInformation (list a)
60instance Vector [] where
61 listNotNull _ = Dict
62 vectorTypeInformation = listTypeInformation
65instance Vector NonEmpty where
66 listNotNull _ = Dict
67 vectorTypeInformation = nonEmptyTypeInformation
70type HVectorize :: (Type -> Type) -> K.HTable -> K.HTable
71newtype HVectorize list table context = HVectorize (HMapTable (Vectorize list) table context)
72 deriving stock Generic
73 deriving anyclass HTable
76data Vectorize :: (Type -> Type) -> Spec -> Exp Spec
79type instance Eval (Vectorize list ('Spec a)) = 'Spec (list a)
82instance Vector list => MapSpec (Vectorize list) where
83 mapInfo = \case
84 SSpec {..} -> case listNotNull @list nullity of
85 Dict -> SSpec
86 { nullity = NotNull
87 , info = vectorTypeInformation nullity info
88 , ..
89 }
92hvectorize :: (HTable t, Unzip f, Vector list)
93 => (forall a. ()
94 => SSpec ('Spec a)
95 -> f (context ('Spec a))
96 -> context' ('Spec (list a)))
97 -> f (t context)
98 -> HVectorize list t context'
99hvectorize vectorizer as = HVectorize $ htabulate $ \(HMapTableField field) ->
100 case hfield hspecs field of
101 spec@SSpec {} -> vectorizer spec (fmap (`hfield` field) as)
102{-# INLINABLE hvectorize #-}
105hunvectorize :: (HTable t, Zip f, Vector list)
106 => (forall a. ()
107 => SSpec ('Spec a)
108 -> context ('Spec (list a))
109 -> f (context' ('Spec a)))
110 -> HVectorize list t context
111 -> f (t context')
112hunvectorize unvectorizer (HVectorize table) =
113 getZippy $ htabulateA $ \field -> case hfield hspecs field of
114 spec@SSpec{} -> case hfield table (HMapTableField field) of
115 a -> Zippy (unvectorizer spec a)
116{-# INLINABLE hunvectorize #-}
119happend :: (HTable t, Vector list) =>
120 ( forall a. ()
121 => Nullity a
122 -> TypeInformation (Unnullify a)
123 -> context ('Spec (list a))
124 -> context ('Spec (list a))
125 -> context ('Spec (list a))
126 )
127 -> HVectorize list t context
128 -> HVectorize list t context
129 -> HVectorize list t context
130happend append (HVectorize as) (HVectorize bs) = HVectorize $
131 htabulate $ \field@(HMapTableField j) -> case (hfield as field, hfield bs field) of
132 (a, b) -> case hfield hspecs j of
133 SSpec {nullity, info} -> append nullity info a b
136hempty :: HTable t =>
137 ( forall a. ()
138 => Nullity a
139 -> TypeInformation (Unnullify a)
140 -> context ('Spec [a])
141 )
142 -> HVectorize [] t context
143hempty empty = HVectorize $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of
144 SSpec {nullity, info} -> empty nullity info