git.iko.soy/rel8
on 8de0eec help sign in
rel8/src/Rel8/Schema/HTable/Vectorize.hs
135 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 RankNTypes #-}
13{-# language RecordWildCards #-}
14{-# language ScopedTypeVariables #-}
15{-# language StandaloneKindSignatures #-}
16{-# language TypeApplications #-}
17{-# language TypeFamilies #-}
18{-# language UndecidableInstances #-}
20module Rel8.Schema.HTable.Vectorize
21 ( HVectorize
22 , hvectorize, hunvectorize
23 , happend, hempty
24 , hproject
25 )
26where
28-- base
29import Data.Kind ( Type )
30import Data.List.NonEmpty ( NonEmpty )
31import GHC.Generics (Generic)
32import Prelude
34-- rel8
35import Rel8.FCF ( Eval, Exp )
36import Rel8.Schema.Dict ( Dict( Dict ) )
37import qualified Rel8.Schema.Kind as K
38import Rel8.Schema.HTable ( HTable, hfield, htabulate, htabulateA, hspecs )
39import Rel8.Schema.HTable.MapTable
40 ( HMapTable, HMapTableField( HMapTableField )
41 , MapSpec, mapInfo
42 )
43import qualified Rel8.Schema.HTable.MapTable as HMapTable ( hproject )
44import Rel8.Schema.Null ( Unnullify, NotNull, Nullity( NotNull ) )
45import Rel8.Schema.Spec ( Spec(..) )
46import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )
47import Rel8.Type.Information ( TypeInformation )
49-- semialign
50import Data.Zip ( Unzip, Zip, Zippy(..) )
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) -> Type -> Exp Type
80type instance Eval (Vectorize list a) = list a
83instance Vector list => MapSpec (Vectorize list) where
84 mapInfo = \case
85 Spec {..} -> case listNotNull @list nullity of
86 Dict -> Spec
87 { nullity = NotNull
88 , info = vectorTypeInformation nullity info
89 , ..
90 }
93hvectorize :: (HTable t, Unzip f, Vector list)
94 => (forall a. Spec a -> f (context a) -> context' (list a))
95 -> f (t context)
96 -> HVectorize list t context'
97hvectorize vectorizer as = HVectorize $ htabulate $ \(HMapTableField field) ->
98 case hfield hspecs field of
99 spec -> vectorizer spec (fmap (`hfield` field) as)
100{-# INLINABLE hvectorize #-}
103hunvectorize :: (HTable t, Zip f, Vector list)
104 => (forall a. Spec a -> context (list a) -> f (context' a))
105 -> HVectorize list t context
106 -> f (t context')
107hunvectorize unvectorizer (HVectorize table) =
108 getZippy $ htabulateA $ \field -> case hfield hspecs field of
109 spec -> case hfield table (HMapTableField field) of
110 a -> Zippy (unvectorizer spec a)
111{-# INLINABLE hunvectorize #-}
114happend :: (HTable t, Vector list)
115 => (forall a. Spec a -> context (list a) -> context (list a) -> context (list a))
116 -> HVectorize list t context
117 -> HVectorize list t context
118 -> HVectorize list t context
119happend append (HVectorize as) (HVectorize bs) = HVectorize $
120 htabulate $ \field@(HMapTableField j) -> case (hfield as field, hfield bs field) of
121 (a, b) -> case hfield hspecs j of
122 spec -> append spec a b
125hempty :: HTable t
126 => (forall a. Spec a -> context [a])
127 -> HVectorize [] t context
128hempty empty = HVectorize $ htabulate $ \(HMapTableField field) ->
129 empty (hfield hspecs field)
132hproject :: ()
133 => (forall ctx. t ctx -> t' ctx)
134 -> HVectorize list t context -> HVectorize list t' context
135hproject f (HVectorize a) = HVectorize (HMapTable.hproject f a)