git.iko.soy/rel8
on c118acc help sign in
rel8/src/Rel8/Schema/HTable/Nullify.hs
146 lines 4.8 kB history raw
1{-# language ConstraintKinds #-}
2{-# language DataKinds #-}
3{-# language FlexibleInstances #-}
4{-# language GADTs #-}
5{-# language InstanceSigs #-}
6{-# language MultiParamTypeClasses #-}
7{-# language QuantifiedConstraints #-}
8{-# language RankNTypes #-}
9{-# language RecordWildCards #-}
10{-# language ScopedTypeVariables #-}
11{-# language StandaloneKindSignatures #-}
12{-# language TypeApplications #-}
13{-# language TypeFamilies #-}
14{-# language UndecidableInstances #-}
16module Rel8.Schema.HTable.Nullify
17 ( HNullify( HNullify )
18 , hnulls, hnullify, hunnullify
19 )
20where
22-- base
23import Data.Kind ( Constraint, Type )
24import Prelude hiding ( null )
26-- rel8
27import Rel8.Schema.Dict ( Dict( Dict ) )
28import Rel8.Schema.HTable
29 ( HTable, HConstrainTable, HField
30 , hfield, htabulate, htabulateA, htraverse, hdicts, hspecs
31 )
32import Rel8.Schema.HTable.Context ( H, HKTable )
33import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ) )
34import Rel8.Schema.Spec ( Context, Spec( Spec ), SSpec(..) )
36-- semigroupoids
37import Data.Functor.Apply ( Apply )
40type HNullify :: HKTable -> HKTable
41data HNullify table context where
42 HNullify :: table (H (NullifySpec context)) -> HNullify table (H context)
45type HNullifyField :: HKTable -> Context
46data HNullifyField table spec where
47 HNullifyField
48 :: HField table ('Spec labels necessity dbType a)
49 -> HNullifyField table ('Spec labels necessity dbType (Maybe dbType))
52instance HTable table => HTable (HNullify table) where
53 type HField (HNullify table) = HNullifyField table
54 type HConstrainTable (HNullify table) c =
55 HConstrainTable table (NullifySpecC c)
57 hfield (HNullify table) (HNullifyField field) =
58 getNullifySpec (hfield table field)
60 htabulate f = HNullify $ htabulate $ \field -> case hfield hspecs field of
61 SSpec {} -> NullifySpec (f (HNullifyField field))
63 htraverse f (HNullify t) = HNullify <$> htraverse (traverseNullifySpec f) t
65 hdicts :: forall c. HConstrainTable table (NullifySpecC c)
66 => HNullify table (H (Dict c))
67 hdicts = HNullify $ htabulate $ \field -> case hfield hspecs field of
68 SSpec {} -> case hfield (hdicts @_ @(NullifySpecC c)) field of
69 Dict -> NullifySpec Dict
71 hspecs = HNullify $ htabulate $ \field -> case hfield hspecs field of
72 SSpec {..} -> case nullability of
73 Nullable -> NullifySpec SSpec {nullability = Nullable, ..}
74 NonNullable -> NullifySpec SSpec {nullability = Nullable, ..}
76 {-# INLINABLE hfield #-}
77 {-# INLINABLE htabulate #-}
78 {-# INLINABLE htraverse #-}
79 {-# INLINABLE hdicts #-}
80 {-# INLINABLE hspecs #-}
83type NullifyingSpec :: Type -> Type
84type NullifyingSpec r = (Spec -> r) -> Spec -> r
87type NullifySpec :: NullifyingSpec Type
88data NullifySpec context spec where
89 NullifySpec
90 :: { getNullifySpec :: context ('Spec labels necessity dbType (Maybe dbType)) }
91 -> NullifySpec context ('Spec labels necessity dbType a)
94type NullifySpecC :: NullifyingSpec Constraint
95class
96 ( forall labels necessity dbType a.
97 ( spec ~ 'Spec labels necessity dbType a =>
98 constraint ('Spec labels necessity dbType (Maybe dbType))
99 )
100 ) => NullifySpecC constraint spec
101instance
102 ( spec ~ 'Spec labels necessity dbType a
103 , constraint ('Spec labels necessity dbType (Maybe dbType))
104 ) => NullifySpecC constraint spec
107traverseNullifySpec :: forall context context' spec m. Functor m
108 => (forall x. context x -> m (context' x))
109 -> NullifySpec context spec -> m (NullifySpec context' spec)
110traverseNullifySpec f (NullifySpec a) = NullifySpec <$> f a
113hnulls :: HTable t
114 => (forall labels necessity dbType. ()
115 => context ('Spec labels necessity dbType (Maybe dbType)))
116 -> HNullify t (H context)
117hnulls null = HNullify $ htabulate $ \field -> case hfield hspecs field of
118 SSpec {} -> NullifySpec null
119{-# INLINABLE hnulls #-}
122hnullify :: HTable t
123 => (forall labels necessity dbType a. ()
124 => SSpec ('Spec labels necessity dbType a)
125 -> context ('Spec labels necessity dbType a)
126 -> context ('Spec labels necessity dbType (Maybe dbType)))
127 -> t (H context)
128 -> HNullify t (H context)
129hnullify nullifier a = HNullify $ htabulate $ \field ->
130 case hfield hspecs field of
131 spec@SSpec {} -> NullifySpec (nullifier spec (hfield a field))
132{-# INLINABLE hnullify #-}
135hunnullify :: (HTable t, Apply m)
136 => (forall labels necessity dbType a. ()
137 => SSpec ('Spec labels necessity dbType a)
138 -> context ('Spec labels necessity dbType (Maybe dbType))
139 -> m (context ('Spec labels necessity dbType a)))
140 -> HNullify t (H context)
141 -> m (t (H context))
142hunnullify unnullifier (HNullify as) =
143 htabulateA $ \field -> case hfield hspecs field of
144 spec@SSpec {} -> case hfield as field of
145 NullifySpec a -> unnullifier spec a
146{-# INLINABLE hunnullify #-}