git.iko.soy/rel8
on f47423e help sign in
rel8/src/Rel8/Schema/HTable/Nullify.hs
109 lines 3.0 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 Data.Kind ( Type )
31import GHC.Generics ( Generic )
32import Prelude hiding ( null )
34-- rel8
35import Rel8.FCF ( Eval, Exp )
36import Rel8.Schema.HTable ( HTable, hfield, htabulate, htabulateA, hspecs )
37import Rel8.Schema.HTable.MapTable
38 ( HMapTable, HMapTableField( HMapTableField )
39 , MapSpec, mapInfo
40 )
41import qualified Rel8.Schema.Kind as K
42import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
43import qualified Rel8.Schema.Null as Type ( Nullify )
44import Rel8.Schema.Spec ( Spec(..) )
46-- semigroupoids
47import Data.Functor.Apply ( Apply )
50type HNullify :: K.HTable -> K.HTable
51newtype HNullify table context = HNullify (HMapTable Nullify table context)
52 deriving stock Generic
53 deriving anyclass HTable
56-- | Transform a 'Type' by allowing it to be @null@.
57data Nullify :: Type -> Exp Type
58type instance Eval (Nullify a) = Type.Nullify a
61instance MapSpec Nullify where
62 mapInfo = \case
63 Spec {nullity, ..} -> Spec
64 { nullity = case nullity of
65 Null -> Null
66 NotNull -> Null
67 , ..
68 }
71hguard :: HTable t
72 => (forall a. context (Maybe a) -> context (Maybe a))
73 -> HNullify t context -> HNullify t context
74hguard guarder (HNullify as) = HNullify $ htabulate $ \(HMapTableField field) ->
75 case hfield hspecs field of
76 Spec {nullity} -> case hfield as (HMapTableField field) of
77 a -> case nullity of
78 Null -> guarder a
79 NotNull -> guarder a
82hnulls :: HTable t
83 => (forall a. Spec a -> context (Type.Nullify a))
84 -> HNullify t context
85hnulls null = HNullify $ htabulate $ \(HMapTableField field) ->
86 case hfield hspecs field of
87 spec@Spec {} -> null spec
88{-# INLINABLE hnulls #-}
91hnullify :: HTable t
92 => (forall a. Spec a -> context a -> context (Type.Nullify a))
93 -> t context
94 -> HNullify t context
95hnullify nullifier a = HNullify $ htabulate $ \(HMapTableField field) ->
96 case hfield hspecs field of
97 spec@Spec {} -> nullifier spec (hfield a field)
98{-# INLINABLE hnullify #-}
101hunnullify :: (HTable t, Apply m)
102 => (forall a. Spec a -> context (Type.Nullify a) -> m (context a))
103 -> HNullify t context
104 -> m (t context)
105hunnullify unnullifier (HNullify as) =
106 htabulateA $ \field -> case hfield hspecs field of
107 spec@Spec {} -> case hfield as (HMapTableField field) of
108 a -> unnullifier spec a
109{-# INLINABLE hunnullify #-}