git.iko.soy/rel8
on 032242f help sign in
rel8/src/Rel8/Schema/HTable/Nullify.hs
117 lines 3.3 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 , hproject
27 )
28where
30-- base
31import Data.Kind ( Type )
32import GHC.Generics ( Generic )
33import Prelude hiding ( null )
35-- rel8
36import Rel8.FCF ( Eval, Exp )
37import Rel8.Schema.HTable ( HTable, hfield, htabulate, htabulateA, hspecs )
38import Rel8.Schema.HTable.MapTable
39 ( HMapTable, HMapTableField( HMapTableField )
40 , MapSpec, mapInfo
41 )
42import qualified Rel8.Schema.HTable.MapTable as HMapTable ( hproject )
43import qualified Rel8.Schema.Kind as K
44import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
45import qualified Rel8.Schema.Null as Type ( Nullify )
46import Rel8.Schema.Spec ( Spec(..) )
48-- semigroupoids
49import Data.Functor.Apply ( Apply )
52type HNullify :: K.HTable -> K.HTable
53newtype HNullify table context = HNullify (HMapTable Nullify table context)
54 deriving stock Generic
55 deriving anyclass HTable
58-- | Transform a 'Type' by allowing it to be @null@.
59data Nullify :: Type -> Exp Type
60type instance Eval (Nullify a) = Type.Nullify a
63instance MapSpec Nullify where
64 mapInfo = \case
65 Spec {nullity, ..} -> Spec
66 { nullity = case nullity of
67 Null -> Null
68 NotNull -> Null
69 , ..
70 }
73hguard :: HTable t
74 => (forall a. context (Maybe a) -> context (Maybe a))
75 -> HNullify t context -> HNullify t context
76hguard guarder (HNullify as) = HNullify $ htabulate $ \(HMapTableField field) ->
77 case hfield hspecs field of
78 Spec {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. Spec a -> context (Type.Nullify a))
86 -> HNullify t context
87hnulls null = HNullify $ htabulate $ \(HMapTableField field) ->
88 case hfield hspecs field of
89 spec@Spec {} -> null spec
90{-# INLINABLE hnulls #-}
93hnullify :: HTable t
94 => (forall a. Spec a -> context a -> context (Type.Nullify a))
95 -> t context
96 -> HNullify t context
97hnullify nullifier a = HNullify $ htabulate $ \(HMapTableField field) ->
98 case hfield hspecs field of
99 spec@Spec {} -> nullifier spec (hfield a field)
100{-# INLINABLE hnullify #-}
103hunnullify :: (HTable t, Apply m)
104 => (forall a. Spec a -> context (Type.Nullify a) -> m (context a))
105 -> HNullify t context
106 -> m (t context)
107hunnullify unnullifier (HNullify as) =
108 htabulateA $ \field -> case hfield hspecs field of
109 spec@Spec {} -> case hfield as (HMapTableField field) of
110 a -> unnullifier spec a
111{-# INLINABLE hunnullify #-}
114hproject :: ()
115 => (forall ctx. t ctx -> t' ctx)
116 -> HNullify t context -> HNullify t' context
117hproject f (HNullify a) = HNullify (HMapTable.hproject f a)