git.iko.soy/rel8
on 1be93da help sign in
rel8/src/Rel8/Schema/HTable/Nullify.hs
107 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 Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
40-- semigroupoids
41import Data.Functor.Apply ( Apply )
42import Rel8.Schema.HTable.MapTable
43import Rel8.FCF
44import GHC.Generics (Generic)
47type HNullify :: K.HTable -> K.HTable
48newtype HNullify table context = HNullify (HMapTable Nullify table context)
49 deriving stock Generic
50 deriving anyclass HTable
54-- | Transform a 'Spec' by allowing it to be @null@.
55data Nullify :: Spec -> Exp Spec
58type instance Eval (Nullify ('Spec labels necessity dbType _)) =
59 'Spec labels necessity dbType (Maybe dbType)
62instance MapSpec Nullify where
63 mapInfo = \case
64 SSpec{labels, necessity, info, nullability} -> SSpec
65 { labels
66 , necessity
67 , info
68 , nullability = case nullability of
69 Nullable -> Nullable
70 NonNullable -> Nullable
71 }
74hnulls :: HTable t
75 => (forall labels necessity dbType. ()
76 => context ('Spec labels necessity dbType (Maybe dbType)))
77 -> HNullify t context
78hnulls null = HNullify $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of
79 SSpec {} -> null
80{-# INLINABLE hnulls #-}
83hnullify :: HTable t
84 => (forall labels necessity dbType a. ()
85 => SSpec ('Spec labels necessity dbType a)
86 -> context ('Spec labels necessity dbType a)
87 -> context ('Spec labels necessity dbType (Maybe dbType)))
88 -> t context
89 -> HNullify t context
90hnullify nullifier a = HNullify $ htabulate $ \(HMapTableField field) ->
91 case hfield hspecs field of
92 spec@SSpec {} -> nullifier spec (hfield a field)
93{-# INLINABLE hnullify #-}
96hunnullify :: (HTable t, Apply m)
97 => (forall labels necessity dbType a. ()
98 => SSpec ('Spec labels necessity dbType a)
99 -> context ('Spec labels necessity dbType (Maybe dbType))
100 -> m (context ('Spec labels necessity dbType a)))
101 -> HNullify t context
102 -> m (t context)
103hunnullify unnullifier (HNullify as) =
104 htabulateA $ \field -> case hfield hspecs field of
105 spec@SSpec {} -> case hfield as (HMapTableField field) of
106 a -> unnullifier spec a
107{-# INLINABLE hunnullify #-}