git.iko.soy/rel8
on 00a36f5 help sign in
rel8/src/Rel8/Schema/HTable/Nullify.hs
145 lines 4.7 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 qualified Rel8.Schema.Kind as K
33import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ) )
34import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
36-- semigroupoids
37import Data.Functor.Apply ( Apply )
40type HNullify :: K.HTable -> K.HTable
41newtype HNullify table context = HNullify (table (NullifySpec context))
44type HNullifyField :: K.HTable -> Spec -> Type
45data HNullifyField table spec where
46 HNullifyField
47 :: HField table ('Spec labels necessity dbType a)
48 -> HNullifyField table ('Spec labels necessity dbType (Maybe dbType))
51instance HTable table => HTable (HNullify table) where
52 type HField (HNullify table) = HNullifyField table
53 type HConstrainTable (HNullify table) c =
54 HConstrainTable table (NullifySpecC c)
56 hfield (HNullify table) (HNullifyField field) =
57 getNullifySpec (hfield table field)
59 htabulate f = HNullify $ htabulate $ \field -> case hfield hspecs field of
60 SSpec {} -> NullifySpec (f (HNullifyField field))
62 htraverse f (HNullify t) = HNullify <$> htraverse (traverseNullifySpec f) t
64 hdicts :: forall c. HConstrainTable table (NullifySpecC c)
65 => HNullify table (Dict c)
66 hdicts = HNullify $ htabulate $ \field -> case hfield hspecs field of
67 SSpec {} -> case hfield (hdicts @_ @(NullifySpecC c)) field of
68 Dict -> NullifySpec Dict
70 hspecs = HNullify $ htabulate $ \field -> case hfield hspecs field of
71 SSpec {..} -> case nullability of
72 Nullable -> NullifySpec SSpec {nullability = Nullable, ..}
73 NonNullable -> NullifySpec SSpec {nullability = Nullable, ..}
75 {-# INLINABLE hfield #-}
76 {-# INLINABLE htabulate #-}
77 {-# INLINABLE htraverse #-}
78 {-# INLINABLE hdicts #-}
79 {-# INLINABLE hspecs #-}
82type NullifyingSpec :: Type -> Type
83type NullifyingSpec r = (Spec -> r) -> Spec -> r
86type NullifySpec :: NullifyingSpec Type
87data NullifySpec context spec where
88 NullifySpec
89 :: { getNullifySpec :: context ('Spec labels necessity dbType (Maybe dbType)) }
90 -> NullifySpec context ('Spec labels necessity dbType a)
93type NullifySpecC :: NullifyingSpec Constraint
94class
95 ( forall labels necessity dbType a.
96 ( spec ~ 'Spec labels necessity dbType a =>
97 constraint ('Spec labels necessity dbType (Maybe dbType))
98 )
99 ) => NullifySpecC constraint spec
100instance
101 ( spec ~ 'Spec labels necessity dbType a
102 , constraint ('Spec labels necessity dbType (Maybe dbType))
103 ) => NullifySpecC constraint spec
106traverseNullifySpec :: forall context context' spec m. Functor m
107 => (forall x. context x -> m (context' x))
108 -> NullifySpec context spec -> m (NullifySpec context' spec)
109traverseNullifySpec f (NullifySpec a) = NullifySpec <$> f a
112hnulls :: HTable t
113 => (forall labels necessity dbType. ()
114 => context ('Spec labels necessity dbType (Maybe dbType)))
115 -> HNullify t context
116hnulls null = HNullify $ htabulate $ \field -> case hfield hspecs field of
117 SSpec {} -> NullifySpec null
118{-# INLINABLE hnulls #-}
121hnullify :: HTable t
122 => (forall labels necessity dbType a. ()
123 => SSpec ('Spec labels necessity dbType a)
124 -> context ('Spec labels necessity dbType a)
125 -> context ('Spec labels necessity dbType (Maybe dbType)))
126 -> t context
127 -> HNullify t context
128hnullify nullifier a = HNullify $ htabulate $ \field ->
129 case hfield hspecs field of
130 spec@SSpec {} -> NullifySpec (nullifier spec (hfield a field))
131{-# INLINABLE hnullify #-}
134hunnullify :: (HTable t, Apply m)
135 => (forall labels necessity dbType a. ()
136 => SSpec ('Spec labels necessity dbType a)
137 -> context ('Spec labels necessity dbType (Maybe dbType))
138 -> m (context ('Spec labels necessity dbType a)))
139 -> HNullify t context
140 -> m (t context)
141hunnullify unnullifier (HNullify as) =
142 htabulateA $ \field -> case hfield hspecs field of
143 spec@SSpec {} -> case hfield as field of
144 NullifySpec a -> unnullifier spec a
145{-# INLINABLE hunnullify #-}