git.iko.soy/rel8
on 9ac34c5 help sign in
rel8/src/Rel8/Schema/HTable/Vectorize.hs
161 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 Data.Type.Equality ( (:~:)( Refl ) )
36import Prelude
38-- rel8
39import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler )
40import qualified Rel8.Schema.Kind as K
41import Rel8.Schema.HTable
42 ( HTable
43 , hfield, htabulate, htabulateA, hspecs
44 )
45import Rel8.Schema.Nullability ( IsMaybe, Nullability( NonNullable ) )
46import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
47import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )
48import Rel8.Type.Information ( TypeInformation )
50-- semialign
51import Data.Zip ( Unzip, Repeat, Zippy(..) )
52import Rel8.FCF
53import Rel8.Schema.HTable.MapTable
54import GHC.Generics (Generic)
57class Vector list where
58 listIsn'tMaybe :: proxy a -> IsMaybe (list a) :~: 'False
59 vectorTypeInformation :: ()
60 => Nullability a ma
61 -> TypeInformation a
62 -> TypeInformation (list ma)
65instance Vector [] where
66 listIsn'tMaybe _ = Refl
67 vectorTypeInformation = listTypeInformation
70instance Vector NonEmpty where
71 listIsn'tMaybe _ = Refl
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) -> Spec -> Exp Spec
84type instance Eval (Vectorize list ('Spec labels necessity _ a)) = 'Spec labels necessity (list a) (list a)
87instance Vector list => MapSpec (Vectorize list) where
88 mapInfo = \case
89 SSpec {..} -> case listIsn'tMaybe @list nullability of
90 Refl -> SSpec
91 { nullability = NonNullable
92 , info = vectorTypeInformation nullability info
93 , ..
94 }
97hvectorize :: (HTable t, Unzip f, Vector list)
98 => (forall labels necessity db a. ()
99 => SSpec ('Spec labels necessity db a)
100 -> f (context ('Spec labels necessity db a))
101 -> context' ('Spec labels necessity (list a) (list a)))
102 -> f (t context)
103 -> HVectorize list t context'
104hvectorize vectorizer as = HVectorize $ htabulate $ \(HMapTableField field) ->
105 case hfield hspecs field of
106 spec@SSpec {} -> vectorizer spec (fmap (`hfield` field) as)
107{-# INLINABLE hvectorize #-}
110hunvectorize :: (HTable t, Repeat f, Vector list)
111 => (forall labels necessity db a. ()
112 => SSpec ('Spec labels necessity db a)
113 -> context ('Spec labels necessity (list a) (list a))
114 -> f (context' ('Spec labels necessity db a)))
115 -> HVectorize list t context
116 -> f (t context')
117hunvectorize unvectorizer (HVectorize table) =
118 getZippy $ htabulateA $ \field -> case hfield hspecs field of
119 spec@SSpec{} -> case hfield table (HMapTableField field) of
120 a -> Zippy (unvectorizer spec a)
121{-# INLINABLE hunvectorize #-}
124happend :: (HTable t, Vector list) =>
125 ( forall labels necessity db a. ()
126 => Nullability db a
127 -> TypeInformation db
128 -> context ('Spec labels necessity (list a) (list a))
129 -> context ('Spec labels necessity (list a) (list a))
130 -> context ('Spec labels necessity (list a) (list a))
131 )
132 -> HVectorize list t context
133 -> HVectorize list t context
134 -> HVectorize list t context
135happend append (HVectorize as) (HVectorize bs) = HVectorize $
136 htabulate $ \field@(HMapTableField j) -> case (hfield as field, hfield bs field) of
137 (a, b) -> case hfield hspecs j of
138 SSpec {nullability, info} -> append nullability info a b
141hempty :: HTable t =>
142 ( forall labels necessity db a. ()
143 => Nullability db a
144 -> TypeInformation db
145 -> context ('Spec labels necessity [a] [a])
146 )
147 -> HVectorize [] t context
148hempty empty = HVectorize $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of
149 SSpec {nullability, info} -> empty nullability info
152instance HLabelable g => HLabelable (Precompose (Vectorize list) g) where
153 hlabeler = Precompose . hlabeler . precomposed
154 hunlabeler = Precompose . hunlabeler . precomposed
157hrelabel :: HLabelable context
158 => (forall ctx. HLabelable ctx => t ctx -> u ctx)
159 -> HVectorize list t context
160 -> HVectorize list u context
161hrelabel f (HVectorize (HMapTable table)) = HVectorize (HMapTable (f table))