git.iko.soy/rel8
on 593e21b help sign in
rel8/src/Rel8/Schema/Nullability.hs
131 lines 3.7 kB history raw
1{-# language ConstraintKinds #-}
2{-# language DataKinds #-}
3{-# language FlexibleContexts #-}
4{-# language FlexibleInstances #-}
5{-# language GADTs #-}
6{-# language MultiParamTypeClasses #-}
7{-# language RankNTypes #-}
8{-# language StandaloneKindSignatures #-}
9{-# language TypeFamilies #-}
10{-# language UndecidableInstances #-}
11{-# language UndecidableSuperClasses #-}
13module Rel8.Schema.Nullability
14 ( Nullify, Unnullify
15 , NotNull
16 , Homonullable
17 , Nullability( Nullable, NonNullable )
18 , HasNullability, nullabilization
19 , Sql, fromSql, mapSql, toSql
20 )
21where
23-- base
24import Data.Kind ( Constraint, Type )
25import Prelude
27-- rel8
28import Rel8.Schema.Dict ( Dict( Dict ) )
31type IsMaybe :: Type -> Bool
32type family IsMaybe a where
33 IsMaybe (Maybe _) = 'True
34 IsMaybe _ = 'False
37type Unnullify' :: Bool -> Type -> Type
38type family Unnullify' isMaybe ma where
39 Unnullify' 'False a = a
40 Unnullify' 'True (Maybe a) = a
43type Unnullify :: Type -> Type
44type Unnullify a = Unnullify' (IsMaybe a) a
47type Nullify' :: Bool -> Type -> Type
48type family Nullify' isMaybe a where
49 Nullify' 'False a = a
50 Nullify' 'True a = Maybe a
53type Nullify :: Type -> Type
54type Nullify a = Maybe (Unnullify a)
57-- | @nullify a@ means @a@ cannot take @null@ as a value.
58type NotNull :: Type -> Constraint
59class (HasNullability a, IsMaybe a ~ 'False) => NotNull a
60instance (HasNullability a, IsMaybe a ~ 'False) => NotNull a
63-- | @Homonullable a b@ means that both @a@ and @b@ can be @null@, or neither
64-- @a@ or @b@ can be @null@.
65type Homonullable :: Type -> Type -> Constraint
66class IsMaybe a ~ IsMaybe b => Homonullable a b
67instance IsMaybe a ~ IsMaybe b => Homonullable a b
70type Nullability :: Type -> Type
71data Nullability a where
72 NonNullable :: NotNull a => Nullability a
73 Nullable :: NotNull a => Nullability (Maybe a)
76type HasNullability' :: Bool -> Type -> Constraint
77class
78 ( IsMaybe a ~ isMaybe
79 , IsMaybe (Unnullify a) ~ 'False
80 , Nullify' isMaybe (Unnullify a) ~ a
81 ) => HasNullability' isMaybe a
82 where
83 nullabilization' :: Nullability a
86instance IsMaybe a ~ 'False => HasNullability' 'False a where
87 nullabilization' = NonNullable
90instance IsMaybe a ~ 'False => HasNullability' 'True (Maybe a) where
91 nullabilization' = Nullable
94-- | @HasNullability a@ means that @rel8@ is able to check if the type @a@ is a
95-- type that can take @null@ values or not.
96type HasNullability :: Type -> Constraint
97class HasNullability' (IsMaybe a) a => HasNullability a
98instance HasNullability' (IsMaybe a) a => HasNullability a
101nullabilization :: HasNullability a => Nullability a
102nullabilization = nullabilization'
105-- | The @Sql@ type class describes both null and not null database values,
106-- constrained by a specific class.
107--
108-- For example, if you see @Sql DBEq a@, this means any database type that
109-- supports equality, and @a@ can either be exactly an @a@, or it could also be
110-- @Maybe a@.
111type Sql :: (Type -> Constraint) -> Type -> Constraint
112class (constraint (Unnullify a), HasNullability a) => Sql constraint a
113instance (constraint (Unnullify a), HasNullability a) => Sql constraint a
116fromSql :: Dict (Sql constraint) a -> (Nullability a, Dict constraint (Unnullify a))
117fromSql Dict = (nullabilization, Dict)
118{-# INLINABLE fromSql #-}
121mapSql :: ()
122 => (forall x. Dict constraint x -> Dict constraint' x)
123 -> Dict (Sql constraint) a -> Dict (Sql constraint') a
124mapSql f dict = case fromSql dict of
125 (nullability, dict') -> toSql nullability (f dict')
128toSql :: Nullability a -> Dict constraint (Unnullify a) -> Dict (Sql constraint) a
129toSql NonNullable Dict = Dict
130toSql Nullable Dict = Dict
131{-# INLINABLE toSql #-}