git.iko.soy/rel8
on master help sign in
Simplify Spec to just labels, necessity and type
53616d0Shane O'Brien
src/Rel8.hs+1−1
compare with master
unifiedsplit
@@ -233,7 +233,7 @@ module Rel8
233 -- TODO
233 -- TODO
234 -- These need organizing, but are reachable from Rel8's documentation so we
234 -- These need organizing, but are reachable from Rel8's documentation so we
235 -- do need to export and document them.
235 -- do need to export and document them.
236− , Nullabilizes
236+ , HasNullability
237 , HTable
237 , HTable
238 , Labelable
238 , Labelable
239 , Context
239 , Context
src/Rel8/Aggregate.hs+1−1
@@ -70,7 +70,7 @@ instance Interpretation Aggregate where
70 data Col Aggregate _spec where
70 data Col Aggregate _spec where
71 Aggregation :: ()
71 Aggregation :: ()
72 => Aggregate (Expr a)
72 => Aggregate (Expr a)
73− -> Col Aggregate ('Spec labels necessity db a)
73+ -> Col Aggregate ('Spec labels necessity a)
74
74
75
75
76instance Table Expr a => Table Aggregate (Aggregate a) where
76instance Table Expr a => Table Aggregate (Aggregate a) where
src/Rel8/Expr.hs+1−3
@@ -108,9 +108,7 @@ instance Sql DBFractional a => Fractional (Expr a) where
108
108
109instance Interpretation Expr where
109instance Interpretation Expr where
110 data Col Expr _spec where
110 data Col Expr _spec where
111− DB :: ()
112− => { unDB :: Expr a }
113− -> Col Expr ('Spec labels necessity db a)
111+ DB :: {unDB :: Expr a} -> Col Expr ('Spec labels necessity a)
114
112
115
113
116instance Sql DBType a => Table Expr (Expr a) where
114instance Sql DBType a => Table Expr (Expr a) where
src/Rel8/Expr/Aggregate.hs+2−7
@@ -14,7 +14,6 @@ module Rel8.Expr.Aggregate
14 , stringAgg
14 , stringAgg
15 , groupByExpr
15 , groupByExpr
16 , listAggExpr, nonEmptyAggExpr
16 , listAggExpr, nonEmptyAggExpr
17− , sgroupByExpr
18 )
17 )
19where
18where
20
19
@@ -38,7 +37,7 @@ import Rel8.Expr.Opaleye
38 )
37 )
39import Rel8.Expr.Null ( null )
38import Rel8.Expr.Null ( null )
40import Rel8.Expr.Serialize ( litExpr )
39import Rel8.Expr.Serialize ( litExpr )
41−import Rel8.Schema.Nullability ( Nullability, Sql, nullabilization )
40+import Rel8.Schema.Nullability ( Sql )
42import Rel8.Type.Array ( fromPrimArray )
41import Rel8.Type.Array ( fromPrimArray )
43import Rel8.Type.Eq ( DBEq )
42import Rel8.Type.Eq ( DBEq )
44import Rel8.Type.Num ( DBNum )
43import Rel8.Type.Num ( DBNum )
@@ -150,7 +149,7 @@ stringAgg delimiter =
150
149
151-- | Aggregate a value by grouping by it.
150-- | Aggregate a value by grouping by it.
152groupByExpr :: Sql DBEq a => Expr a -> Aggregate (Expr a)
151groupByExpr :: Sql DBEq a => Expr a -> Aggregate (Expr a)
153−groupByExpr = sgroupByExpr nullabilization
152+groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Nothing
154
153
155
154
156listAggExpr :: Expr a -> Aggregate (Expr [a])
155listAggExpr :: Expr a -> Aggregate (Expr [a])
@@ -173,7 +172,3 @@ nonEmptyAggExpr = unsafeMakeAggregate toPrimExpr from $ Just
173 }
172 }
174 where
173 where
175 from = fromPrimExpr . fromPrimArray
174 from = fromPrimExpr . fromPrimArray
176−
177−
178−sgroupByExpr :: DBEq db => Nullability db a -> Expr a -> Aggregate (Expr a)
179−sgroupByExpr _ = unsafeMakeAggregate toPrimExpr fromPrimExpr Nothing
src/Rel8/Expr/Array.hs+1−1
@@ -39,7 +39,7 @@ sappend1 :: Expr (NonEmpty a) -> Expr (NonEmpty a) -> Expr (NonEmpty a)
39sappend1 = zipPrimExprsWith (zipPrimArraysWith (Opaleye.BinExpr (Opaleye.:||)))
39sappend1 = zipPrimExprsWith (zipPrimArraysWith (Opaleye.BinExpr (Opaleye.:||)))
40
40
41
41
42−sempty :: Nullability t a -> TypeInformation t -> Expr [a]
42+sempty :: Nullability a -> TypeInformation (Unnullify a) -> Expr [a]
43sempty _ info = fromPrimExpr $ array info []
43sempty _ info = fromPrimExpr $ array info []
44
44
45
45
src/Rel8/Expr/Eq.hs+23−34
@@ -1,13 +1,14 @@
1{-# language FlexibleContexts #-}
1{-# language FlexibleContexts #-}
2{-# language GADTs #-}
2{-# language GADTs #-}
3{-# language LambdaCase #-}
3{-# language LambdaCase #-}
4+{-# language ScopedTypeVariables #-}
5+{-# language TypeApplications #-}
4{-# language ViewPatterns #-}
6{-# language ViewPatterns #-}
5
7
6{-# options_ghc -fno-warn-redundant-constraints #-}
8{-# options_ghc -fno-warn-redundant-constraints #-}
7
9
8module Rel8.Expr.Eq
10module Rel8.Expr.Eq
9− ( seq, sne
10− , (==.), (/=.)
11+ ( (==.), (/=.)
11 , (==?), (/=?)
12 , (==?), (/=?)
12 , in_
13 , in_
13 )
14 )
@@ -16,7 +17,7 @@ where
16-- base
17-- base
17import Data.Foldable ( toList )
18import Data.Foldable ( toList )
18import Data.List.NonEmpty ( nonEmpty )
19import Data.List.NonEmpty ( nonEmpty )
19−import Prelude hiding ( seq, sin )
20+import Prelude
20
21
21-- opaleye
22-- opaleye
22import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
23import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
@@ -41,39 +42,16 @@ ne :: DBEq a => Expr a -> Expr a -> Expr Bool
41ne = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:<>))
42ne = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:<>))
42
43
43
44
44−seq :: DBEq db => Nullability db a -> Expr a -> Expr a -> Expr Bool
45−seq = \case
46− Nullable -> \ma mb -> isNull ma &&. isNull mb ||. ma ==? mb
47− NonNullable -> eq
48−
49−
50−sne :: DBEq db => Nullability db a -> Expr a -> Expr a -> Expr Bool
51−sne = \case
52− Nullable -> \ma mb -> isNull ma `ne` isNull mb ||. ma /=? mb
53− NonNullable -> ne
54−
55−
56−sin :: (DBEq db, Foldable f)
57− => Nullability db a -> Expr a -> f (Expr a) -> Expr Bool
58−sin nullability a (toList -> as) = case nullability of
59− Nullable -> or_ $ map (seq Nullable a) as
60− NonNullable -> case nonEmpty as of
61− Nothing -> false
62− Just xs ->
63− fromPrimExpr $
64− Opaleye.BinExpr Opaleye.OpIn
65− (toPrimExpr a)
66− (Opaleye.ListExpr (toPrimExpr <$> xs))
67−
68−
69-- | Compare two expressions for equality.
45-- | Compare two expressions for equality.
70--
46--
71-- This corresponds to the SQL @IS NOT DISTINCT FROM@ operator, and will equate
47-- This corresponds to the SQL @IS NOT DISTINCT FROM@ operator, and will equate
72-- @null@ values as @true@. This differs from @=@ which would return @null@.
48-- @null@ values as @true@. This differs from @=@ which would return @null@.
73-- This operator matches Haskell's '==' operator. For an operator identical to
49-- This operator matches Haskell's '==' operator. For an operator identical to
74-- SQL @=@, see '==?'.
50-- SQL @=@, see '==?'.
75−(==.) :: Sql DBEq a => Expr a -> Expr a -> Expr Bool
51+(==.) :: forall a. Sql DBEq a => Expr a -> Expr a -> Expr Bool
76−(==.) = seq nullabilization
52+(==.) = case nullabilization @a of
53+ Nullable -> \ma mb -> isNull ma &&. isNull mb ||. ma ==? mb
54+ NonNullable -> eq
77infix 4 ==.
55infix 4 ==.
78
56
79
57
@@ -83,8 +61,10 @@ infix 4 ==.
83-- @false@ when comparing two @null@ values. This differs from ordinary @=@
61-- @false@ when comparing two @null@ values. This differs from ordinary @=@
84-- which would return @null@. This operator is closer to Haskell's '=='
62-- which would return @null@. This operator is closer to Haskell's '=='
85-- operator. For an operator identical to SQL @=@, see '/=?'.
63-- operator. For an operator identical to SQL @=@, see '/=?'.
86−(/=.) :: Sql DBEq a => Expr a -> Expr a -> Expr Bool
64+(/=.) :: forall a. Sql DBEq a => Expr a -> Expr a -> Expr Bool
87−(/=.) = sne nullabilization
65+(/=.) = case nullabilization @a of
66+ Nullable -> \ma mb -> isNull ma `ne` isNull mb ||. ma /=? mb
67+ NonNullable -> ne
88infix 4 /=.
68infix 4 /=.
89
69
90
70
@@ -128,5 +108,14 @@ infix 4 /=?
128--
108--
129-- >>> select c $ return $ lit (42 :: Int32) `in_` [ lit x | x <- [1..5] ]
109-- >>> select c $ return $ lit (42 :: Int32) `in_` [ lit x | x <- [1..5] ]
130-- [False]
110-- [False]
111+in_ :: forall a f. (Sql DBEq a, Foldable f)
131−in_ :: (Sql DBEq a, Foldable f) => Expr a -> f (Expr a) -> Expr Bool
112+ => Expr a -> f (Expr a) -> Expr Bool
132−in_ = sin nullabilization
113+in_ a (toList -> as) = case nullabilization @a of
114+ Nullable -> or_ $ map (a ==.) as
115+ NonNullable -> case nonEmpty as of
116+ Nothing -> false
117+ Just xs ->
118+ fromPrimExpr $
119+ Opaleye.BinExpr Opaleye.OpIn
120+ (toPrimExpr a)
121+ (Opaleye.ListExpr (toPrimExpr <$> xs))
src/Rel8/Expr/Null.hs+4−5
@@ -23,7 +23,7 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
23import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
23import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
24import Rel8.Expr.Bool ( (||.), boolExpr )
24import Rel8.Expr.Bool ( (||.), boolExpr )
25import Rel8.Expr.Opaleye ( scastExpr, mapPrimExpr )
25import Rel8.Expr.Opaleye ( scastExpr, mapPrimExpr )
26−import Rel8.Schema.Nullability ( Nullability( Nullable ), IsMaybe )
26+import Rel8.Schema.Nullability ( IsMaybe )
27import Rel8.Type ( DBType, typeInformation )
27import Rel8.Type ( DBType, typeInformation )
28import Rel8.Type.Information ( TypeInformation )
28import Rel8.Type.Information ( TypeInformation )
29
29
@@ -93,14 +93,13 @@ liftOpNullable f ma mb =
93 (isNull ma ||. isNull mb)
93 (isNull ma ||. isNull mb)
94
94
95
95
96−snull :: Nullability a (Maybe a) -> TypeInformation a -> Expr (Maybe a)
96+snull :: TypeInformation a -> Expr (Maybe a)
97−snull nullability info =
98− scastExpr nullability info $ Expr $ Opaleye.ConstExpr Opaleye.NullLit
97+snull info = scastExpr info $ Expr $ Opaleye.ConstExpr Opaleye.NullLit
99
98
100
99
101-- | Corresponds to SQL @null@.
100-- | Corresponds to SQL @null@.
102null :: (IsMaybe a ~ 'False, DBType a) => Expr (Maybe a)
101null :: (IsMaybe a ~ 'False, DBType a) => Expr (Maybe a)
103−null = snull Nullable typeInformation
102+null = snull typeInformation
104
103
105
104
106unsafeMapNullable :: IsMaybe b ~ 'False
105unsafeMapNullable :: IsMaybe b ~ 'False
src/Rel8/Expr/Opaleye.hs+6−6
@@ -25,26 +25,26 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
25
25
26-- rel8
26-- rel8
27import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
27import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
28−import Rel8.Schema.Nullability ( Nullability, Sql, nullabilization )
28+import Rel8.Schema.Nullability ( Unnullify, Sql )
29import Rel8.Type ( DBType, typeInformation )
29import Rel8.Type ( DBType, typeInformation )
30import Rel8.Type.Information ( TypeInformation(..) )
30import Rel8.Type.Information ( TypeInformation(..) )
31
31
32
32
33castExpr :: Sql DBType a => Expr a -> Expr a
33castExpr :: Sql DBType a => Expr a -> Expr a
34−castExpr = scastExpr nullabilization typeInformation
34+castExpr = scastExpr typeInformation
35
35
36
36
37unsafeCastExpr :: Sql DBType b => Expr a -> Expr b
37unsafeCastExpr :: Sql DBType b => Expr a -> Expr b
38−unsafeCastExpr = sunsafeCastExpr nullabilization typeInformation
38+unsafeCastExpr = sunsafeCastExpr typeInformation
39
39
40
40
41−scastExpr :: Nullability db a -> TypeInformation db -> Expr a -> Expr a
41+scastExpr :: TypeInformation (Unnullify a) -> Expr a -> Expr a
42scastExpr = sunsafeCastExpr
42scastExpr = sunsafeCastExpr
43
43
44
44
45sunsafeCastExpr :: ()
45sunsafeCastExpr :: ()
46− => Nullability db b -> TypeInformation db -> Expr a -> Expr b
46+ => TypeInformation (Unnullify b) -> Expr a -> Expr b
47−sunsafeCastExpr _ TypeInformation {typeName} =
47+sunsafeCastExpr TypeInformation {typeName} =
48 fromPrimExpr . Opaleye.CastExpr typeName . toPrimExpr
48 fromPrimExpr . Opaleye.CastExpr typeName . toPrimExpr
49
49
50
50
src/Rel8/Expr/Ord.hs+17−34
@@ -8,8 +8,7 @@
8{-# options_ghc -fno-warn-redundant-constraints #-}
8{-# options_ghc -fno-warn-redundant-constraints #-}
9
9
10module Rel8.Expr.Ord
10module Rel8.Expr.Ord
11− ( slt, sle, sgt, sge
12− , (<.), (<=.), (>.), (>=.)
11+ ( (<.), (<=.), (>.), (>=.)
13 , (<?), (<=?), (>?), (>=?)
12 , (<?), (<=?), (>?), (>=?)
14 , leastExpr, greatestExpr
13 , leastExpr, greatestExpr
15 )
14 )
@@ -49,59 +48,43 @@ ge :: DBOrd a => Expr a -> Expr a -> Expr Bool
49ge = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:>=))
48ge = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:>=))
50
49
51
50
52−slt :: DBOrd db => Nullability db a -> Expr a -> Expr a -> Expr Bool
53−slt = \case
54− Nullable -> \ma mb -> isNull ma &&. isNonNull mb ||. ma <? mb
55− NonNullable -> lt
56−
57−
58−sle :: DBOrd db => Nullability db a -> Expr a -> Expr a -> Expr Bool
59−sle = \case
60− Nullable -> \ma mb -> isNull ma ||. ma <=? mb
61− NonNullable -> le
62−
63−
64−sgt :: DBOrd db => Nullability db a -> Expr a -> Expr a -> Expr Bool
65−sgt = \case
66− Nullable -> \ma mb -> isNonNull ma &&. isNull mb ||. ma >? mb
67− NonNullable -> gt
68−
69−
70−sge :: DBOrd db => Nullability db a -> Expr a -> Expr a -> Expr Bool
71−sge = \case
72− Nullable -> \ma mb -> isNull mb ||. ma >=? mb
73− NonNullable -> ge
74−
75−
76-- | Corresponds to the SQL @<@ operator. Note that this differs from SQL @<@
51-- | Corresponds to the SQL @<@ operator. Note that this differs from SQL @<@
77-- as @null@ will sort below any other value. For a version of @<@ that exactly
52-- as @null@ will sort below any other value. For a version of @<@ that exactly
78-- matches SQL, see '(<?)'.
53-- matches SQL, see '(<?)'.
79−(<.) :: Sql DBOrd a => Expr a -> Expr a -> Expr Bool
54+(<.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool
80−(<.) = slt nullabilization
55+(<.) = case nullabilization @a of
56+ Nullable -> \ma mb -> isNull ma &&. isNonNull mb ||. ma <? mb
57+ NonNullable -> lt
81infix 4 <.
58infix 4 <.
82
59
83
60
84-- | Corresponds to the SQL @<=@ operator. Note that this differs from SQL @<=@
61-- | Corresponds to the SQL @<=@ operator. Note that this differs from SQL @<=@
85-- as @null@ will sort below any other value. For a version of @<=@ that exactly
62-- as @null@ will sort below any other value. For a version of @<=@ that exactly
86-- matches SQL, see '(<=?)'.
63-- matches SQL, see '(<=?)'.
87−(<=.) :: Sql DBOrd a => Expr a -> Expr a -> Expr Bool
64+(<=.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool
88−(<=.) = sle nullabilization
65+(<=.) = case nullabilization @a of
66+ Nullable -> \ma mb -> isNull ma ||. ma <=? mb
67+ NonNullable -> le
89infix 4 <=.
68infix 4 <=.
90
69
91
70
92-- | Corresponds to the SQL @>@ operator. Note that this differs from SQL @>@
71-- | Corresponds to the SQL @>@ operator. Note that this differs from SQL @>@
93-- as @null@ will sort below any other value. For a version of @>@ that exactly
72-- as @null@ will sort below any other value. For a version of @>@ that exactly
94-- matches SQL, see '(>?)'.
73-- matches SQL, see '(>?)'.
95−(>.) :: Sql DBOrd a => Expr a -> Expr a -> Expr Bool
74+(>.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool
96−(>.) = sgt nullabilization
75+(>.) = case nullabilization @a of
76+ Nullable -> \ma mb -> isNonNull ma &&. isNull mb ||. ma >? mb
77+ NonNullable -> gt
97infix 4 >.
78infix 4 >.
98
79
99
80
100-- | Corresponds to the SQL @>=@ operator. Note that this differs from SQL @>@
81-- | Corresponds to the SQL @>=@ operator. Note that this differs from SQL @>@
101-- as @null@ will sort below any other value. For a version of @>=@ that
82-- as @null@ will sort below any other value. For a version of @>=@ that
102-- exactly matches SQL, see '(>=?)'.
83-- exactly matches SQL, see '(>=?)'.
103−(>=.) :: Sql DBOrd a => Expr a -> Expr a -> Expr Bool
84+(>=.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool
104−(>=.) = sge nullabilization
85+(>=.) = case nullabilization @a of
86+ Nullable -> \ma mb -> isNull mb ||. ma >=? mb
87+ NonNullable -> ge
105infix 4 >=.
88infix 4 >=.
106
89
107
90
src/Rel8/Expr/Serialize.hs+7−6
@@ -22,7 +22,8 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
22import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
22import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
23import Rel8.Expr.Opaleye ( scastExpr )
23import Rel8.Expr.Opaleye ( scastExpr )
24import Rel8.Schema.Nullability
24import Rel8.Schema.Nullability
25+ ( Unnullify
25− ( Nullability( Nullable, NonNullable )
26+ , Nullability( Nullable, NonNullable )
26 , Sql, nullabilization
27 , Sql, nullabilization
27 )
28 )
28import Rel8.Type ( DBType, typeInformation )
29import Rel8.Type ( DBType, typeInformation )
@@ -33,16 +34,16 @@ litExpr :: Sql DBType a => a -> Expr a
33litExpr = slitExpr nullabilization typeInformation
34litExpr = slitExpr nullabilization typeInformation
34
35
35
36
36−slitExpr :: Nullability db a -> TypeInformation db -> a -> Expr a
37+slitExpr :: Nullability a -> TypeInformation (Unnullify a) -> a -> Expr a
37−slitExpr nullable info@TypeInformation {encode} =
38+slitExpr nullability info@TypeInformation {encode} =
38− scastExpr nullable info . Expr . encoder
39+ scastExpr info . Expr . encoder
39 where
40 where
40− encoder = case nullable of
41+ encoder = case nullability of
41 Nullable -> maybe (Opaleye.ConstExpr Opaleye.NullLit) encode
42 Nullable -> maybe (Opaleye.ConstExpr Opaleye.NullLit) encode
42 NonNullable -> encode
43 NonNullable -> encode
43
44
44
45
45−sparseValue :: Nullability db a -> TypeInformation db -> Hasql.Row a
46+sparseValue :: Nullability a -> TypeInformation (Unnullify a) -> Hasql.Row a
46sparseValue nullability TypeInformation {decode, out} = case nullability of
47sparseValue nullability TypeInformation {decode, out} = case nullability of
47 Nullable -> Hasql.column $ Hasql.nullable $ out <$> decode
48 Nullable -> Hasql.column $ Hasql.nullable $ out <$> decode
48 NonNullable -> Hasql.column $ Hasql.nonNullable $ out <$> decode
49 NonNullable -> Hasql.column $ Hasql.nonNullable $ out <$> decode
src/Rel8/Schema/Column.hs−2
@@ -28,7 +28,6 @@ import Rel8.Schema.Field ( Field )
28import Rel8.Schema.Insert ( Insert )
28import Rel8.Schema.Insert ( Insert )
29import qualified Rel8.Schema.Kind as K
29import qualified Rel8.Schema.Kind as K
30import Rel8.Schema.Name ( Name )
30import Rel8.Schema.Name ( Name )
31−import Rel8.Schema.Nullability ( Unnullify )
32import Rel8.Schema.Structure
31import Rel8.Schema.Structure
33 ( Structure
32 ( Structure
34 , Shape( Either, List, Maybe, NonEmpty, These )
33 , Shape( Either, List, Maybe, NonEmpty, These )
@@ -111,7 +110,6 @@ type Column :: K.Context -> Type -> Type
111type Column context a =
110type Column context a =
112 Field context (GetLabel a)
111 Field context (GetLabel a)
113 (GetNecessity (UnwrapLabel a))
112 (GetNecessity (UnwrapLabel a))
114− (Unnullify (UnwrapDefault (UnwrapLabel a)))
115 (UnwrapDefault (UnwrapLabel a))
113 (UnwrapDefault (UnwrapLabel a))
116
114
117
115
src/Rel8/Schema/Context.hs+1−1
@@ -25,4 +25,4 @@ class Interpretation context where
25
25
26instance Interpretation Identity where
26instance Interpretation Identity where
27 data Col Identity _spec where
27 data Col Identity _spec where
28− Result :: a -> Col Identity ('Spec labels necessity db a)
28+ Result :: a -> Col Identity ('Spec labels necessity a)
src/Rel8/Schema/Context/Identity.hs+17−16
@@ -30,7 +30,8 @@ import Rel8.Schema.HTable.Nullify ( hnulls, hnullify, hunnullify )
30import Rel8.Schema.HTable.These ( HTheseTable(..) )
30import Rel8.Schema.HTable.These ( HTheseTable(..) )
31import Rel8.Schema.HTable.Vectorize ( hvectorize, hunvectorize )
31import Rel8.Schema.HTable.Vectorize ( hvectorize, hunvectorize )
32import Rel8.Schema.Nullability
32import Rel8.Schema.Nullability
33+ ( Nullify
33− ( Nullability( Nullable, NonNullable )
34+ , Nullability( Nullable, NonNullable )
34 )
35 )
35import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
36import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
36import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), MaybeTag( IsJust ) )
37import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), MaybeTag( IsJust ) )
@@ -155,23 +156,23 @@ fromHTheseTable HTheseTable {hhereTag, hhere, hthereTag, hthere} =
155{-# INLINABLE fromHTheseTable #-}
156{-# INLINABLE fromHTheseTable #-}
156
157
157
158
158−null :: Col Identity ('Spec labels necessity db (Maybe db))
159+null :: Col Identity ('Spec labels necessity (Maybe a))
159null = Result Nothing
160null = Result Nothing
160
161
161
162
162nullifier :: ()
163nullifier :: ()
163− => SSpec ('Spec labels necessity db a)
164+ => SSpec ('Spec labels necessity a)
164− -> Col Identity ('Spec labels necessity db a)
165+ -> Col Identity ('Spec labels necessity a)
165− -> Col Identity ('Spec labels necessity db (Maybe db))
166+ -> Col Identity ('Spec labels necessity (Nullify a))
166nullifier SSpec {nullability} (Result a) = Result $ case nullability of
167nullifier SSpec {nullability} (Result a) = Result $ case nullability of
167 Nullable -> a
168 Nullable -> a
168 NonNullable -> Just a
169 NonNullable -> Just a
169
170
170
171
171unnullifier :: ()
172unnullifier :: ()
172− => SSpec ('Spec labels necessity db a)
173+ => SSpec ('Spec labels necessity a)
173− -> Col Identity ('Spec labels necessity db (Maybe db))
174+ -> Col Identity ('Spec labels necessity (Nullify a))
174− -> Maybe (Col Identity ('Spec labels necessity db a))
175+ -> Maybe (Col Identity ('Spec labels necessity a))
175unnullifier SSpec {nullability} (Result a) =
176unnullifier SSpec {nullability} (Result a) =
176 case nullability of
177 case nullability of
177 Nullable -> pure $ Result a
178 Nullable -> pure $ Result a
@@ -179,20 +180,20 @@ unnullifier SSpec {nullability} (Result a) =
179
180
180
181
181vectorizer :: Functor f
182vectorizer :: Functor f
182− => SSpec ('Spec labels necessity db a)
183+ => SSpec ('Spec labels necessity a)
183− -> f (Col Identity ('Spec labels necessity db a))
184+ -> f (Col Identity ('Spec labels necessity a))
184− -> Col Identity ('Spec labels necessity (f a) (f a))
185+ -> Col Identity ('Spec labels necessity (f a))
185vectorizer _ = Result . fmap (\(Result a) -> a)
186vectorizer _ = Result . fmap (\(Result a) -> a)
186
187
187
188
188unvectorizer :: Functor f
189unvectorizer :: Functor f
189− => SSpec ('Spec labels necessity db a)
190+ => SSpec ('Spec labels necessity a)
190− -> Col Identity ('Spec labels necessity (f a) (f a))
191+ -> Col Identity ('Spec labels necessity (f a))
191− -> f (Col Identity ('Spec labels necessity db a))
192+ -> f (Col Identity ('Spec labels necessity a))
192unvectorizer _ (Result results) = Result <$> results
193unvectorizer _ (Result results) = Result <$> results
193
194
194
195
195relabel :: ()
196relabel :: ()
196− => HIdentity ('Spec labels necessity db a) (Col Identity)
197+ => HIdentity ('Spec labels necessity a) (Col Identity)
197− -> HIdentity ('Spec relabels necessity db a) (Col Identity)
198+ -> HIdentity ('Spec relabels necessity a) (Col Identity)
198relabel (HIdentity (Result a)) = HIdentity (Result a)
199relabel (HIdentity (Result a)) = HIdentity (Result a)
src/Rel8/Schema/Context/Label.hs+8−8
@@ -23,12 +23,12 @@ import Rel8.Schema.Spec ( Spec( Spec ) )
23type Labelable :: Context -> Constraint
23type Labelable :: Context -> Constraint
24class Interpretation context => Labelable context where
24class Interpretation context => Labelable context where
25 labeler :: ()
25 labeler :: ()
26− => Col context ('Spec labels necessity db a)
26+ => Col context ('Spec labels necessity a)
27− -> Col context ('Spec (label ': labels) necessity db a)
27+ -> Col context ('Spec (label ': labels) necessity a)
28
28
29 unlabeler :: ()
29 unlabeler :: ()
30− => Col context ('Spec (label ': labels) necessity db a)
30+ => Col context ('Spec (label ': labels) necessity a)
31− -> Col context ('Spec labels necessity db a)
31+ -> Col context ('Spec labels necessity a)
32
32
33
33
34instance Labelable Identity where
34instance Labelable Identity where
@@ -39,12 +39,12 @@ instance Labelable Identity where
39type HLabelable :: HContext -> Constraint
39type HLabelable :: HContext -> Constraint
40class HLabelable context where
40class HLabelable context where
41 hlabeler :: ()
41 hlabeler :: ()
42− => context ('Spec labels necessity db a)
42+ => context ('Spec labels necessity a)
43− -> context ('Spec (label ': labels) necessity db a)
43+ -> context ('Spec (label ': labels) necessity a)
44
44
45 hunlabeler :: ()
45 hunlabeler :: ()
46− => context ('Spec (label ': labels) necessity db a)
46+ => context ('Spec (label ': labels) necessity a)
47− -> context ('Spec labels necessity db a)
47+ -> context ('Spec labels necessity a)
48
48
49
49
50instance Labelable context => HLabelable (Col context) where
50instance Labelable context => HLabelable (Col context) where
src/Rel8/Schema/Context/Nullify.hs+15−11
@@ -28,7 +28,11 @@ import Rel8.Kind.Labels ( KnownLabels )
28import Rel8.Kind.Necessity ( Necessity( Required ) )
28import Rel8.Kind.Necessity ( Necessity( Required ) )
29import Rel8.Schema.Context ( Interpretation, Col(..) )
29import Rel8.Schema.Context ( Interpretation, Col(..) )
30import qualified Rel8.Schema.Kind as K
30import qualified Rel8.Schema.Kind as K
31+import Rel8.Schema.Nullability
32+ ( Nullify
31−import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ), Sql )
33+ , Nullability( Nullable, NonNullable )
34+ , Sql
35+ )
32import Rel8.Schema.Spec ( Spec( Spec ), SSpec )
36import Rel8.Schema.Spec ( Spec( Spec ), SSpec )
33import Rel8.Type.Eq ( DBEq )
37import Rel8.Type.Eq ( DBEq )
34import Rel8.Type.Monoid ( DBMonoid )
38import Rel8.Type.Monoid ( DBMonoid )
@@ -38,23 +42,23 @@ type Nullifiable :: K.Context -> Constraint
38class Interpretation context => Nullifiable context where
42class Interpretation context => Nullifiable context where
39 encodeTag :: (Sql DBEq a, KnownLabels labels)
43 encodeTag :: (Sql DBEq a, KnownLabels labels)
40 => Expr a
44 => Expr a
41− -> Col context ('Spec labels 'Required db a)
45+ -> Col context ('Spec labels 'Required a)
42
46
43 decodeTag :: Sql DBMonoid a
47 decodeTag :: Sql DBMonoid a
44− => Col context ('Spec labels 'Required db a)
48+ => Col context ('Spec labels 'Required a)
45 -> Expr a
49 -> Expr a
46
50
47 nullifier :: ()
51 nullifier :: ()
48 => Expr Bool
52 => Expr Bool
49− -> SSpec ('Spec labels necessity db a)
53+ -> SSpec ('Spec labels necessity a)
50− -> Col context ('Spec labels necessity db a)
54+ -> Col context ('Spec labels necessity a)
51− -> Col context ('Spec labels necessity db (Maybe db))
55+ -> Col context ('Spec labels necessity (Nullify a))
52
56
53 unnullifier :: ()
57 unnullifier :: ()
54 => Expr Bool
58 => Expr Bool
55− -> SSpec ('Spec labels necessity db a)
59+ -> SSpec ('Spec labels necessity a)
56− -> Col context ('Spec labels necessity db (Maybe db))
60+ -> Col context ('Spec labels necessity (Nullify a))
57− -> Col context ('Spec labels necessity db a)
61+ -> Col context ('Spec labels necessity a)
58
62
59
63
60type NullifiableEq :: K.Context -> K.Context -> Constraint
64type NullifiableEq :: K.Context -> K.Context -> Constraint
@@ -62,7 +66,7 @@ class (a ~ b, Nullifiable b) => NullifiableEq a b
62instance (a ~ b, Nullifiable b) => NullifiableEq a b
66instance (a ~ b, Nullifiable b) => NullifiableEq a b
63
67
64
68
65−runTag :: Nullability db a -> Expr Bool -> Expr a -> Expr (Maybe db)
69+runTag :: Nullability a -> Expr Bool -> Expr a -> Expr (Nullify a)
66runTag nullability tag a = case nullability of
70runTag nullability tag a = case nullability of
67 Nullable -> boolExpr null a tag
71 Nullable -> boolExpr null a tag
68 NonNullable -> boolExpr null (nullify a) tag
72 NonNullable -> boolExpr null (nullify a) tag
@@ -70,7 +74,7 @@ runTag nullability tag a = case nullability of
70 null = fromPrimExpr $ Opaleye.ConstExpr Opaleye.NullLit
74 null = fromPrimExpr $ Opaleye.ConstExpr Opaleye.NullLit
71
75
72
76
73−unnull :: Nullability db a -> Expr (Maybe db) -> Expr a
77+unnull :: Nullability a -> Expr (Nullify a) -> Expr a
74unnull nullability a = case nullability of
78unnull nullability a = case nullability of
75 Nullable -> a
79 Nullable -> a
76 NonNullable -> unsafeUnnullify a
80 NonNullable -> unsafeUnnullify a
src/Rel8/Schema/Field.hs+9−9
@@ -23,12 +23,12 @@ import Rel8.Schema.Spec ( Spec( Spec ) )
23import Rel8.Schema.Structure ( Structure, Shape( Column ), Shape1 )
23import Rel8.Schema.Structure ( Structure, Shape( Column ), Shape1 )
24
24
25
25
26−type Field :: K.Context -> Labels -> Necessity -> Type -> Type -> Type
26+type Field :: K.Context -> Labels -> Necessity -> Type -> Type
27−type family Field labels context necessity db a where
27+type family Field labels context necessity a where
28− Field Identity _labels _necessity _db a = a
28+ Field Identity _labels _necessity a = a
29− Field Expr _labels _necessity _db a = Expr a
29+ Field Expr _labels _necessity a = Expr a
30− Field Insert _labels 'Required _db a = Expr a
30+ Field Insert _labels 'Required a = Expr a
31− Field Insert _labels 'Optional _db a = Maybe (Expr a)
31+ Field Insert _labels 'Optional a = Maybe (Expr a)
32− Field Aggregate _labels _necessity _db a = Aggregate (Expr a)
32+ Field Aggregate _labels _necessity a = Aggregate (Expr a)
33− Field Structure labels necessity db a = Shape1 'Column ('Spec labels necessity db a)
33+ Field Structure labels necessity a = Shape1 'Column ('Spec labels necessity a)
34− Field context _labels _necessity _db a = context a
34+ Field context _labels _necessity a = context a
src/Rel8/Schema/Generic.hs+24−24
@@ -315,10 +315,10 @@ instance
315
315
316type K1Columns :: Symbol -> Type -> K.HTable
316type K1Columns :: Symbol -> Type -> K.HTable
317type family K1Columns label structure where
317type family K1Columns label structure where
318− K1Columns label (Shape1 'Column ('Spec '[] necessity nullability blueprint)) =
318+ K1Columns label (Shape1 'Column ('Spec '[] necessity a)) =
319− HIdentity ('Spec '[label] necessity nullability blueprint)
319+ HIdentity ('Spec '[label] necessity a)
320− K1Columns _label (Shape1 'Column ('Spec (label ': labels) necessity nullability blueprint)) =
320+ K1Columns _label (Shape1 'Column ('Spec (label ': labels) necessity a)) =
321− HIdentity ('Spec (label ': labels) necessity nullability blueprint)
321+ HIdentity ('Spec (label ': labels) necessity a)
322 K1Columns label (Shape2 'Either a b) =
322 K1Columns label (Shape2 'Either a b) =
323 HLabel label (HEitherTable (K1Columns "Left" a) (K1Columns "Right" b))
323 HLabel label (HEitherTable (K1Columns "Left" a) (K1Columns "Right" b))
324 K1Columns label (Shape1 'List a) = HListTable (K1Columns label a)
324 K1Columns label (Shape1 'List a) = HListTable (K1Columns label a)
@@ -364,8 +364,8 @@ class isStructure ~ IsStructure structure =>
364
364
365
365
366instance
366instance
367− ( x ~ Field Aggregate '[] necessity db a
367+ ( x ~ Field Aggregate '[] necessity a
368− ) => K1Table label Aggregate 'True (Shape1 'Column ('Spec '[] necessity db a)) x
368+ ) => K1Table label Aggregate 'True (Shape1 'Column ('Spec '[] necessity a)) x
369 where
369 where
370 fromK1Columns (HIdentity (Aggregation a)) = a
370 fromK1Columns (HIdentity (Aggregation a)) = a
371 toK1Columns = HIdentity . Aggregation
371 toK1Columns = HIdentity . Aggregation
@@ -374,8 +374,8 @@ instance
374
374
375
375
376instance
376instance
377− ( x ~ Field Aggregate (label ': labels) necessity db a
377+ ( x ~ Field Aggregate (label ': labels) necessity a
378− ) => K1Table _label Aggregate 'True (Shape1 'Column ('Spec (label ': labels) necessity db a)) x
378+ ) => K1Table _label Aggregate 'True (Shape1 'Column ('Spec (label ': labels) necessity a)) x
379 where
379 where
380 fromK1Columns (HIdentity (Aggregation a)) = a
380 fromK1Columns (HIdentity (Aggregation a)) = a
381 toK1Columns = HIdentity . Aggregation
381 toK1Columns = HIdentity . Aggregation
@@ -384,8 +384,8 @@ instance
384
384
385
385
386instance
386instance
387− ( x ~ Field Expr '[] necessity db a
387+ ( x ~ Field Expr '[] necessity a
388− ) => K1Table label Expr 'True (Shape1 'Column ('Spec '[] necessity db a)) x
388+ ) => K1Table label Expr 'True (Shape1 'Column ('Spec '[] necessity a)) x
389 where
389 where
390 fromK1Columns (HIdentity (DB a)) = a
390 fromK1Columns (HIdentity (DB a)) = a
391 toK1Columns = HIdentity . DB
391 toK1Columns = HIdentity . DB
@@ -394,8 +394,8 @@ instance
394
394
395
395
396instance
396instance
397− ( x ~ Field Expr (label ': labels) necessity db a
397+ ( x ~ Field Expr (label ': labels) necessity a
398− ) => K1Table _label Expr 'True (Shape1 'Column ('Spec (label ': labels) necessity db a)) x
398+ ) => K1Table _label Expr 'True (Shape1 'Column ('Spec (label ': labels) necessity a)) x
399 where
399 where
400 fromK1Columns (HIdentity (DB a)) = a
400 fromK1Columns (HIdentity (DB a)) = a
401 toK1Columns = HIdentity . DB
401 toK1Columns = HIdentity . DB
@@ -404,9 +404,9 @@ instance
404
404
405
405
406instance
406instance
407− ( x ~ Field Insert '[] necessity db a
407+ ( x ~ Field Insert '[] necessity a
408 , KnownNecessity necessity
408 , KnownNecessity necessity
409− ) => K1Table label Insert 'True (Shape1 'Column ('Spec '[] necessity db a)) x
409+ ) => K1Table label Insert 'True (Shape1 'Column ('Spec '[] necessity a)) x
410 where
410 where
411 fromK1Columns (HIdentity insert) = case insert of
411 fromK1Columns (HIdentity insert) = case insert of
412 RequiredInsert a -> a
412 RequiredInsert a -> a
@@ -419,9 +419,9 @@ instance
419
419
420
420
421instance
421instance
422− ( x ~ Field Insert (label ': labels) necessity db a
422+ ( x ~ Field Insert (label ': labels) necessity a
423 , KnownNecessity necessity
423 , KnownNecessity necessity
424− ) => K1Table _label Insert 'True (Shape1 'Column ('Spec (label ': labels) necessity db a)) x
424+ ) => K1Table _label Insert 'True (Shape1 'Column ('Spec (label ': labels) necessity a)) x
425 where
425 where
426 fromK1Columns (HIdentity insert) = case insert of
426 fromK1Columns (HIdentity insert) = case insert of
427 RequiredInsert a -> a
427 RequiredInsert a -> a
@@ -434,8 +434,8 @@ instance
434
434
435
435
436instance
436instance
437− ( x ~ Field Identity '[] necessity db a
437+ ( x ~ Field Identity '[] necessity a
438− ) => K1Table label Identity 'True (Shape1 'Column ('Spec '[] necessity db a)) x
438+ ) => K1Table label Identity 'True (Shape1 'Column ('Spec '[] necessity a)) x
439 where
439 where
440 fromK1Columns (HIdentity (Result a)) = a
440 fromK1Columns (HIdentity (Result a)) = a
441 toK1Columns = HIdentity . Result
441 toK1Columns = HIdentity . Result
@@ -444,8 +444,8 @@ instance
444
444
445
445
446instance
446instance
447− ( x ~ Field Identity (label ': labels) necessity db a
447+ ( x ~ Field Identity (label ': labels) necessity a
448− ) => K1Table _label Identity 'True (Shape1 'Column ('Spec (label ': labels) necessity db a)) x
448+ ) => K1Table _label Identity 'True (Shape1 'Column ('Spec (label ': labels) necessity a)) x
449 where
449 where
450 fromK1Columns (HIdentity (Result a)) = a
450 fromK1Columns (HIdentity (Result a)) = a
451 toK1Columns = HIdentity . Result
451 toK1Columns = HIdentity . Result
@@ -454,8 +454,8 @@ instance
454
454
455
455
456instance
456instance
457− ( x ~ Field Name '[] necessity db a
457+ ( x ~ Field Name '[] necessity a
458− ) => K1Table _label Name 'True (Shape1 'Column ('Spec (label ': labels) necessity db a)) x
458+ ) => K1Table _label Name 'True (Shape1 'Column ('Spec (label ': labels) necessity a)) x
459 where
459 where
460 fromK1Columns (HIdentity (NameCol a)) = Name a
460 fromK1Columns (HIdentity (NameCol a)) = Name a
461 toK1Columns (Name a) = HIdentity (NameCol a)
461 toK1Columns (Name a) = HIdentity (NameCol a)
@@ -464,8 +464,8 @@ instance
464
464
465
465
466instance
466instance
467− ( x ~ Field Name (label ': labels) necessity db a
467+ ( x ~ Field Name (label ': labels) necessity a
468− ) => K1Table label Name 'True (Shape1 'Column ('Spec '[] necessity db a)) x
468+ ) => K1Table label Name 'True (Shape1 'Column ('Spec '[] necessity a)) x
469 where
469 where
470 fromK1Columns = Name . (\(NameCol a) -> a) . unlabeler . unHIdentity
470 fromK1Columns = Name . (\(NameCol a) -> a) . unlabeler . unHIdentity
471 toK1Columns = HIdentity . labeler . NameCol . (\(Name a) -> a)
471 toK1Columns = HIdentity . labeler . NameCol . (\(Name a) -> a)
src/Rel8/Schema/HTable/Either.hs+1−1
@@ -25,7 +25,7 @@ import Rel8.Type.Tag ( EitherTag )
25
25
26type HEitherTable :: K.HTable -> K.HTable -> K.HTable
26type HEitherTable :: K.HTable -> K.HTable -> K.HTable
27data HEitherTable left right context = HEitherTable
27data HEitherTable left right context = HEitherTable
28− { htag :: HIdentity ('Spec '["isRight"] 'Required EitherTag EitherTag) context
28+ { htag :: HIdentity ('Spec '["isRight"] 'Required EitherTag) context
29 , hleft :: HNullify left context
29 , hleft :: HNullify left context
30 , hright :: HNullify right context
30 , hright :: HNullify right context
31 }
31 }
src/Rel8/Schema/HTable/Label.hs+7−7
@@ -51,7 +51,7 @@ newtype HLabel label table context = HLabel (HMapTable (Label label) table conte
51data Label :: Symbol -> Spec -> Exp Spec
51data Label :: Symbol -> Spec -> Exp Spec
52
52
53
53
54−type instance Eval (Label label ('Spec labels necessity db a)) = 'Spec (label : labels) necessity db a
54+type instance Eval (Label label ('Spec labels necessity a)) = 'Spec (label : labels) necessity a
55
55
56
56
57instance KnownSymbol l => MapSpec (Label l) where
57instance KnownSymbol l => MapSpec (Label l) where
@@ -60,9 +60,9 @@ instance KnownSymbol l => MapSpec (Label l) where
60
60
61
61
62hlabel :: (HTable t, KnownSymbol label)
62hlabel :: (HTable t, KnownSymbol label)
63− => (forall labels necessity db a. ()
63+ => (forall labels necessity a. ()
64− => context ('Spec labels necessity db a)
64+ => context ('Spec labels necessity a)
65− -> context ('Spec (label ': labels) necessity db a))
65+ -> context ('Spec (label ': labels) necessity a))
66 -> t context
66 -> t context
67 -> HLabel label t context
67 -> HLabel label t context
68hlabel labeler a = HLabel $ htabulate $ \(HMapTableField field) ->
68hlabel labeler a = HLabel $ htabulate $ \(HMapTableField field) ->
@@ -72,9 +72,9 @@ hlabel labeler a = HLabel $ htabulate $ \(HMapTableField field) ->
72
72
73
73
74hunlabel :: (HTable t, KnownSymbol label)
74hunlabel :: (HTable t, KnownSymbol label)
75− => (forall labels necessity db a. ()
75+ => (forall labels necessity a. ()
76− => context ('Spec (label ': labels) necessity db a)
76+ => context ('Spec (label ': labels) necessity a)
77− -> context ('Spec labels necessity db a))
77+ -> context ('Spec labels necessity a))
78 -> HLabel label t context
78 -> HLabel label t context
79 -> t context
79 -> t context
80hunlabel unlabler (HLabel as) =
80hunlabel unlabler (HLabel as) =
src/Rel8/Schema/HTable/Maybe.hs+1−1
@@ -29,7 +29,7 @@ import Rel8.Schema.HTable.Nullify ( HNullify )
29
29
30type HMaybeTable :: K.HTable -> K.HTable
30type HMaybeTable :: K.HTable -> K.HTable
31data HMaybeTable table context = HMaybeTable
31data HMaybeTable table context = HMaybeTable
32− { htag :: HIdentity ('Spec '["isJust"] 'Required MaybeTag (Maybe MaybeTag)) context
32+ { htag :: HIdentity ('Spec '["isJust"] 'Required (Maybe MaybeTag)) context
33 , hjust :: HNullify table context
33 , hjust :: HNullify table context
34 }
34 }
35 deriving stock Generic
35 deriving stock Generic
src/Rel8/Schema/HTable/Nullify.hs+13−12
@@ -35,6 +35,7 @@ import Rel8.Schema.HTable
35 )
35 )
36import qualified Rel8.Schema.Kind as K
36import qualified Rel8.Schema.Kind as K
37import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ) )
37import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ) )
38+import qualified Rel8.Schema.Nullability as Type ( Nullify )
38import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
39import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
39
40
40-- semigroupoids
41-- semigroupoids
@@ -55,8 +56,8 @@ newtype HNullify table context = HNullify (HMapTable Nullify table context)
55data Nullify :: Spec -> Exp Spec
56data Nullify :: Spec -> Exp Spec
56
57
57
58
58−type instance Eval (Nullify ('Spec labels necessity dbType _)) =
59+type instance Eval (Nullify ('Spec labels necessity a)) =
59− 'Spec labels necessity dbType (Maybe dbType)
60+ 'Spec labels necessity (Type.Nullify a)
60
61
61
62
62instance MapSpec Nullify where
63instance MapSpec Nullify where
@@ -72,8 +73,8 @@ instance MapSpec Nullify where
72
73
73
74
74hnulls :: HTable t
75hnulls :: HTable t
75− => (forall labels necessity dbType. ()
76+ => (forall labels necessity a. ()
76− => context ('Spec labels necessity dbType (Maybe dbType)))
77+ => context ('Spec labels necessity (Maybe a)))
77 -> HNullify t context
78 -> HNullify t context
78hnulls null = HNullify $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of
79hnulls null = HNullify $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of
79 SSpec {} -> null
80 SSpec {} -> null
@@ -81,10 +82,10 @@ hnulls null = HNullify $ htabulate $ \(HMapTableField field) -> case hfield hspe
81
82
82
83
83hnullify :: HTable t
84hnullify :: HTable t
84− => (forall labels necessity dbType a. ()
85+ => (forall labels necessity a. ()
85− => SSpec ('Spec labels necessity dbType a)
86+ => SSpec ('Spec labels necessity a)
86− -> context ('Spec labels necessity dbType a)
87+ -> context ('Spec labels necessity a)
87− -> context ('Spec labels necessity dbType (Maybe dbType)))
88+ -> context ('Spec labels necessity (Type.Nullify a)))
88 -> t context
89 -> t context
89 -> HNullify t context
90 -> HNullify t context
90hnullify nullifier a = HNullify $ htabulate $ \(HMapTableField field) ->
91hnullify nullifier a = HNullify $ htabulate $ \(HMapTableField field) ->
@@ -94,10 +95,10 @@ hnullify nullifier a = HNullify $ htabulate $ \(HMapTableField field) ->
94
95
95
96
96hunnullify :: (HTable t, Apply m)
97hunnullify :: (HTable t, Apply m)
97− => (forall labels necessity dbType a. ()
98+ => (forall labels necessity a. ()
98− => SSpec ('Spec labels necessity dbType a)
99+ => SSpec ('Spec labels necessity a)
99− -> context ('Spec labels necessity dbType (Maybe dbType))
100+ -> context ('Spec labels necessity (Type.Nullify a))
100− -> m (context ('Spec labels necessity dbType a)))
101+ -> m (context ('Spec labels necessity a)))
101 -> HNullify t context
102 -> HNullify t context
102 -> m (t context)
103 -> m (t context)
103hunnullify unnullifier (HNullify as) =
104hunnullify unnullifier (HNullify as) =
src/Rel8/Schema/HTable/These.hs+2−2
@@ -25,9 +25,9 @@ import Rel8.Type.Tag ( MaybeTag )
25
25
26type HTheseTable :: K.HTable -> K.HTable -> K.HTable
26type HTheseTable :: K.HTable -> K.HTable -> K.HTable
27data HTheseTable here there context = HTheseTable
27data HTheseTable here there context = HTheseTable
28− { hhereTag :: HIdentity ('Spec '["hasHere"] 'Required MaybeTag (Maybe MaybeTag)) context
28+ { hhereTag :: HIdentity ('Spec '["hasHere"] 'Required (Maybe MaybeTag)) context
29 , hhere :: HNullify here context
29 , hhere :: HNullify here context
30− , hthereTag :: HIdentity ('Spec '["hasThere"] 'Required MaybeTag (Maybe MaybeTag)) context
30+ , hthereTag :: HIdentity ('Spec '["hasThere"] 'Required (Maybe MaybeTag)) context
31 , hthere :: HNullify there context
31 , hthere :: HNullify there context
32 }
32 }
33 deriving stock Generic
33 deriving stock Generic
src/Rel8/Schema/HTable/Type.hs+4−4
@@ -23,24 +23,24 @@ import Rel8.Schema.HTable
23 , hfield, htabulate, htraverse, hdicts, hspecs
23 , hfield, htabulate, htraverse, hdicts, hspecs
24 )
24 )
25import qualified Rel8.Schema.Kind as K
25import qualified Rel8.Schema.Kind as K
26−import Rel8.Schema.Nullability ( Unnullify, Sql, nullabilization )
26+import Rel8.Schema.Nullability ( Sql, nullabilization )
27import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
27import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
28import Rel8.Type ( DBType, typeInformation )
28import Rel8.Type ( DBType, typeInformation )
29
29
30
30
31type HType :: Type -> K.HTable
31type HType :: Type -> K.HTable
32newtype HType a context = HType
32newtype HType a context = HType
33− { unHType :: context ('Spec '[""] 'Required (Unnullify a) a)
33+ { unHType :: context ('Spec '[""] 'Required a)
34 }
34 }
35
35
36
36
37type HTypeField :: Type -> Spec -> Type
37type HTypeField :: Type -> Spec -> Type
38data HTypeField a spec where
38data HTypeField a spec where
39− HTypeField :: HTypeField a ('Spec '[""] 'Required (Unnullify a) a)
39+ HTypeField :: HTypeField a ('Spec '[""] 'Required a)
40
40
41
41
42instance Sql DBType a => HTable (HType a) where
42instance Sql DBType a => HTable (HType a) where
43− type HConstrainTable (HType a) c = c ('Spec '[""] 'Required (Unnullify a) a)
43+ type HConstrainTable (HType a) c = c ('Spec '[""] 'Required a)
44 type HField (HType a) = HTypeField a
44 type HField (HType a) = HTypeField a
45
45
46 hfield (HType a) HTypeField = a
46 hfield (HType a) HTypeField = a
src/Rel8/Schema/HTable/Vectorize.hs+27−23
@@ -42,7 +42,11 @@ import Rel8.Schema.HTable
42 ( HTable
42 ( HTable
43 , hfield, htabulate, htabulateA, hspecs
43 , hfield, htabulate, htabulateA, hspecs
44 )
44 )
45−import Rel8.Schema.Nullability ( IsMaybe, Nullability( NonNullable ) )
45+import Rel8.Schema.Nullability
46+ ( IsMaybe
47+ , Unnullify
48+ , Nullability( NonNullable )
49+ )
46import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
50import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
47import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )
51import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )
48import Rel8.Type.Information ( TypeInformation )
52import Rel8.Type.Information ( TypeInformation )
@@ -57,9 +61,9 @@ import GHC.Generics (Generic)
57class Vector list where
61class Vector list where
58 listIsn'tMaybe :: proxy a -> IsMaybe (list a) :~: 'False
62 listIsn'tMaybe :: proxy a -> IsMaybe (list a) :~: 'False
59 vectorTypeInformation :: ()
63 vectorTypeInformation :: ()
60− => Nullability a ma
64+ => Nullability a
61− -> TypeInformation a
65+ -> TypeInformation (Unnullify a)
62− -> TypeInformation (list ma)
66+ -> TypeInformation (list a)
63
67
64
68
65instance Vector [] where
69instance Vector [] where
@@ -81,7 +85,7 @@ newtype HVectorize list table context = HVectorize (HMapTable (Vectorize list) t
81data Vectorize :: (Type -> Type) -> Spec -> Exp Spec
85data Vectorize :: (Type -> Type) -> Spec -> Exp Spec
82
86
83
87
84−type instance Eval (Vectorize list ('Spec labels necessity _ a)) = 'Spec labels necessity (list a) (list a)
88+type instance Eval (Vectorize list ('Spec labels necessity a)) = 'Spec labels necessity (list a)
85
89
86
90
87instance Vector list => MapSpec (Vectorize list) where
91instance Vector list => MapSpec (Vectorize list) where
@@ -95,10 +99,10 @@ instance Vector list => MapSpec (Vectorize list) where
95
99
96
100
97hvectorize :: (HTable t, Unzip f, Vector list)
101hvectorize :: (HTable t, Unzip f, Vector list)
98− => (forall labels necessity db a. ()
102+ => (forall labels necessity a. ()
99− => SSpec ('Spec labels necessity db a)
103+ => SSpec ('Spec labels necessity a)
100− -> f (context ('Spec labels necessity db a))
104+ -> f (context ('Spec labels necessity a))
101− -> context' ('Spec labels necessity (list a) (list a)))
105+ -> context' ('Spec labels necessity (list a)))
102 -> f (t context)
106 -> f (t context)
103 -> HVectorize list t context'
107 -> HVectorize list t context'
104hvectorize vectorizer as = HVectorize $ htabulate $ \(HMapTableField field) ->
108hvectorize vectorizer as = HVectorize $ htabulate $ \(HMapTableField field) ->
@@ -108,10 +112,10 @@ hvectorize vectorizer as = HVectorize $ htabulate $ \(HMapTableField field) ->
108
112
109
113
110hunvectorize :: (HTable t, Repeat f, Vector list)
114hunvectorize :: (HTable t, Repeat f, Vector list)
111− => (forall labels necessity db a. ()
115+ => (forall labels necessity a. ()
112− => SSpec ('Spec labels necessity db a)
116+ => SSpec ('Spec labels necessity a)
113− -> context ('Spec labels necessity (list a) (list a))
117+ -> context ('Spec labels necessity (list a))
114− -> f (context' ('Spec labels necessity db a)))
118+ -> f (context' ('Spec labels necessity a)))
115 -> HVectorize list t context
119 -> HVectorize list t context
116 -> f (t context')
120 -> f (t context')
117hunvectorize unvectorizer (HVectorize table) =
121hunvectorize unvectorizer (HVectorize table) =
@@ -122,12 +126,12 @@ hunvectorize unvectorizer (HVectorize table) =
122
126
123
127
124happend :: (HTable t, Vector list) =>
128happend :: (HTable t, Vector list) =>
125− ( forall labels necessity db a. ()
129+ ( forall labels necessity a. ()
126− => Nullability db a
130+ => Nullability a
127− -> TypeInformation db
131+ -> TypeInformation (Unnullify a)
128− -> context ('Spec labels necessity (list a) (list a))
132+ -> context ('Spec labels necessity (list a))
129− -> context ('Spec labels necessity (list a) (list a))
133+ -> context ('Spec labels necessity (list a))
130− -> context ('Spec labels necessity (list a) (list a))
134+ -> context ('Spec labels necessity (list a))
131 )
135 )
132 -> HVectorize list t context
136 -> HVectorize list t context
133 -> HVectorize list t context
137 -> HVectorize list t context
@@ -139,10 +143,10 @@ happend append (HVectorize as) (HVectorize bs) = HVectorize $
139
143
140
144
141hempty :: HTable t =>
145hempty :: HTable t =>
142− ( forall labels necessity db a. ()
146+ ( forall labels necessity a. ()
143− => Nullability db a
147+ => Nullability a
144− -> TypeInformation db
148+ -> TypeInformation (Unnullify a)
145− -> context ('Spec labels necessity [a] [a])
149+ -> context ('Spec labels necessity [a])
146 )
150 )
147 -> HVectorize [] t context
151 -> HVectorize [] t context
148hempty empty = HVectorize $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of
152hempty empty = HVectorize $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of
src/Rel8/Schema/Insert.hs+2−2
@@ -76,8 +76,8 @@ data Insert a where
76
76
77instance Interpretation Insert where
77instance Interpretation Insert where
78 data Col Insert _spec where
78 data Col Insert _spec where
79− RequiredInsert :: Expr a -> Col Insert ('Spec labels 'Required db a)
79+ RequiredInsert :: Expr a -> Col Insert ('Spec labels 'Required a)
80− OptionalInsert :: Maybe (Expr a) -> Col Insert ('Spec labels 'Optional db a)
80+ OptionalInsert :: Maybe (Expr a) -> Col Insert ('Spec labels 'Optional a)
81
81
82
82
83type Insertion :: K.Context
83type Insertion :: K.Context
src/Rel8/Schema/Name.hs+2−2
@@ -98,8 +98,8 @@ instance Nullifiable Name where
98 {-# INLINABLE unnullifier #-}
98 {-# INLINABLE unnullifier #-}
99
99
100
100
101−nameFromLabel :: forall labels necessity db a.
101+nameFromLabel :: forall labels necessity a.
102− KnownLabels labels => Col Name ('Spec labels necessity db a)
102+ KnownLabels labels => Col Name ('Spec labels necessity a)
103nameFromLabel = case labelsSing @labels of
103nameFromLabel = case labelsSing @labels of
104 labels -> NameCol (NonEmpty.last (renderLabels labels))
104 labels -> NameCol (NonEmpty.last (renderLabels labels))
105
105
src/Rel8/Schema/Nullability.hs+20−22
@@ -15,7 +15,7 @@ module Rel8.Schema.Nullability
15 ( IsMaybe, Nullify, Unnullify
15 ( IsMaybe, Nullify, Unnullify
16 , Nullability( Nullable, NonNullable )
16 , Nullability( Nullable, NonNullable )
17 , Sql
17 , Sql
18− , Nullabilizes, nullabilization
18+ , HasNullability, nullabilization
19 )
19 )
20where
20where
21
21
@@ -53,35 +53,34 @@ type Nullify :: Type -> Type
53type Nullify a = Maybe (Unnullify a)
53type Nullify a = Maybe (Unnullify a)
54
54
55
55
56−type Nullability :: Type -> Type -> Type
56+type Nullability :: Type -> Type
57−data Nullability a ma where
57+data Nullability a where
58− NonNullable :: IsMaybe a ~ 'False => Nullability a a
58+ NonNullable :: IsMaybe a ~ 'False => Nullability a
59− Nullable :: IsMaybe a ~ 'False => Nullability a (Maybe a)
59+ Nullable :: IsMaybe a ~ 'False => Nullability (Maybe a)
60
60
61
61
62−type Nullabilizes' :: Bool -> Type -> Type -> Constraint
62+type HasNullability' :: Bool -> Type -> Constraint
63class
63class
64− ( IsMaybe ma ~ isMaybe
64+ ( IsMaybe a ~ isMaybe
65− , IsMaybe a ~ 'False
65+ , IsMaybe (Unnullify a) ~ 'False
66− , Unnullify ma ~ a
67− , Nullify' isMaybe a ~ ma
66+ , Nullify' isMaybe (Unnullify a) ~ a
68− ) => Nullabilizes' isMaybe a ma | isMaybe ma -> a, isMaybe a -> ma
67+ ) => HasNullability' isMaybe a
69 where
68 where
70− nullabilization' :: Nullability a ma
69+ nullabilization' :: Nullability a
71
70
72
71
73−instance IsMaybe a ~ 'False => Nullabilizes' 'False a a where
72+instance IsMaybe a ~ 'False => HasNullability' 'False a where
74 nullabilization' = NonNullable
73 nullabilization' = NonNullable
75
74
76
75
77−instance IsMaybe a ~ 'False => Nullabilizes' 'True a (Maybe a) where
76+instance IsMaybe a ~ 'False => HasNullability' 'True (Maybe a) where
78 nullabilization' = Nullable
77 nullabilization' = Nullable
79
78
80
79
81−type Nullabilizes :: Type -> Type -> Constraint
80+type HasNullability :: Type -> Constraint
82−class Nullabilizes' (IsMaybe ma) a ma => Nullabilizes a ma
81+class HasNullability' (IsMaybe a) a => HasNullability a
83−instance Nullabilizes' (IsMaybe ma) a ma => Nullabilizes a ma
82+instance HasNullability' (IsMaybe a) a => HasNullability a
84−instance {-# OVERLAPPING #-} Nullabilizes Opaque Opaque
83+instance {-# OVERLAPPING #-} HasNullability Opaque
85
84
86
85
87-- | The @Sql@ type class describes both null and not null database values,
86-- | The @Sql@ type class describes both null and not null database values,
@@ -93,14 +92,13 @@ instance {-# OVERLAPPING #-} Nullabilizes Opaque Opaque
93type Sql :: (Type -> Constraint) -> Type -> Constraint
92type Sql :: (Type -> Constraint) -> Type -> Constraint
94class
93class
95 ( (forall c. (forall x. (constraint x => c x)) => Sql c a)
94 ( (forall c. (forall x. (constraint x => c x)) => Sql c a)
96− , Nullabilizes (Unnullify a) a
95+ , HasNullability a
97 , constraint (Unnullify a)
96 , constraint (Unnullify a)
98 )
97 )
99 => Sql constraint a
98 => Sql constraint a
100−instance (constraint db, Nullabilizes db a) => Sql constraint a
99+instance (constraint (Unnullify a), HasNullability a) => Sql constraint a
101instance {-# OVERLAPPING #-} (constraint Opaque, Sql constraint Opaque) => Sql constraint Opaque
100instance {-# OVERLAPPING #-} (constraint Opaque, Sql constraint Opaque) => Sql constraint Opaque
102−-- instance {-# OVERLAPPING #-} Sql OpaqueC Opaque => Sql OpaqueC Opaque
103
101
104
102
105−nullabilization :: forall a db. Nullabilizes db a => Nullability db a
103+nullabilization :: HasNullability a => Nullability a
106nullabilization = nullabilization'
104nullabilization = nullabilization'
src/Rel8/Schema/Spec.hs+6−7
@@ -24,13 +24,13 @@ import Rel8.Kind.Necessity
24 , SNecessity
24 , SNecessity
25 , KnownNecessity, necessitySing
25 , KnownNecessity, necessitySing
26 )
26 )
27−import Rel8.Schema.Nullability ( Unnullify, Nullability, Sql, nullabilization )
27+import Rel8.Schema.Nullability ( Nullability, Sql, Unnullify, nullabilization )
28import Rel8.Type ( DBType, typeInformation )
28import Rel8.Type ( DBType, typeInformation )
29import Rel8.Type.Information ( TypeInformation )
29import Rel8.Type.Information ( TypeInformation )
30
30
31
31
32type Spec :: Type
32type Spec :: Type
33−data Spec = Spec Labels Necessity Type Type
33+data Spec = Spec Labels Necessity Type
34
34
35
35
36type SSpec :: Spec -> Type
36type SSpec :: Spec -> Type
@@ -38,10 +38,10 @@ data SSpec spec where
38 SSpec ::
38 SSpec ::
39 { labels :: SLabels labels
39 { labels :: SLabels labels
40 , necessity :: SNecessity necessity
40 , necessity :: SNecessity necessity
41− , info :: TypeInformation db
41+ , info :: TypeInformation (Unnullify a)
42− , nullability :: Nullability db a
42+ , nullability :: Nullability a
43 }
43 }
44− -> SSpec ('Spec labels necessity db a)
44+ -> SSpec ('Spec labels necessity a)
45
45
46
46
47type KnownSpec :: Spec -> Constraint
47type KnownSpec :: Spec -> Constraint
@@ -53,9 +53,8 @@ instance
53 ( KnownLabels labels
53 ( KnownLabels labels
54 , KnownNecessity necessity
54 , KnownNecessity necessity
55 , Sql DBType a
55 , Sql DBType a
56− , db ~ Unnullify a
57 )
56 )
58− => KnownSpec ('Spec labels necessity db a)
57+ => KnownSpec ('Spec labels necessity a)
59 where
58 where
60 specSing = SSpec
59 specSing = SSpec
61 { labels = labelsSing
60 { labels = labelsSing
src/Rel8/Schema/Spec/ConstrainDBType.hs+6−5
@@ -17,18 +17,19 @@ import Data.Kind ( Constraint, Type )
17import Prelude ()
17import Prelude ()
18
18
19-- rel8
19-- rel8
20+import Rel8.Schema.Nullability ( Sql )
20import Rel8.Schema.Spec ( Spec( Spec ) )
21import Rel8.Schema.Spec ( Spec( Spec ) )
21
22
22
23
23type ConstrainDBType :: (Type -> Constraint) -> Spec -> Constraint
24type ConstrainDBType :: (Type -> Constraint) -> Spec -> Constraint
24class
25class
25− ( forall labels necessity db a. ()
26+ ( forall c labels necessity a. ()
26− => (spec ~ 'Spec labels necessity db a)
27+ => (spec ~ 'Spec labels necessity a)
27− => constraint db
28+ => (forall x. (constraint x => c x)) => Sql c a
28 )
29 )
29 => ConstrainDBType constraint spec
30 => ConstrainDBType constraint spec
30instance
31instance
31− ( spec ~ 'Spec labels necessity db a
32+ ( spec ~ 'Spec labels necessity a
32− , constraint db
33+ , Sql constraint a
33 )
34 )
34 => ConstrainDBType constraint spec
35 => ConstrainDBType constraint spec
src/Rel8/Schema/Spec/ConstrainType.hs+3−3
@@ -22,10 +22,10 @@ import Rel8.Schema.Spec ( Spec( Spec ) )
22
22
23type ConstrainType :: (Type -> Constraint) -> Spec -> Constraint
23type ConstrainType :: (Type -> Constraint) -> Spec -> Constraint
24class
24class
25− ( forall labels necessity db a. ()
25+ ( forall labels necessity a. ()
26− => (spec ~ 'Spec labels necessity db a)
26+ => (spec ~ 'Spec labels necessity a)
27 => constraint a
27 => constraint a
28 ) =>
28 ) =>
29 ConstrainType constraint spec
29 ConstrainType constraint spec
30−instance (spec ~ 'Spec labels necessity db a, constraint a) =>
30+instance (spec ~ 'Spec labels necessity a, constraint a) =>
31 ConstrainType constraint spec
31 ConstrainType constraint spec
src/Rel8/Table/Aggregate.hs+4−6
@@ -20,11 +20,10 @@ import Prelude
20-- rel8
20-- rel8
21import Rel8.Aggregate ( Aggregate, Aggregates, Col(..) )
21import Rel8.Aggregate ( Aggregate, Aggregates, Col(..) )
22import Rel8.Expr ( Expr, Col(..) )
22import Rel8.Expr ( Expr, Col(..) )
23−import Rel8.Expr.Aggregate ( listAggExpr, nonEmptyAggExpr, sgroupByExpr )
23+import Rel8.Expr.Aggregate ( groupByExpr, listAggExpr, nonEmptyAggExpr )
24import Rel8.Schema.Dict ( Dict( Dict ) )
24import Rel8.Schema.Dict ( Dict( Dict ) )
25−import Rel8.Schema.HTable ( htabulate, hfield, hdicts, hspecs )
25+import Rel8.Schema.HTable ( htabulate, hfield, hdicts )
26import Rel8.Schema.HTable.Vectorize ( hvectorize )
26import Rel8.Schema.HTable.Vectorize ( hvectorize )
27−import Rel8.Schema.Spec ( SSpec(..) )
28import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
27import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
29import Rel8.Table ( Table, Columns, toColumns, fromColumns )
28import Rel8.Table ( Table, Columns, toColumns, fromColumns )
30import Rel8.Table.Eq ( EqTable )
29import Rel8.Table.Eq ( EqTable )
@@ -38,9 +37,8 @@ import Rel8.Type.Eq ( DBEq )
38groupBy :: forall exprs. EqTable exprs => exprs -> Aggregate exprs
37groupBy :: forall exprs. EqTable exprs => exprs -> Aggregate exprs
39groupBy (toColumns -> exprs) = fromColumns $ htabulate $ \field ->
38groupBy (toColumns -> exprs) = fromColumns $ htabulate $ \field ->
40 case hfield dicts field of
39 case hfield dicts field of
41− Dict -> case hfield hspecs field of
40+ Dict -> case hfield exprs field of
42− SSpec {nullability} -> case hfield exprs field of
43− DB expr -> Aggregation $ sgroupByExpr nullability expr
41+ DB expr -> Aggregation $ groupByExpr expr
44 where
42 where
45 dicts = hdicts @(Columns exprs) @(ConstrainDBType DBEq)
43 dicts = hdicts @(Columns exprs) @(ConstrainDBType DBEq)
46
44
src/Rel8/Table/Eq.hs+5−14
@@ -20,20 +20,15 @@ import Data.Foldable ( foldl' )
20import Data.Functor.Const ( Const( Const ), getConst )
20import Data.Functor.Const ( Const( Const ), getConst )
21import Data.Kind ( Constraint, Type )
21import Data.Kind ( Constraint, Type )
22import Data.List.NonEmpty ( NonEmpty( (:|) ) )
22import Data.List.NonEmpty ( NonEmpty( (:|) ) )
23−import Prelude hiding ( seq )
23+import Prelude
24
24
25-- rel8
25-- rel8
26import Rel8.Expr ( Expr, Col(..) )
26import Rel8.Expr ( Expr, Col(..) )
27import Rel8.Expr.Bool ( (||.), (&&.) )
27import Rel8.Expr.Bool ( (||.), (&&.) )
28−import Rel8.Expr.Eq ( seq, sne )
28+import Rel8.Expr.Eq ( (==.), (/=.) )
29import Rel8.Opaque ( Opaque )
29import Rel8.Opaque ( Opaque )
30import Rel8.Schema.Dict ( Dict( Dict ) )
30import Rel8.Schema.Dict ( Dict( Dict ) )
31−import Rel8.Schema.HTable
31+import Rel8.Schema.HTable ( HConstrainTable, htabulateA, hfield, hdicts )
32− ( HConstrainTable
33− , htabulateA, hfield
34− , hdicts, hspecs
35− )
36−import Rel8.Schema.Spec ( SSpec(..) )
37import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
32import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
38import Rel8.Table ( Table, Columns, toColumns )
33import Rel8.Table ( Table, Columns, toColumns )
39import Rel8.Type.Eq ( DBEq )
34import Rel8.Type.Eq ( DBEq )
@@ -59,11 +54,9 @@ instance {-# OVERLAPPING #-} EqTable Opaque
59 foldl1' (&&.) $ getConst $ htabulateA $ \field ->
54 foldl1' (&&.) $ getConst $ htabulateA $ \field ->
60 case (hfield as field, hfield bs field) of
55 case (hfield as field, hfield bs field) of
61 (DB a, DB b) -> case hfield dicts field of
56 (DB a, DB b) -> case hfield dicts field of
62− Dict -> case hfield specs field of
57+ Dict -> Const (pure (a ==. b))
63− SSpec {nullability} -> Const (pure (seq nullability a b))
64 where
58 where
65 dicts = hdicts @(Columns a) @(ConstrainDBType DBEq)
59 dicts = hdicts @(Columns a) @(ConstrainDBType DBEq)
66− specs = hspecs @(Columns a)
67infix 4 ==:
60infix 4 ==:
68
61
69
62
@@ -75,11 +68,9 @@ infix 4 ==:
75 foldl1' (||.) $ getConst $ htabulateA $ \field ->
68 foldl1' (||.) $ getConst $ htabulateA $ \field ->
76 case (hfield as field, hfield bs field) of
69 case (hfield as field, hfield bs field) of
77 (DB a, DB b) -> case hfield dicts field of
70 (DB a, DB b) -> case hfield dicts field of
78− Dict -> case hfield specs field of
71+ Dict -> Const (pure (a /=. b))
79− SSpec {nullability} -> Const (pure (sne nullability a b))
80 where
72 where
81 dicts = hdicts @(Columns a) @(ConstrainDBType DBEq)
73 dicts = hdicts @(Columns a) @(ConstrainDBType DBEq)
82− specs = hspecs @(Columns a)
83infix 4 /=:
74infix 4 /=:
84
75
85
76
src/Rel8/Table/Opaleye.hs+9−10
@@ -96,16 +96,15 @@ tableFields (toColumns -> names) = dimap toColumns fromColumns $
96 name -> lmap (`hfield` field) (go specs name)
96 name -> lmap (`hfield` field) (go specs name)
97 where
97 where
98 go :: SSpec spec -> Col Name spec -> Opaleye.TableFields (Col Insert spec) (Col Expr spec)
98 go :: SSpec spec -> Col Name spec -> Opaleye.TableFields (Col Insert spec) (Col Expr spec)
99− go SSpec {necessity, info, nullability} (NameCol name) =
99+ go SSpec {necessity, info} (NameCol name) = case necessity of
100− case necessity of
101− SRequired ->
100+ SRequired ->
102− lmap (\(RequiredInsert a) -> toColumn $ toPrimExpr a) $
101+ lmap (\(RequiredInsert a) -> toColumn $ toPrimExpr a) $
103− DB . scastExpr nullability info . fromPrimExpr . fromColumn <$>
102+ DB . scastExpr info . fromPrimExpr . fromColumn <$>
104− Opaleye.requiredTableField name
103+ Opaleye.requiredTableField name
105− SOptional ->
104+ SOptional ->
106− lmap (\(OptionalInsert ma) -> toColumn . toPrimExpr <$> ma) $
105+ lmap (\(OptionalInsert ma) -> toColumn . toPrimExpr <$> ma) $
107− DB . scastExpr nullability info . fromPrimExpr . fromColumn <$>
106+ DB . scastExpr info . fromPrimExpr . fromColumn <$>
108− Opaleye.optionalTableField name
107+ Opaleye.optionalTableField name
109
108
110
109
111unpackspec :: Table Expr a => Opaleye.Unpackspec a a
110unpackspec :: Table Expr a => Opaleye.Unpackspec a a
src/Rel8/Table/Ord.hs+7−24
@@ -22,16 +22,11 @@ import Prelude hiding ( seq )
22-- rel8
22-- rel8
23import Rel8.Expr ( Expr, Col(..) )
23import Rel8.Expr ( Expr, Col(..) )
24import Rel8.Expr.Bool ( (||.), (&&.), false, true )
24import Rel8.Expr.Bool ( (||.), (&&.), false, true )
25−import Rel8.Expr.Eq ( seq )
25+import Rel8.Expr.Eq ( (==.) )
26−import Rel8.Expr.Ord ( slt, sgt)
26+import Rel8.Expr.Ord ( (<.), (>.) )
27import Rel8.Opaque ( Opaque )
27import Rel8.Opaque ( Opaque )
28import Rel8.Schema.Dict ( Dict( Dict ) )
28import Rel8.Schema.Dict ( Dict( Dict ) )
29−import Rel8.Schema.HTable
29+import Rel8.Schema.HTable ( HConstrainTable, htabulateA, hfield, hdicts )
30− ( HConstrainTable
31− , htabulateA, hfield
32− , hdicts, hspecs
33− )
34−import Rel8.Schema.Spec ( SSpec(..) )
35import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
30import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
36import Rel8.Table ( Columns, toColumns )
31import Rel8.Table ( Columns, toColumns )
37import Rel8.Table.Bool ( bool )
32import Rel8.Table.Bool ( bool )
@@ -61,12 +56,9 @@ instance {-# OVERLAPPING #-} OrdTable Opaque
61 foldr @[] go false $ getConst $ htabulateA $ \field ->
56 foldr @[] go false $ getConst $ htabulateA $ \field ->
62 case (hfield as field, hfield bs field) of
57 case (hfield as field, hfield bs field) of
63 (DB a, DB b) -> case hfield dicts field of
58 (DB a, DB b) -> case hfield dicts field of
64− Dict -> case hfield specs field of
59+ Dict -> Const [(a <. b, a ==. b)]
65− SSpec {nullability} ->
66− Const [(slt nullability a b, seq nullability a b)]
67 where
60 where
68 dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
61 dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
69− specs = hspecs @(Columns a)
70 go (lt, eq) a = lt ||. (eq &&. a)
62 go (lt, eq) a = lt ||. (eq &&. a)
71infix 4 <:
63infix 4 <:
72
64
@@ -78,12 +70,9 @@ infix 4 <:
78 foldr @[] go true $ getConst $ htabulateA $ \field ->
70 foldr @[] go true $ getConst $ htabulateA $ \field ->
79 case (hfield as field, hfield bs field) of
71 case (hfield as field, hfield bs field) of
80 (DB a, DB b) -> case hfield dicts field of
72 (DB a, DB b) -> case hfield dicts field of
81− Dict -> case hfield specs field of
73+ Dict -> Const [(a <. b, a ==. b)]
82− SSpec {nullability} ->
83− Const [(slt nullability a b, seq nullability a b)]
84 where
74 where
85 dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
75 dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
86− specs = hspecs @(Columns a)
87 go (lt, eq) a = lt ||. (eq &&. a)
76 go (lt, eq) a = lt ||. (eq &&. a)
88infix 4 <=:
77infix 4 <=:
89
78
@@ -95,12 +84,9 @@ infix 4 <=:
95 foldr @[] go false $ getConst $ htabulateA $ \field ->
84 foldr @[] go false $ getConst $ htabulateA $ \field ->
96 case (hfield as field, hfield bs field) of
85 case (hfield as field, hfield bs field) of
97 (DB a, DB b) -> case hfield dicts field of
86 (DB a, DB b) -> case hfield dicts field of
98− Dict -> case hfield specs field of
87+ Dict -> Const [(a >. b, a ==. b)]
99− SSpec {nullability} ->
100− Const [(slt nullability a b, seq nullability a b)]
101 where
88 where
102 dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
89 dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
103− specs = hspecs @(Columns a)
104 go (gt, eq) a = gt ||. (eq &&. a)
90 go (gt, eq) a = gt ||. (eq &&. a)
105infix 4 >:
91infix 4 >:
106
92
@@ -112,12 +98,9 @@ infix 4 >:
112 foldr @[] go true $ getConst $ htabulateA $ \field ->
98 foldr @[] go true $ getConst $ htabulateA $ \field ->
113 case (hfield as field, hfield bs field) of
99 case (hfield as field, hfield bs field) of
114 (DB a, DB b) -> case hfield dicts field of
100 (DB a, DB b) -> case hfield dicts field of
115− Dict -> case hfield specs field of
101+ Dict -> Const [(a >. b, a ==. b)]
116− SSpec {nullability} ->
117− Const [(sgt nullability a b, seq nullability a b)]
118 where
102 where
119 dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
103 dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
120− specs = hspecs @(Columns a)
121 go (gt, eq) a = gt ||. (eq &&. a)
104 go (gt, eq) a = gt ||. (eq &&. a)
122infix 4 >=:
105infix 4 >=:
123
106
src/Rel8/Table/Order.hs+40−14
@@ -1,3 +1,4 @@
1+{-# language DataKinds #-}
1{-# language NamedFieldPuns #-}
2{-# language NamedFieldPuns #-}
2{-# language ScopedTypeVariables #-}
3{-# language ScopedTypeVariables #-}
3{-# language TypeApplications #-}
4{-# language TypeApplications #-}
@@ -20,8 +21,11 @@ import Rel8.Expr.Order ( asc, desc, nullsFirst, nullsLast )
20import Rel8.Order ( Order )
21import Rel8.Order ( Order )
21import Rel8.Schema.Dict ( Dict( Dict ) )
22import Rel8.Schema.Dict ( Dict( Dict ) )
22import Rel8.Schema.HTable (htabulateA, hfield, hdicts, hspecs)
23import Rel8.Schema.HTable (htabulateA, hfield, hdicts, hspecs)
23−import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ) )
24+import Rel8.Schema.Nullability
25+ ( Unnullify, Nullability( Nullable, NonNullable )
26+ , Sql, nullabilization
27+ )
24−import Rel8.Schema.Spec ( SSpec(..) )
28+import Rel8.Schema.Spec ( Spec( Spec ), SSpec( SSpec ) )
25import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
29import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
26import Rel8.Table
30import Rel8.Table
27import Rel8.Table.Ord
31import Rel8.Table.Ord
@@ -33,12 +37,13 @@ import Rel8.Type.Ord
33ascTable :: forall a. OrdTable a => Order a
37ascTable :: forall a. OrdTable a => Order a
34ascTable = contramap toColumns $ getConst $
38ascTable = contramap toColumns $ getConst $
35 htabulateA @(Columns a) $ \field -> case hfield hspecs field of
39 htabulateA @(Columns a) $ \field -> case hfield hspecs field of
36− SSpec {nullability} -> case hfield ords field of
40+ SSpec {} -> case hfield ords field of
41+ dict@Dict -> case ord dict of
37− Dict -> Const $ unDB . (`hfield` field) >$< case nullability of
42+ Dict -> Const $ unDB . (`hfield` field) >$< case nullability dict of
38− Nullable -> nullsFirst asc
43+ Nullable -> nullsFirst asc
39− NonNullable -> asc
44+ NonNullable -> asc
40− where
45+ where
41− ords = hdicts @(Columns a) @(ConstrainDBType DBOrd)
46+ ords = hdicts @(Columns a) @(ConstrainDBType DBOrd)
42
47
43
48
44-- | Construct an 'Order' for a 'Table' by sorting all columns into descending
49-- | Construct an 'Order' for a 'Table' by sorting all columns into descending
@@ -46,9 +51,30 @@ ascTable = contramap toColumns $ getConst $
46descTable :: forall a. OrdTable a => Order a
51descTable :: forall a. OrdTable a => Order a
47descTable = contramap toColumns $ getConst $
52descTable = contramap toColumns $ getConst $
48 htabulateA @(Columns a) $ \field -> case hfield hspecs field of
53 htabulateA @(Columns a) $ \field -> case hfield hspecs field of
49− SSpec {nullability} -> case hfield ords field of
54+ SSpec {} -> case hfield ords field of
55+ dict@Dict -> case ord dict of
50− Dict -> Const $ unDB . (`hfield` field) >$< case nullability of
56+ Dict -> Const $ unDB . (`hfield` field) >$< case nullability dict of
51− Nullable -> nullsLast desc
57+ Nullable -> nullsLast desc
52− NonNullable -> desc
58+ NonNullable -> desc
53− where
59+ where
54− ords = hdicts @(Columns a) @(ConstrainDBType DBOrd)
60+ ords = hdicts @(Columns a) @(ConstrainDBType DBOrd)
61+
62+
63+nullability :: Dict (ConstrainDBType DBOrd) ('Spec l n a) -> Nullability a
64+nullability = step2 . step1
65+ where
66+ step1 :: Dict (ConstrainDBType DBOrd) ('Spec l n a) -> Dict (Sql DBOrd) a
67+ step1 Dict = Dict
68+
69+ step2 :: Dict (Sql DBOrd) a -> Nullability a
70+ step2 Dict = nullabilization
71+
72+
73+ord :: Dict (ConstrainDBType DBOrd) ('Spec l n a) -> Dict DBOrd (Unnullify a)
74+ord = step2 . step1
75+ where
76+ step1 :: Dict (ConstrainDBType DBOrd) ('Spec l n a) -> Dict (Sql DBOrd) a
77+ step1 Dict = Dict
78+
79+ step2 :: Dict (Sql DBOrd) a -> Dict DBOrd (Unnullify a)
80+ step2 Dict = Dict
src/Rel8/Table/Undefined.hs+2−2
@@ -22,5 +22,5 @@ import Rel8.Table ( Table, fromColumns )
22undefined :: Table Expr a => a
22undefined :: Table Expr a => a
23undefined = fromColumns $ htabulate $ \field -> case hfield hspecs field of
23undefined = fromColumns $ htabulate $ \field -> case hfield hspecs field of
24 SSpec {nullability, info} -> case nullability of
24 SSpec {nullability, info} -> case nullability of
25− Nullable -> DB (snull Nullable info)
25+ Nullable -> DB (snull info)
26− NonNullable -> DB (unsafeUnnullify (snull Nullable info))
26+ NonNullable -> DB (unsafeUnnullify (snull info))
src/Rel8/Type/Array.hs+7−7
@@ -22,7 +22,7 @@ import qualified Hasql.Decoders as Hasql
22import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
22import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
23
23
24-- rel8
24-- rel8
25−import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ) )
25+import Rel8.Schema.Nullability ( Unnullify, Nullability( Nullable, NonNullable ) )
26import Rel8.Type.Information ( TypeInformation(..), parseTypeInformation )
26import Rel8.Type.Information ( TypeInformation(..), parseTypeInformation )
27
27
28
28
@@ -35,9 +35,9 @@ array TypeInformation {typeName} =
35
35
36
36
37listTypeInformation :: ()
37listTypeInformation :: ()
38− => Nullability a ma
38+ => Nullability a
39− -> TypeInformation a
39+ -> TypeInformation (Unnullify a)
40− -> TypeInformation [ma]
40+ -> TypeInformation [a]
41listTypeInformation nullability info =
41listTypeInformation nullability info =
42 case info of
42 case info of
43 TypeInformation{ encode, decode, out } -> TypeInformation
43 TypeInformation{ encode, decode, out } -> TypeInformation
@@ -56,9 +56,9 @@ listTypeInformation nullability info =
56
56
57
57
58nonEmptyTypeInformation :: ()
58nonEmptyTypeInformation :: ()
59− => Nullability a ma
59+ => Nullability a
60− -> TypeInformation a
60+ -> TypeInformation (Unnullify a)
61− -> TypeInformation (NonEmpty ma)
61+ -> TypeInformation (NonEmpty a)
62nonEmptyTypeInformation nullability =
62nonEmptyTypeInformation nullability =
63 parseTypeInformation parse toList . listTypeInformation nullability
63 parseTypeInformation parse toList . listTypeInformation nullability
64 where
64 where
src/Rel8/Type/Array1D.hs+3−3
@@ -92,9 +92,9 @@ type family IsArray1D a where
92 IsArray1D _ = 'False
92 IsArray1D _ = 'False
93
93
94
94
95−array1DTypeInformation :: IsArray1D db ~ 'False
95+array1DTypeInformation :: IsArray1D (Unnullify a) ~ 'False
96− => Nullability db a
96+ => Nullability a
97− -> TypeInformation db
97+ -> TypeInformation (Unnullify a)
98 -> TypeInformation (Array1D a)
98 -> TypeInformation (Array1D a)
99array1DTypeInformation nullability info =
99array1DTypeInformation nullability info =
100 case info of
100 case info of