git.iko.soy/rel8
on ca7aaef help sign in
rel8/src/Rel8/Schema/HTable/Nullify.hs
108 lines 3.0 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 InstanceSigs #-}
11{-# language MultiParamTypeClasses #-}
12{-# language QuantifiedConstraints #-}
13{-# language RankNTypes #-}
14{-# language RecordWildCards #-}
15{-# language ScopedTypeVariables #-}
16{-# language StandaloneKindSignatures #-}
17{-# language TypeApplications #-}
18{-# language TypeFamilies #-}
19{-# language UndecidableInstances #-}
21module Rel8.Schema.HTable.Nullify
22 ( HNullify( HNullify )
23 , Nullify
24 , hnulls, hnullify, hunnullify
25 )
26where
28-- base
29import Prelude hiding ( null )
31-- rel8
32import Rel8.Schema.HTable
33 ( HTable
34 , hfield, htabulate, htabulateA, hspecs
35 )
36import qualified Rel8.Schema.Kind as K
37import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ) )
38import qualified Rel8.Schema.Nullability as Type ( Nullify )
39import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
41-- semigroupoids
42import Data.Functor.Apply ( Apply )
43import Rel8.Schema.HTable.MapTable
44import Rel8.FCF
45import GHC.Generics (Generic)
48type HNullify :: K.HTable -> K.HTable
49newtype HNullify table context = HNullify (HMapTable Nullify table context)
50 deriving stock Generic
51 deriving anyclass HTable
55-- | Transform a 'Spec' by allowing it to be @null@.
56data Nullify :: Spec -> Exp Spec
59type instance Eval (Nullify ('Spec labels necessity a)) =
60 'Spec labels necessity (Type.Nullify a)
63instance MapSpec Nullify where
64 mapInfo = \case
65 SSpec{labels, necessity, info, nullability} -> SSpec
66 { labels
67 , necessity
68 , info
69 , nullability = case nullability of
70 Nullable -> Nullable
71 NonNullable -> Nullable
72 }
75hnulls :: HTable t
76 => (forall labels necessity a. ()
77 => context ('Spec labels necessity (Maybe a)))
78 -> HNullify t context
79hnulls null = HNullify $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of
80 SSpec {} -> null
81{-# INLINABLE hnulls #-}
84hnullify :: HTable t
85 => (forall labels necessity a. ()
86 => SSpec ('Spec labels necessity a)
87 -> context ('Spec labels necessity a)
88 -> context ('Spec labels necessity (Type.Nullify a)))
89 -> t context
90 -> HNullify t context
91hnullify nullifier a = HNullify $ htabulate $ \(HMapTableField field) ->
92 case hfield hspecs field of
93 spec@SSpec {} -> nullifier spec (hfield a field)
94{-# INLINABLE hnullify #-}
97hunnullify :: (HTable t, Apply m)
98 => (forall labels necessity a. ()
99 => SSpec ('Spec labels necessity a)
100 -> context ('Spec labels necessity (Type.Nullify a))
101 -> m (context ('Spec labels necessity a)))
102 -> HNullify t context
103 -> m (t context)
104hunnullify unnullifier (HNullify as) =
105 htabulateA $ \field -> case hfield hspecs field of
106 spec@SSpec {} -> case hfield as (HMapTableField field) of
107 a -> unnullifier spec a
108{-# INLINABLE hunnullify #-}