git.iko.soy/rel8
on 00a36f5 help sign in
rel8/src/Rel8/Schema/Column.hs
142 lines 3.7 kB history raw
1{-# language DataKinds #-}
2{-# language TypeFamilies #-}
3{-# language StandaloneKindSignatures #-}
5module Rel8.Schema.Column
6 ( Column, Default, Label
7 , HEither
8 , HList
9 , HMaybe
10 , HNonEmpty
11 , HThese
12 )
13where
15-- base
16import Data.Functor.Identity ( Identity )
17import Data.Kind ( Type )
18import Data.List.NonEmpty ( NonEmpty )
19import GHC.TypeLits ( Symbol )
20import Prelude
22-- rel8
23import Rel8.Kind.Labels ( Labels )
24import Rel8.Kind.Necessity ( Necessity( Required, Optional ) )
25import Rel8.Schema.Context ( IsSpecialContext )
26import Rel8.Schema.Field ( Field )
27import qualified Rel8.Schema.Kind as K
28import Rel8.Schema.Nullability ( Unnullify )
29import Rel8.Schema.Structure
30 ( Structure
31 , Shape( Either, List, Maybe, NonEmpty, These )
32 , Shape1
33 , Shape2
34 )
35import Rel8.Table.Either ( EitherTable )
36import Rel8.Table.List ( ListTable )
37import Rel8.Table.Maybe ( MaybeTable )
38import Rel8.Table.NonEmpty ( NonEmptyTable )
39import Rel8.Table.These ( TheseTable )
41-- these
42import Data.These ( These )
45type Label :: Symbol -> Type -> Type
46data Label label a
49type Default :: Type -> Type
50data Default a
53type GetLabel :: Type -> Labels
54type family GetLabel a where
55 GetLabel (Label label _) = '[label]
56 GetLabel _ = '[]
59type UnwrapLabel :: Type -> Type
60type family UnwrapLabel a where
61 UnwrapLabel (Label _ a) = a
62 UnwrapLabel a = a
65type GetNecessity :: Type -> Necessity
66type family GetNecessity a where
67 GetNecessity (Default _) = 'Optional
68 GetNecessity _ = 'Required
71type UnwrapDefault :: Type -> Type
72type family UnwrapDefault a where
73 UnwrapDefault (Default a) = a
74 UnwrapDefault a = a
77type Column :: K.Context -> Type -> Type
78type Column context a =
79 Field context (GetLabel a)
80 (GetNecessity (UnwrapLabel a))
81 (Unnullify (UnwrapDefault (UnwrapLabel a)))
82 (UnwrapDefault (UnwrapLabel a))
85type IHEither :: Bool -> K.Context -> Type -> Type -> Type
86type family IHEither isSpecialContext context where
87 IHEither 'False _ = EitherTable
88 IHEither 'True Identity = Either
89 IHEither 'True Structure = Shape2 'Either
90 IHEither 'True _ = EitherTable
93type IHList :: Bool -> K.Context -> Type -> Type
94type family IHList isSpecialContext context where
95 IHList 'False _ = ListTable
96 IHList 'True Identity = []
97 IHList 'True Structure = Shape1 'List
98 IHList 'True _ = ListTable
101type IHMaybe :: Bool -> K.Context -> Type -> Type
102type family IHMaybe isSpecialContext context where
103 IHMaybe 'False _ = MaybeTable
104 IHMaybe 'True Identity = Maybe
105 IHMaybe 'True Structure = Shape1 'Maybe
106 IHMaybe 'True _ = MaybeTable
109type IHNonEmpty :: Bool -> K.Context -> Type -> Type
110type family IHNonEmpty isSpecialContext context where
111 IHNonEmpty 'False _ = NonEmptyTable
112 IHNonEmpty 'True Identity = NonEmpty
113 IHNonEmpty 'True Structure = Shape1 'NonEmpty
114 IHNonEmpty 'True _ = NonEmptyTable
117type IHThese :: Bool -> K.Context -> Type -> Type -> Type
118type family IHThese isSpecialContext context where
119 IHThese 'False _ = TheseTable
120 IHThese 'True Identity = These
121 IHThese 'True Structure = Shape2 'These
122 IHThese 'True _ = TheseTable
125type HEither :: K.Context -> Type -> Type -> Type
126type HEither context = IHEither (IsSpecialContext context) context
129type HList :: K.Context -> Type -> Type
130type HList context = IHList (IsSpecialContext context) context
133type HMaybe :: K.Context -> Type -> Type
134type HMaybe context = IHMaybe (IsSpecialContext context) context
137type HNonEmpty :: K.Context -> Type -> Type
138type HNonEmpty context = IHNonEmpty (IsSpecialContext context) context
141type HThese :: K.Context -> Type -> Type -> Type
142type HThese context = IHThese (IsSpecialContext context) context