git.iko.soy/rel8
on f47423e help sign in
rel8/src/Rel8/Schema/HTable/Vectorize.hs
124 lines 3.6 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 )
25where
27-- base
28import Data.Kind ( Type )
29import Data.List.NonEmpty ( NonEmpty )
30import Prelude
32-- rel8
33import Rel8.Schema.Dict ( Dict( Dict ) )
34import qualified Rel8.Schema.Kind as K
35import Rel8.Schema.HTable ( HTable, hfield, htabulate, htabulateA, hspecs )
36import Rel8.Schema.Null ( Unnullify, NotNull, Nullity( NotNull ) )
37import Rel8.Schema.Spec ( Spec(..) )
38import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )
39import Rel8.Type.Information ( TypeInformation )
41-- semialign
42import Data.Zip ( Unzip, Zip, Zippy(..) )
43import Rel8.FCF
44import Rel8.Schema.HTable.MapTable
45import GHC.Generics (Generic)
48class Vector list where
49 listNotNull :: proxy a -> Dict NotNull (list a)
50 vectorTypeInformation :: ()
51 => Nullity a
52 -> TypeInformation (Unnullify a)
53 -> TypeInformation (list a)
56instance Vector [] where
57 listNotNull _ = Dict
58 vectorTypeInformation = listTypeInformation
61instance Vector NonEmpty where
62 listNotNull _ = Dict
63 vectorTypeInformation = nonEmptyTypeInformation
66type HVectorize :: (Type -> Type) -> K.HTable -> K.HTable
67newtype HVectorize list table context = HVectorize (HMapTable (Vectorize list) table context)
68 deriving stock Generic
69 deriving anyclass HTable
72data Vectorize :: (Type -> Type) -> Type -> Exp Type
75type instance Eval (Vectorize list a) = list a
78instance Vector list => MapSpec (Vectorize list) where
79 mapInfo = \case
80 Spec {..} -> case listNotNull @list nullity of
81 Dict -> Spec
82 { nullity = NotNull
83 , info = vectorTypeInformation nullity info
84 , ..
85 }
88hvectorize :: (HTable t, Unzip f, Vector list)
89 => (forall a. Spec a -> f (context a) -> context' (list a))
90 -> f (t context)
91 -> HVectorize list t context'
92hvectorize vectorizer as = HVectorize $ htabulate $ \(HMapTableField field) ->
93 case hfield hspecs field of
94 spec -> vectorizer spec (fmap (`hfield` field) as)
95{-# INLINABLE hvectorize #-}
98hunvectorize :: (HTable t, Zip f, Vector list)
99 => (forall a. Spec a -> context (list a) -> f (context' a))
100 -> HVectorize list t context
101 -> f (t context')
102hunvectorize unvectorizer (HVectorize table) =
103 getZippy $ htabulateA $ \field -> case hfield hspecs field of
104 spec -> case hfield table (HMapTableField field) of
105 a -> Zippy (unvectorizer spec a)
106{-# INLINABLE hunvectorize #-}
109happend :: (HTable t, Vector list)
110 => (forall a. Spec a -> context (list a) -> context (list a) -> context (list a))
111 -> HVectorize list t context
112 -> HVectorize list t context
113 -> HVectorize list t context
114happend append (HVectorize as) (HVectorize bs) = HVectorize $
115 htabulate $ \field@(HMapTableField j) -> case (hfield as field, hfield bs field) of
116 (a, b) -> case hfield hspecs j of
117 spec -> append spec a b
120hempty :: HTable t
121 => (forall a. Spec a -> context [a])
122 -> HVectorize [] t context
123hempty empty = HVectorize $ htabulate $ \(HMapTableField field) ->
124 empty (hfield hspecs field)