git.iko.soy/rel8
on bb078d2 help sign in
rel8/src/Rel8/Schema/Context.hs
131 lines 3.3 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 ( Sql )
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 (spec ~ 'Spec labels necessity dbType a, Sql DBSemigroup a) =>
59 Semigroup (DB spec)
60 where
61 DB a <> DB b = DB (a <> b)
64instance (spec ~ 'Spec labels necessity dbType a, Sql DBMonoid a) =>
65 Monoid (DB spec)
66 where
67 mempty = DB mempty
70type Insertion :: Context
71data Insertion spec where
72 RequiredInsert :: ()
73 => Expr a
74 -> Insertion ('Spec labels 'Required dbType a)
75 OptionalInsert :: ()
76 => Maybe (Expr a)
77 -> Insertion ('Spec labels 'Optional dbType a)
78deriving stock instance Show (Insertion spec)
81instance (spec ~ 'Spec labels necessity dbType a, Sql DBSemigroup a) =>
82 Semigroup (Insertion spec)
83 where
84 RequiredInsert a <> RequiredInsert b = RequiredInsert (a <> b)
85 OptionalInsert ma <> OptionalInsert mb = OptionalInsert (liftA2 (<>) ma mb)
88instance
89 ( spec ~ 'Spec labels necessity dbType a
90 , KnownNecessity necessity
91 , Sql DBMonoid a
92 ) => Monoid (Insertion spec)
93 where
94 mempty = case necessitySing @necessity of
95 SRequired -> RequiredInsert mempty
96 SOptional -> OptionalInsert (Just mempty)
99type Name :: Context
100newtype Name spec = Name String
101 deriving stock Show
102 deriving newtype (IsString, Monoid, Semigroup)
105type Result :: Context
106data Result spec where
107 Result :: a -> Result ('Spec labels necessity dbType a)
108deriving stock instance Show a =>
109 Show (Result ('Spec labels necessity dbType a))
112instance (spec ~ 'Spec labels necessity dbType a, Semigroup a) =>
113 Semigroup (Result spec)
114 where
115 Result a <> Result b = Result (a <> b)
118instance (spec ~ 'Spec labels necessity dbType a, Monoid a) =>
119 Monoid (Result spec)
120 where
121 mempty = Result mempty
124type IsSpecialContext :: Context -> Bool
125type family IsSpecialContext context where
126 IsSpecialContext Aggregation = 'True
127 IsSpecialContext DB = 'True
128 IsSpecialContext Insertion = 'True
129 IsSpecialContext Result = 'True
130 IsSpecialContext Structure = 'True
131 IsSpecialContext _ = 'False