git.iko.soy/rel8
on da76712 help sign in
rel8/src/Rel8/Schema/HTable/Vectorize.hs
143 lines 4.3 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 , hcolumn
26 )
27where
29-- base
30import Data.Kind ( Constraint, Type )
31import Data.List.NonEmpty ( NonEmpty )
32import GHC.Generics (Generic)
33import Prelude
35-- rel8
36import Rel8.FCF ( Eval, Exp )
37import Rel8.Schema.Dict ( Dict( Dict ) )
38import qualified Rel8.Schema.Kind as K
39import Rel8.Schema.HTable ( HTable, hfield, htabulate, htabulateA, hspecs )
40import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
41import Rel8.Schema.HTable.MapTable
42 ( HMapTable( HMapTable ), HMapTableField( HMapTableField )
43 , MapSpec, mapInfo
44 , Precompose( Precompose )
45 )
46import qualified Rel8.Schema.HTable.MapTable as HMapTable ( hproject )
47import Rel8.Schema.Null ( Unnullify, NotNull, Nullity( NotNull ) )
48import Rel8.Schema.Spec ( Spec(..) )
49import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )
50import Rel8.Type.Information ( TypeInformation )
52-- semialign
53import Data.Zip ( Unzip, Zip, Zippy(..) )
56type Vector :: (Type -> Type) -> Constraint
57class Vector list where
58 listNotNull :: proxy a -> Dict NotNull (list a)
59 vectorTypeInformation :: ()
60 => Nullity a
61 -> TypeInformation (Unnullify a)
62 -> TypeInformation (list a)
65instance Vector [] where
66 listNotNull _ = Dict
67 vectorTypeInformation = listTypeInformation
70instance Vector NonEmpty where
71 listNotNull _ = Dict
72 vectorTypeInformation = nonEmptyTypeInformation
75type HVectorize :: (Type -> Type) -> K.HTable -> K.HTable
76newtype HVectorize list table context = HVectorize (HMapTable (Vectorize list) table context)
77 deriving stock Generic
78 deriving anyclass HTable
81data Vectorize :: (Type -> Type) -> Type -> Exp Type
84type instance Eval (Vectorize list a) = list a
87instance Vector list => MapSpec (Vectorize list) where
88 mapInfo = \case
89 Spec {..} -> case listNotNull @list nullity of
90 Dict -> Spec
91 { nullity = NotNull
92 , info = vectorTypeInformation nullity info
93 , ..
94 }
97hvectorize :: (HTable t, Unzip f, Vector list)
98 => (forall a. Spec a -> f (context a) -> context' (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 -> vectorizer spec (fmap (`hfield` field) as)
104{-# INLINABLE hvectorize #-}
107hunvectorize :: (HTable t, Zip f, Vector list)
108 => (forall a. Spec a -> context (list a) -> f (context' a))
109 -> HVectorize list t context
110 -> f (t context')
111hunvectorize unvectorizer (HVectorize table) =
112 getZippy $ htabulateA $ \field -> case hfield hspecs field of
113 spec -> case hfield table (HMapTableField field) of
114 a -> Zippy (unvectorizer spec a)
115{-# INLINABLE hunvectorize #-}
118happend :: (HTable t, Vector list)
119 => (forall a. Spec a -> context (list a) -> context (list a) -> context (list a))
120 -> HVectorize list t context
121 -> HVectorize list t context
122 -> HVectorize list t context
123happend append (HVectorize as) (HVectorize bs) = HVectorize $
124 htabulate $ \field@(HMapTableField j) -> case (hfield as field, hfield bs field) of
125 (a, b) -> case hfield hspecs j of
126 spec -> append spec a b
129hempty :: HTable t
130 => (forall a. Spec a -> context [a])
131 -> HVectorize [] t context
132hempty empty = HVectorize $ htabulate $ \(HMapTableField field) ->
133 empty (hfield hspecs field)
136hproject :: ()
137 => (forall ctx. t ctx -> t' ctx)
138 -> HVectorize list t context -> HVectorize list t' context
139hproject f (HVectorize a) = HVectorize (HMapTable.hproject f a)
142hcolumn :: HVectorize list (HIdentity a) context -> context (list a)
143hcolumn (HVectorize (HMapTable (HIdentity (Precompose a)))) = a