git.iko.soy/rel8
on 28aaa76 help sign in
rel8/src/Rel8/Schema/HTable/Vectorize.hs
165 lines 5.0 kB history raw
1{-# LANGUAGE DeriveAnyClass #-}
2{-# LANGUAGE DeriveGeneric #-}
3{-# LANGUAGE DerivingStrategies #-}
4{-# LANGUAGE LambdaCase #-}
5{-# language AllowAmbiguousTypes #-}
6{-# language ConstraintKinds #-}
7{-# language DataKinds #-}
8{-# language FlexibleContexts #-}
9{-# language FlexibleInstances #-}
10{-# language GADTs #-}
11{-# language InstanceSigs #-}
12{-# language MultiParamTypeClasses #-}
13{-# language NamedFieldPuns #-}
14{-# language QuantifiedConstraints #-}
15{-# language RankNTypes #-}
16{-# language RecordWildCards #-}
17{-# language ScopedTypeVariables #-}
18{-# language StandaloneKindSignatures #-}
19{-# language TypeApplications #-}
20{-# language TypeFamilies #-}
21{-# language TypeOperators #-}
22{-# language UndecidableInstances #-}
24module Rel8.Schema.HTable.Vectorize
25 ( HVectorize
26 , hvectorize, hunvectorize
27 , happend, hempty
28 , hrelabel
29 )
30where
32-- base
33import Data.Kind ( Type )
34import Data.List.NonEmpty ( NonEmpty )
35import Prelude
37-- rel8
38import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler )
39import Rel8.Schema.Dict ( Dict( Dict ) )
40import qualified Rel8.Schema.Kind as K
41import Rel8.Schema.HTable
42 ( HTable
43 , hfield, htabulate, htabulateA, hspecs
44 )
45import Rel8.Schema.Nullability
46 ( Unnullify
47 , NotNull
48 , Nullability( NonNullable )
49 )
50import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
51import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )
52import Rel8.Type.Information ( TypeInformation )
54-- semialign
55import Data.Zip ( Unzip, Repeat, Zippy(..) )
56import Rel8.FCF
57import Rel8.Schema.HTable.MapTable
58import GHC.Generics (Generic)
61class Vector list where
62 listNotNull :: proxy a -> Dict NotNull (list a)
63 vectorTypeInformation :: ()
64 => Nullability a
65 -> TypeInformation (Unnullify a)
66 -> TypeInformation (list a)
69instance Vector [] where
70 listNotNull _ = Dict
71 vectorTypeInformation = listTypeInformation
74instance Vector NonEmpty where
75 listNotNull _ = Dict
76 vectorTypeInformation = nonEmptyTypeInformation
79type HVectorize :: (Type -> Type) -> K.HTable -> K.HTable
80newtype HVectorize list table context = HVectorize (HMapTable (Vectorize list) table context)
81 deriving stock Generic
82 deriving anyclass HTable
85data Vectorize :: (Type -> Type) -> Spec -> Exp Spec
88type instance Eval (Vectorize list ('Spec labels necessity a)) = 'Spec labels necessity (list a)
91instance Vector list => MapSpec (Vectorize list) where
92 mapInfo = \case
93 SSpec {..} -> case listNotNull @list nullability of
94 Dict -> SSpec
95 { nullability = NonNullable
96 , info = vectorTypeInformation nullability info
97 , ..
98 }
101hvectorize :: (HTable t, Unzip f, Vector list)
102 => (forall labels necessity a. ()
103 => SSpec ('Spec labels necessity a)
104 -> f (context ('Spec labels necessity a))
105 -> context' ('Spec labels necessity (list a)))
106 -> f (t context)
107 -> HVectorize list t context'
108hvectorize vectorizer as = HVectorize $ htabulate $ \(HMapTableField field) ->
109 case hfield hspecs field of
110 spec@SSpec {} -> vectorizer spec (fmap (`hfield` field) as)
111{-# INLINABLE hvectorize #-}
114hunvectorize :: (HTable t, Repeat f, Vector list)
115 => (forall labels necessity a. ()
116 => SSpec ('Spec labels necessity a)
117 -> context ('Spec labels necessity (list a))
118 -> f (context' ('Spec labels necessity a)))
119 -> HVectorize list t context
120 -> f (t context')
121hunvectorize unvectorizer (HVectorize table) =
122 getZippy $ htabulateA $ \field -> case hfield hspecs field of
123 spec@SSpec{} -> case hfield table (HMapTableField field) of
124 a -> Zippy (unvectorizer spec a)
125{-# INLINABLE hunvectorize #-}
128happend :: (HTable t, Vector list) =>
129 ( forall labels necessity a. ()
130 => Nullability a
131 -> TypeInformation (Unnullify a)
132 -> context ('Spec labels necessity (list a))
133 -> context ('Spec labels necessity (list a))
134 -> context ('Spec labels necessity (list a))
135 )
136 -> HVectorize list t context
137 -> HVectorize list t context
138 -> HVectorize list t context
139happend append (HVectorize as) (HVectorize bs) = HVectorize $
140 htabulate $ \field@(HMapTableField j) -> case (hfield as field, hfield bs field) of
141 (a, b) -> case hfield hspecs j of
142 SSpec {nullability, info} -> append nullability info a b
145hempty :: HTable t =>
146 ( forall labels necessity a. ()
147 => Nullability a
148 -> TypeInformation (Unnullify a)
149 -> context ('Spec labels necessity [a])
150 )
151 -> HVectorize [] t context
152hempty empty = HVectorize $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of
153 SSpec {nullability, info} -> empty nullability info
156instance HLabelable g => HLabelable (Precompose (Vectorize list) g) where
157 hlabeler = Precompose . hlabeler . precomposed
158 hunlabeler = Precompose . hunlabeler . precomposed
161hrelabel :: HLabelable context
162 => (forall ctx. HLabelable ctx => t ctx -> u ctx)
163 -> HVectorize list t context
164 -> HVectorize list u context
165hrelabel f (HVectorize (HMapTable table)) = HVectorize (HMapTable (f table))