git.iko.soy/rel8
on ca7aaef help sign in
rel8/src/Rel8/Schema/Nullability/Internal.hs
137 lines 3.7 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)
60type NotNull :: Type -> Constraint
61class (HasNullability a, IsMaybe a ~ 'False) => NotNull a
62instance (HasNullability a, IsMaybe a ~ 'False) => NotNull a
63instance {-# OVERLAPPING #-} NotNull Opaque
66type Homonullable :: Type -> Type -> Constraint
67class IsMaybe a ~ IsMaybe b => Homonullable a b
68instance IsMaybe a ~ IsMaybe b => Homonullable a b
69instance {-# OVERLAPPING #-} Homonullable Opaque Opaque
72type Nullability :: Type -> Type
73data Nullability a where
74 NonNullable :: NotNull a => Nullability a
75 Nullable :: NotNull a => Nullability (Maybe a)
78type HasNullability' :: Bool -> Type -> Constraint
79class
80 ( IsMaybe a ~ isMaybe
81 , IsMaybe (Unnullify a) ~ 'False
82 , Nullify' isMaybe (Unnullify a) ~ a
83 ) => HasNullability' isMaybe a
84 where
85 nullabilization' :: Nullability a
88instance IsMaybe a ~ 'False => HasNullability' 'False a where
89 nullabilization' = NonNullable
92instance IsMaybe a ~ 'False => HasNullability' 'True (Maybe a) where
93 nullabilization' = Nullable
96type HasNullability :: Type -> Constraint
97class HasNullability' (IsMaybe a) a => HasNullability a
98instance HasNullability' (IsMaybe a) a => HasNullability a
99instance {-# OVERLAPPING #-} HasNullability Opaque
102nullabilization :: HasNullability a => Nullability a
103nullabilization = nullabilization'
106-- | The @Sql@ type class describes both null and not null database values,
107-- constrained by a specific class.
108--
109-- For example, if you see @Sql DBEq a@, this means any database type that
110-- supports equality, and @a@ can either be exactly an @a@, or it could also be
111-- @Maybe a@.
112type Sql :: (Type -> Constraint) -> Type -> Constraint
113class
114 ( (forall c. (forall x. (constraint x => c x)) => Sql c a)
115 , HasNullability a
116 , constraint (Unnullify a)
117 )
118 => Sql constraint a
119instance (constraint (Unnullify a), HasNullability a) => Sql constraint a
122fromSql :: Dict (Sql constraint) a -> (Nullability a, Dict constraint (Unnullify a))
123fromSql Dict = (nullabilization, Dict)
124{-# INLINABLE fromSql #-}
127mapSql :: ()
128 => (forall x. Dict constraint x -> Dict constraint' x)
129 -> Dict (Sql constraint) a -> Dict (Sql constraint') a
130mapSql f dict = case fromSql dict of
131 (nullability, dict') -> toSql nullability (f dict')
134toSql :: Nullability a -> Dict constraint (Unnullify a) -> Dict (Sql constraint) a
135toSql NonNullable Dict = Dict
136toSql Nullable Dict = Dict
137{-# INLINABLE toSql #-}