git.iko.soy/rel8
on 7c5422f help sign in
rel8/src/Rel8/Schema/HTable/Nullify.hs
119 lines 3.2 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 , hguard
23 , hnulls
24 , hnullify
25 , hunnullify
26 )
27where
29-- base
30import GHC.Generics ( Generic )
31import Prelude hiding ( null )
33-- rel8
34import Rel8.FCF ( Eval, Exp )
35import Rel8.Schema.HTable ( HTable, hfield, htabulate, htabulateA, hspecs )
36import Rel8.Schema.HTable.MapTable
37 ( HMapTable, HMapTableField( HMapTableField )
38 , MapSpec, mapInfo
39 )
40import qualified Rel8.Schema.Kind as K
41import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
42import qualified Rel8.Schema.Null as Type ( Nullify )
43import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
45-- semigroupoids
46import Data.Functor.Apply ( Apply )
49type HNullify :: K.HTable -> K.HTable
50newtype HNullify table context = HNullify (HMapTable Nullify table context)
51 deriving stock Generic
52 deriving anyclass HTable
55-- | Transform a 'Spec' by allowing it to be @null@.
56data Nullify :: Spec -> Exp Spec
59type instance Eval (Nullify ('Spec a)) =
60 'Spec (Type.Nullify a)
63instance MapSpec Nullify where
64 mapInfo = \case
65 SSpec {nullity, ..} -> SSpec
66 { nullity = case nullity of
67 Null -> Null
68 NotNull -> Null
69 , ..
70 }
73hguard :: HTable t
74 => (forall a. context ('Spec (Maybe a)) -> context ('Spec (Maybe a)))
75 -> HNullify t context -> HNullify t context
76hguard guarder (HNullify as) = HNullify $ htabulate $ \(HMapTableField field) ->
77 case hfield hspecs field of
78 SSpec {nullity} -> case hfield as (HMapTableField field) of
79 a -> case nullity of
80 Null -> guarder a
81 NotNull -> guarder a
84hnulls :: HTable t
85 => (forall a. ()
86 => SSpec ('Spec a)
87 -> context ('Spec (Type.Nullify a)))
88 -> HNullify t context
89hnulls null = HNullify $ htabulate $ \(HMapTableField field) ->
90 case hfield hspecs field of
91 spec@SSpec {} -> null spec
92{-# INLINABLE hnulls #-}
95hnullify :: HTable t
96 => (forall a. ()
97 => SSpec ('Spec a)
98 -> context ('Spec a)
99 -> context ('Spec (Type.Nullify a)))
100 -> t context
101 -> HNullify t context
102hnullify nullifier a = HNullify $ htabulate $ \(HMapTableField field) ->
103 case hfield hspecs field of
104 spec@SSpec {} -> nullifier spec (hfield a field)
105{-# INLINABLE hnullify #-}
108hunnullify :: (HTable t, Apply m)
109 => (forall a. ()
110 => SSpec ('Spec a)
111 -> context ('Spec (Type.Nullify a))
112 -> m (context ('Spec a)))
113 -> HNullify t context
114 -> m (t context)
115hunnullify unnullifier (HNullify as) =
116 htabulateA $ \field -> case hfield hspecs field of
117 spec@SSpec {} -> case hfield as (HMapTableField field) of
118 a -> unnullifier spec a
119{-# INLINABLE hunnullify #-}