git.iko.soy/rel8
on 7a526b6 help sign in
rel8/src/Rel8/Schema/HTable/Nullify.hs
103 lines 2.9 kB history raw
1{-# language ConstraintKinds #-}
2{-# language DataKinds #-}
3{-# language DeriveAnyClass #-}
4{-# language DerivingStrategies #-}
5{-# language DeriveGeneric #-}
6{-# language FlexibleInstances #-}
7{-# language GADTs #-}
8{-# language LambdaCase #-}
9{-# language MultiParamTypeClasses #-}
10{-# language NamedFieldPuns #-}
11{-# language QuantifiedConstraints #-}
12{-# language RankNTypes #-}
13{-# language ScopedTypeVariables #-}
14{-# language StandaloneKindSignatures #-}
15{-# language TypeFamilies #-}
16{-# language UndecidableInstances #-}
18module Rel8.Schema.HTable.Nullify
19 ( HNullify( HNullify )
20 , Nullify
21 , hnulls, hnullify, hunnullify
22 )
23where
25-- base
26import Prelude hiding ( null )
28-- rel8
29import Rel8.Schema.HTable ( HTable, hfield, htabulate, htabulateA, hspecs )
30import qualified Rel8.Schema.Kind as K
31import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
32import qualified Rel8.Schema.Null as Type ( Nullify )
33import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
35-- semigroupoids
36import Data.Functor.Apply ( Apply )
37import Rel8.Schema.HTable.MapTable
38import Rel8.FCF
39import GHC.Generics (Generic)
42type HNullify :: K.HTable -> K.HTable
43newtype HNullify table context = HNullify (HMapTable Nullify table context)
44 deriving stock Generic
45 deriving anyclass HTable
49-- | Transform a 'Spec' by allowing it to be @null@.
50data Nullify :: Spec -> Exp Spec
53type instance Eval (Nullify ('Spec labels necessity a)) =
54 'Spec labels necessity (Type.Nullify a)
57instance MapSpec Nullify where
58 mapInfo = \case
59 SSpec{labels, necessity, info, nullity} -> SSpec
60 { labels
61 , necessity
62 , info
63 , nullity = case nullity of
64 Null -> Null
65 NotNull -> Null
66 }
69hnulls :: HTable t
70 => (forall labels necessity a. ()
71 => SSpec ('Spec labels necessity a)
72 -> context ('Spec labels necessity (Type.Nullify a)))
73 -> HNullify t context
74hnulls null = HNullify $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of
75 spec@SSpec {} -> null spec
76{-# INLINABLE hnulls #-}
79hnullify :: HTable t
80 => (forall labels necessity a. ()
81 => SSpec ('Spec labels necessity a)
82 -> context ('Spec labels necessity a)
83 -> context ('Spec labels necessity (Type.Nullify a)))
84 -> t context
85 -> HNullify t context
86hnullify nullifier a = HNullify $ htabulate $ \(HMapTableField field) ->
87 case hfield hspecs field of
88 spec@SSpec {} -> nullifier spec (hfield a field)
89{-# INLINABLE hnullify #-}
92hunnullify :: (HTable t, Apply m)
93 => (forall labels necessity a. ()
94 => SSpec ('Spec labels necessity a)
95 -> context ('Spec labels necessity (Type.Nullify a))
96 -> m (context ('Spec labels necessity a)))
97 -> HNullify t context
98 -> m (t context)
99hunnullify unnullifier (HNullify as) =
100 htabulateA $ \field -> case hfield hspecs field of
101 spec@SSpec {} -> case hfield as (HMapTableField field) of
102 a -> unnullifier spec a
103{-# INLINABLE hunnullify #-}