git.iko.soy/rel8
on fce7213 help sign in
rel8/src/Rel8/Schema/Context.hs
144 lines 3.5 kB history raw
1{-# language DataKinds #-}
2{-# language DerivingStrategies #-}
3{-# language FlexibleInstances #-}
4{-# language GADTs #-}
5{-# language GeneralizedNewtypeDeriving #-}
6{-# language ScopedTypeVariables #-}
7{-# language StandaloneDeriving #-}
8{-# language StandaloneKindSignatures #-}
9{-# language TypeApplications #-}
10{-# language TypeFamilies #-}
11{-# language UndecidableInstances #-}
13module Rel8.Schema.Context
14 ( Aggregation( Aggregation )
15 , DB( DB, unDB )
16 , Insertion( RequiredInsert, OptionalInsert )
17 , Name( Name )
18 , Result( Result )
19 , IsSpecialContext
20 )
21where
23-- base
24import Control.Applicative ( liftA2 )
25import Data.String ( IsString )
26import Prelude
28-- rel8
29import Rel8.Aggregate ( Aggregate )
30import Rel8.Expr ( Expr )
31import Rel8.Kind.Necessity
32 ( Necessity( Optional, Required )
33 , SNecessity( SOptional, SRequired )
34 , KnownNecessity, necessitySing
35 )
36import Rel8.Schema.Nullability ( Nullabilizes )
37import Rel8.Schema.Spec ( Context, Spec( Spec ) )
38import Rel8.Schema.Structure ( Structure )
39import Rel8.Type.Monoid ( DBMonoid )
40import Rel8.Type.Semigroup ( DBSemigroup )
43type Aggregation :: Context
44data Aggregation spec where
45 Aggregation :: ()
46 => Aggregate (Expr a)
47 -> Aggregation ('Spec labels necessity dbType a)
50type DB :: Context
51data DB spec where
52 DB :: ()
53 => { unDB :: Expr a }
54 -> DB ('Spec labels necessity dbType a)
55deriving stock instance Show (DB spec)
58instance
59 ( spec ~ 'Spec labels necessity dbType a
60 , DBSemigroup dbType
61 , Nullabilizes dbType a
62 ) =>
63 Semigroup (DB spec)
64 where
65 DB a <> DB b = DB (a <> b)
68instance
69 ( spec ~ 'Spec labels necessity dbType a
70 , DBMonoid dbType
71 , Nullabilizes dbType a
72 ) =>
73 Monoid (DB spec)
74 where
75 mempty = DB mempty
78type Insertion :: Context
79data Insertion spec where
80 RequiredInsert :: ()
81 => Expr a
82 -> Insertion ('Spec labels 'Required dbType a)
83 OptionalInsert :: ()
84 => Maybe (Expr a)
85 -> Insertion ('Spec labels 'Optional dbType a)
86deriving stock instance Show (Insertion spec)
89instance
90 ( spec ~ 'Spec labels necessity dbType a
91 , DBSemigroup dbType
92 , Nullabilizes dbType a
93 ) =>
94 Semigroup (Insertion spec)
95 where
96 RequiredInsert a <> RequiredInsert b = RequiredInsert (a <> b)
97 OptionalInsert ma <> OptionalInsert mb = OptionalInsert (liftA2 (<>) ma mb)
100instance
101 ( spec ~ 'Spec labels necessity dbType a
102 , KnownNecessity necessity
103 , DBMonoid dbType
104 , Nullabilizes dbType a
105 ) => Monoid (Insertion spec)
106 where
107 mempty = case necessitySing @necessity of
108 SRequired -> RequiredInsert mempty
109 SOptional -> OptionalInsert (Just mempty)
112type Name :: Context
113newtype Name spec = Name String
114 deriving stock Show
115 deriving newtype (IsString, Monoid, Semigroup)
118type Result :: Context
119data Result spec where
120 Result :: a -> Result ('Spec labels necessity dbType a)
121deriving stock instance Show a =>
122 Show (Result ('Spec labels necessity dbType a))
125instance (spec ~ 'Spec labels necessity dbType a, Semigroup a) =>
126 Semigroup (Result spec)
127 where
128 Result a <> Result b = Result (a <> b)
131instance (spec ~ 'Spec labels necessity dbType a, Monoid a) =>
132 Monoid (Result spec)
133 where
134 mempty = Result mempty
137type IsSpecialContext :: Context -> Bool
138type family IsSpecialContext context where
139 IsSpecialContext Aggregation = 'True
140 IsSpecialContext DB = 'True
141 IsSpecialContext Insertion = 'True
142 IsSpecialContext Result = 'True
143 IsSpecialContext Structure = 'True
144 IsSpecialContext _ = 'False