git.iko.soy/rel8
on 593e21b help sign in
rel8/src/Rel8/Schema/HTable/Vectorize.hs
163 lines 4.9 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 , hrelabel
27 )
28where
30-- base
31import Data.Kind ( Type )
32import Data.List.NonEmpty ( NonEmpty )
33import Prelude
35-- rel8
36import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler )
37import Rel8.Schema.Dict ( Dict( Dict ) )
38import qualified Rel8.Schema.Kind as K
39import Rel8.Schema.HTable
40 ( HTable
41 , hfield, htabulate, htabulateA, hspecs
42 )
43import Rel8.Schema.Nullability
44 ( Unnullify
45 , NotNull
46 , Nullability( NonNullable )
47 )
48import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
49import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )
50import Rel8.Type.Information ( TypeInformation )
52-- semialign
53import Data.Zip ( Unzip, Repeat, Zippy(..) )
54import Rel8.FCF
55import Rel8.Schema.HTable.MapTable
56import GHC.Generics (Generic)
59class Vector list where
60 listNotNull :: proxy a -> Dict NotNull (list a)
61 vectorTypeInformation :: ()
62 => Nullability a
63 -> TypeInformation (Unnullify a)
64 -> TypeInformation (list a)
67instance Vector [] where
68 listNotNull _ = Dict
69 vectorTypeInformation = listTypeInformation
72instance Vector NonEmpty where
73 listNotNull _ = Dict
74 vectorTypeInformation = nonEmptyTypeInformation
77type HVectorize :: (Type -> Type) -> K.HTable -> K.HTable
78newtype HVectorize list table context = HVectorize (HMapTable (Vectorize list) table context)
79 deriving stock Generic
80 deriving anyclass HTable
83data Vectorize :: (Type -> Type) -> Spec -> Exp Spec
86type instance Eval (Vectorize list ('Spec labels necessity a)) = 'Spec labels necessity (list a)
89instance Vector list => MapSpec (Vectorize list) where
90 mapInfo = \case
91 SSpec {..} -> case listNotNull @list nullability of
92 Dict -> SSpec
93 { nullability = NonNullable
94 , info = vectorTypeInformation nullability info
95 , ..
96 }
99hvectorize :: (HTable t, Unzip f, Vector list)
100 => (forall labels necessity a. ()
101 => SSpec ('Spec labels necessity a)
102 -> f (context ('Spec labels necessity a))
103 -> context' ('Spec labels necessity (list a)))
104 -> f (t context)
105 -> HVectorize list t context'
106hvectorize vectorizer as = HVectorize $ htabulate $ \(HMapTableField field) ->
107 case hfield hspecs field of
108 spec@SSpec {} -> vectorizer spec (fmap (`hfield` field) as)
109{-# INLINABLE hvectorize #-}
112hunvectorize :: (HTable t, Repeat f, Vector list)
113 => (forall labels necessity a. ()
114 => SSpec ('Spec labels necessity a)
115 -> context ('Spec labels necessity (list a))
116 -> f (context' ('Spec labels necessity a)))
117 -> HVectorize list t context
118 -> f (t context')
119hunvectorize unvectorizer (HVectorize table) =
120 getZippy $ htabulateA $ \field -> case hfield hspecs field of
121 spec@SSpec{} -> case hfield table (HMapTableField field) of
122 a -> Zippy (unvectorizer spec a)
123{-# INLINABLE hunvectorize #-}
126happend :: (HTable t, Vector list) =>
127 ( forall labels necessity a. ()
128 => Nullability a
129 -> TypeInformation (Unnullify a)
130 -> context ('Spec labels necessity (list a))
131 -> context ('Spec labels necessity (list a))
132 -> context ('Spec labels necessity (list a))
133 )
134 -> HVectorize list t context
135 -> HVectorize list t context
136 -> HVectorize list t context
137happend append (HVectorize as) (HVectorize bs) = HVectorize $
138 htabulate $ \field@(HMapTableField j) -> case (hfield as field, hfield bs field) of
139 (a, b) -> case hfield hspecs j of
140 SSpec {nullability, info} -> append nullability info a b
143hempty :: HTable t =>
144 ( forall labels necessity a. ()
145 => Nullability a
146 -> TypeInformation (Unnullify a)
147 -> context ('Spec labels necessity [a])
148 )
149 -> HVectorize [] t context
150hempty empty = HVectorize $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of
151 SSpec {nullability, info} -> empty nullability info
154instance HLabelable g => HLabelable (Precompose (Vectorize list) g) where
155 hlabeler = Precompose . hlabeler . precomposed
156 hunlabeler = Precompose . hunlabeler . precomposed
159hrelabel :: HLabelable context
160 => (forall ctx. HLabelable ctx => t ctx -> u ctx)
161 -> HVectorize list t context
162 -> HVectorize list u context
163hrelabel f (HVectorize (HMapTable table)) = HVectorize (HMapTable (f table))