git.iko.soy/rel8
on fb4e1a5 help sign in
rel8/src/Rel8/Schema/Nullability/Internal.hs
142 lines 4.0 kB history raw
1{-# language ConstraintKinds #-}
2{-# language DataKinds #-}
3{-# language FlexibleContexts #-}
4{-# language FlexibleInstances #-}
5{-# language FunctionalDependencies #-}
6{-# language GADTs #-}
7{-# language MultiParamTypeClasses #-}
8{-# language RankNTypes #-}
9{-# language QuantifiedConstraints #-}
10{-# language StandaloneKindSignatures #-}
11{-# language TypeFamilies #-}
12{-# language UndecidableInstances #-}
13{-# language UndecidableSuperClasses #-}
15module Rel8.Schema.Nullability.Internal
16 ( Nullify, Unnullify
17 , NotNull
18 , Homonullable
19 , Nullability( Nullable, NonNullable )
20 , HasNullability, nullabilization
21 , Sql, fromSql, mapSql, toSql
22 )
23where
25-- base
26import Data.Kind ( Constraint, Type )
27import Prelude
29-- rel8
30import Rel8.Opaque ( Opaque )
31import Rel8.Schema.Dict ( Dict( Dict ) )
34type IsMaybe :: Type -> Bool
35type family IsMaybe a where
36 IsMaybe (Maybe _) = 'True
37 IsMaybe _ = 'False
40type Unnullify' :: Bool -> Type -> Type
41type family Unnullify' isMaybe ma where
42 Unnullify' 'False a = a
43 Unnullify' 'True (Maybe a) = a
46type Unnullify :: Type -> Type
47type Unnullify a = Unnullify' (IsMaybe a) a
50type Nullify' :: Bool -> Type -> Type
51type family Nullify' isMaybe a where
52 Nullify' 'False a = a
53 Nullify' 'True a = Maybe a
56type Nullify :: Type -> Type
57type Nullify a = Maybe (Unnullify a)
60-- | @NotNull a@ means @a@ cannot take @null@ as a value.
61type NotNull :: Type -> Constraint
62class (HasNullability a, IsMaybe a ~ 'False) => NotNull a
63instance (HasNullability a, IsMaybe a ~ 'False) => NotNull a
64instance {-# OVERLAPPING #-} NotNull Opaque
67-- | @Homonullable a b@ means that both @a@ and @b@ can be @null@, or neither
68-- @a@ or @b@ can be @null@.
69type Homonullable :: Type -> Type -> Constraint
70class IsMaybe a ~ IsMaybe b => Homonullable a b
71instance IsMaybe a ~ IsMaybe b => Homonullable a b
72instance {-# OVERLAPPING #-} Homonullable Opaque Opaque
75type Nullability :: Type -> Type
76data Nullability a where
77 NonNullable :: NotNull a => Nullability a
78 Nullable :: NotNull a => Nullability (Maybe a)
81type HasNullability' :: Bool -> Type -> Constraint
82class
83 ( IsMaybe a ~ isMaybe
84 , IsMaybe (Unnullify a) ~ 'False
85 , Nullify' isMaybe (Unnullify a) ~ a
86 ) => HasNullability' isMaybe a
87 where
88 nullabilization' :: Nullability a
91instance IsMaybe a ~ 'False => HasNullability' 'False a where
92 nullabilization' = NonNullable
95instance IsMaybe a ~ 'False => HasNullability' 'True (Maybe a) where
96 nullabilization' = Nullable
99-- | @HasNullability a@ means that @rel8@ is able to check if the type @a@ is a
100-- type that can take @null@ values or not.
101type HasNullability :: Type -> Constraint
102class HasNullability' (IsMaybe a) a => HasNullability a
103instance HasNullability' (IsMaybe a) a => HasNullability a
104instance {-# OVERLAPPING #-} HasNullability Opaque
107nullabilization :: HasNullability a => Nullability a
108nullabilization = nullabilization'
111-- | The @Sql@ type class describes both null and not null database values,
112-- constrained by a specific class.
113--
114-- For example, if you see @Sql DBEq a@, this means any database type that
115-- supports equality, and @a@ can either be exactly an @a@, or it could also be
116-- @Maybe a@.
117type Sql :: (Type -> Constraint) -> Type -> Constraint
118class
119 ( (forall c. (forall x. (constraint x => c x)) => Sql c a)
120 , HasNullability a
121 , constraint (Unnullify a)
122 )
123 => Sql constraint a
124instance (constraint (Unnullify a), HasNullability a) => Sql constraint a
127fromSql :: Dict (Sql constraint) a -> (Nullability a, Dict constraint (Unnullify a))
128fromSql Dict = (nullabilization, Dict)
129{-# INLINABLE fromSql #-}
132mapSql :: ()
133 => (forall x. Dict constraint x -> Dict constraint' x)
134 -> Dict (Sql constraint) a -> Dict (Sql constraint') a
135mapSql f dict = case fromSql dict of
136 (nullability, dict') -> toSql nullability (f dict')
139toSql :: Nullability a -> Dict constraint (Unnullify a) -> Dict (Sql constraint) a
140toSql NonNullable Dict = Dict
141toSql Nullable Dict = Dict
142{-# INLINABLE toSql #-}