git.iko.soy/rel8
on bf19395 help sign in
rel8/src/Rel8/Schema/HTable/Nullify.hs
102 lines 2.7 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 RecordWildCards #-}
14{-# language ScopedTypeVariables #-}
15{-# language StandaloneKindSignatures #-}
16{-# language TypeFamilies #-}
17{-# language UndecidableInstances #-}
19module Rel8.Schema.HTable.Nullify
20 ( HNullify( HNullify )
21 , Nullify
22 , hnulls, hnullify, hunnullify
23 )
24where
26-- base
27import Prelude hiding ( null )
29-- rel8
30import Rel8.Schema.HTable ( HTable, hfield, htabulate, htabulateA, hspecs )
31import qualified Rel8.Schema.Kind as K
32import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
33import qualified Rel8.Schema.Null as Type ( Nullify )
34import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
36-- semigroupoids
37import Data.Functor.Apply ( Apply )
38import Rel8.Schema.HTable.MapTable
39import Rel8.FCF
40import GHC.Generics (Generic)
43type HNullify :: K.HTable -> K.HTable
44newtype HNullify table context = HNullify (HMapTable Nullify table context)
45 deriving stock Generic
46 deriving anyclass HTable
50-- | Transform a 'Spec' by allowing it to be @null@.
51data Nullify :: Spec -> Exp Spec
54type instance Eval (Nullify ('Spec a)) =
55 'Spec (Type.Nullify a)
58instance MapSpec Nullify where
59 mapInfo = \case
60 SSpec {nullity, ..} -> SSpec
61 { nullity = case nullity of
62 Null -> Null
63 NotNull -> Null
64 , ..
65 }
68hnulls :: HTable t
69 => (forall a. ()
70 => SSpec ('Spec a)
71 -> context ('Spec (Type.Nullify a)))
72 -> HNullify t context
73hnulls null = HNullify $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of
74 spec@SSpec {} -> null spec
75{-# INLINABLE hnulls #-}
78hnullify :: HTable t
79 => (forall a. ()
80 => SSpec ('Spec a)
81 -> context ('Spec a)
82 -> context ('Spec (Type.Nullify a)))
83 -> t context
84 -> HNullify t context
85hnullify nullifier a = HNullify $ htabulate $ \(HMapTableField field) ->
86 case hfield hspecs field of
87 spec@SSpec {} -> nullifier spec (hfield a field)
88{-# INLINABLE hnullify #-}
91hunnullify :: (HTable t, Apply m)
92 => (forall a. ()
93 => SSpec ('Spec a)
94 -> context ('Spec (Type.Nullify a))
95 -> m (context ('Spec a)))
96 -> HNullify t context
97 -> m (t context)
98hunnullify unnullifier (HNullify as) =
99 htabulateA $ \field -> case hfield hspecs field of
100 spec@SSpec {} -> case hfield as (HMapTableField field) of
101 a -> unnullifier spec a
102{-# INLINABLE hunnullify #-}