git.iko.soy/rel8
on 593e21b help sign in
rel8/src/Rel8/Schema/HTable/Nullify.hs
105 lines 2.9 kB history raw
1{-# LANGUAGE DeriveAnyClass #-}
2{-# LANGUAGE DerivingStrategies #-}
3{-# LANGUAGE DeriveGeneric #-}
4{-# LANGUAGE NamedFieldPuns #-}
5{-# LANGUAGE LambdaCase #-}
6{-# language ConstraintKinds #-}
7{-# language DataKinds #-}
8{-# language FlexibleInstances #-}
9{-# language GADTs #-}
10{-# language MultiParamTypeClasses #-}
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
30 ( HTable
31 , hfield, htabulate, htabulateA, hspecs
32 )
33import qualified Rel8.Schema.Kind as K
34import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ) )
35import qualified Rel8.Schema.Nullability as Type ( Nullify )
36import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
38-- semigroupoids
39import Data.Functor.Apply ( Apply )
40import Rel8.Schema.HTable.MapTable
41import Rel8.FCF
42import GHC.Generics (Generic)
45type HNullify :: K.HTable -> K.HTable
46newtype HNullify table context = HNullify (HMapTable Nullify table context)
47 deriving stock Generic
48 deriving anyclass HTable
52-- | Transform a 'Spec' by allowing it to be @null@.
53data Nullify :: Spec -> Exp Spec
56type instance Eval (Nullify ('Spec labels necessity a)) =
57 'Spec labels necessity (Type.Nullify a)
60instance MapSpec Nullify where
61 mapInfo = \case
62 SSpec{labels, necessity, info, nullability} -> SSpec
63 { labels
64 , necessity
65 , info
66 , nullability = case nullability of
67 Nullable -> Nullable
68 NonNullable -> Nullable
69 }
72hnulls :: HTable t
73 => (forall labels necessity a. ()
74 => context ('Spec labels necessity (Maybe a)))
75 -> HNullify t context
76hnulls null = HNullify $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of
77 SSpec {} -> null
78{-# INLINABLE hnulls #-}
81hnullify :: HTable t
82 => (forall labels necessity a. ()
83 => SSpec ('Spec labels necessity a)
84 -> context ('Spec labels necessity a)
85 -> context ('Spec labels necessity (Type.Nullify a)))
86 -> t context
87 -> HNullify t context
88hnullify nullifier a = HNullify $ htabulate $ \(HMapTableField field) ->
89 case hfield hspecs field of
90 spec@SSpec {} -> nullifier spec (hfield a field)
91{-# INLINABLE hnullify #-}
94hunnullify :: (HTable t, Apply m)
95 => (forall labels necessity a. ()
96 => SSpec ('Spec labels necessity a)
97 -> context ('Spec labels necessity (Type.Nullify a))
98 -> m (context ('Spec labels necessity a)))
99 -> HNullify t context
100 -> m (t context)
101hunnullify unnullifier (HNullify as) =
102 htabulateA $ \field -> case hfield hspecs field of
103 spec@SSpec {} -> case hfield as (HMapTableField field) of
104 a -> unnullifier spec a
105{-# INLINABLE hunnullify #-}