git.iko.soy/rel8
on master help sign in
Start work breaking down EqTable and OrdTable
8127f14Ollie Charles
src/Rel8/Schema/HTable.hs+2
compare with master
unifiedsplit
@@ -19,6 +19,8 @@ module Rel8.Schema.HTable
19 , htabulateA
19 , htabulateA
20
20
21 , HPair(..)
21 , HPair(..)
22+ , HPairField(..)
23+ , GHField(..)
22 )
24 )
23where
25where
24
26
src/Rel8/Schema/HTable/Label.hs+1−1
@@ -19,7 +19,7 @@
19{-# language UndecidableInstances #-}
19{-# language UndecidableInstances #-}
20
20
21module Rel8.Schema.HTable.Label
21module Rel8.Schema.HTable.Label
22− ( HLabel
22+ ( HLabel, Label
23 , hlabel, hunlabel
23 , hlabel, hunlabel
24 )
24 )
25where
25where
src/Rel8/Table/Aggregate.hs+4−8
@@ -23,25 +23,21 @@ import Rel8.Aggregate ( Aggregate, Aggregates, Col(..) )
23import Rel8.Expr ( Expr, Col(..) )
23import Rel8.Expr ( Expr, Col(..) )
24import Rel8.Expr.Aggregate ( groupByExpr, listAggExpr, nonEmptyAggExpr )
24import Rel8.Expr.Aggregate ( groupByExpr, listAggExpr, nonEmptyAggExpr )
25import Rel8.Schema.Dict ( Dict( Dict ) )
25import Rel8.Schema.Dict ( Dict( Dict ) )
26−import Rel8.Schema.HTable ( htabulate, hfield, hdicts )
26+import Rel8.Schema.HTable ( htabulate, hfield )
27import Rel8.Schema.HTable.Vectorize ( hvectorize )
27import Rel8.Schema.HTable.Vectorize ( hvectorize )
28−import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
29−import Rel8.Table ( Table, Columns, toColumns, fromColumns )
28+import Rel8.Table ( Table, toColumns, fromColumns )
30−import Rel8.Table.Eq ( EqTable )
29+import Rel8.Table.Eq ( EqTable, eqTable )
31import Rel8.Table.List ( ListTable )
30import Rel8.Table.List ( ListTable )
32import Rel8.Table.NonEmpty ( NonEmptyTable )
31import Rel8.Table.NonEmpty ( NonEmptyTable )
33−import Rel8.Type.Eq ( DBEq )
34
32
35
33
36-- | Group equal tables together. This works by aggregating each column in the
34-- | Group equal tables together. This works by aggregating each column in the
37-- given table with 'groupByExpr'.
35-- given table with 'groupByExpr'.
38groupBy :: forall exprs. EqTable exprs => exprs -> Aggregate exprs
36groupBy :: forall exprs. EqTable exprs => exprs -> Aggregate exprs
39groupBy (toColumns -> exprs) = fromColumns $ htabulate $ \field ->
37groupBy (toColumns -> exprs) = fromColumns $ htabulate $ \field ->
40− case hfield dicts field of
38+ case hfield (eqTable @exprs) field of
41 Dict -> case hfield exprs field of
39 Dict -> case hfield exprs field of
42 DB expr -> Aggregation $ groupByExpr expr
40 DB expr -> Aggregation $ groupByExpr expr
43− where
44− dicts = hdicts @(Columns exprs) @(ConstrainDBType DBEq)
45
41
46
42
47-- | Aggregate rows into a single row containing an array of all aggregated
43-- | Aggregate rows into a single row containing an array of all aggregated
src/Rel8/Table/Eq.hs+33−18
@@ -1,6 +1,10 @@
1+{-# language AllowAmbiguousTypes #-}
2+{-# language BlockArguments #-}
1{-# language DataKinds #-}
3{-# language DataKinds #-}
4+{-# language DefaultSignatures #-}
2{-# language FlexibleContexts #-}
5{-# language FlexibleContexts #-}
3{-# language FlexibleInstances #-}
6{-# language FlexibleInstances #-}
7+{-# language LambdaCase #-}
4{-# language NamedFieldPuns #-}
8{-# language NamedFieldPuns #-}
5{-# language ScopedTypeVariables #-}
9{-# language ScopedTypeVariables #-}
6{-# language StandaloneKindSignatures #-}
10{-# language StandaloneKindSignatures #-}
@@ -11,7 +15,7 @@
11{-# language ViewPatterns #-}
15{-# language ViewPatterns #-}
12
16
13module Rel8.Table.Eq
17module Rel8.Table.Eq
14− ( EqTable, (==:), (/=:)
18+ ( EqTable( eqTable ), (==:), (/=:)
15 )
19 )
16where
20where
17
21
@@ -26,24 +30,39 @@ import Prelude
26import Rel8.Expr ( Expr, Col(..) )
30import Rel8.Expr ( Expr, Col(..) )
27import Rel8.Expr.Bool ( (||.), (&&.) )
31import Rel8.Expr.Bool ( (||.), (&&.) )
28import Rel8.Expr.Eq ( (==.), (/=.) )
32import Rel8.Expr.Eq ( (==.), (/=.) )
29−import Rel8.Opaque ( Opaque )
30import Rel8.Schema.Dict ( Dict( Dict ) )
33import Rel8.Schema.Dict ( Dict( Dict ) )
31−import Rel8.Schema.HTable ( HConstrainTable, htabulateA, hfield, hdicts )
34+import Rel8.Schema.HTable ( HConstrainTable, HPairField(..), GHField(..), htabulate, htabulateA, hfield, hdicts, hspecs )
32import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
35import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
33import Rel8.Table ( Table, Columns, toColumns )
36import Rel8.Table ( Table, Columns, toColumns )
34import Rel8.Type.Eq ( DBEq )
37import Rel8.Type.Eq ( DBEq )
38+import Rel8.Schema.HTable.MapTable ( HMapTableField(..) )
39+import Rel8.Schema.Spec ( SSpec( SSpec ) )
40+import Rel8.Schema.Nullability ( Sql )
35
41
36
42
37type EqTable :: Type -> Constraint
43type EqTable :: Type -> Constraint
38−class
44+class Table Expr a => EqTable a where
39− ( Table Expr a
45+ eqTable :: Columns a (Dict (ConstrainDBType DBEq))
46+
40− , HConstrainTable (Columns a) (ConstrainDBType DBEq)
47+ default eqTable :: HConstrainTable (Columns a) (ConstrainDBType DBEq) => Columns a (Dict (ConstrainDBType DBEq))
41− ) => EqTable a
48+ eqTable = hdicts @(Columns a) @(ConstrainDBType DBEq)
42−instance
49+
43− ( Table Expr a
50+
44− , HConstrainTable (Columns a) (ConstrainDBType DBEq)
51+instance (Table Expr (t Expr), f ~ Expr, HConstrainTable (Columns (t Expr)) (ConstrainDBType DBEq)) => EqTable (t f)
52+
53+
45− ) => EqTable a
54+instance Sql DBEq a => EqTable (Expr a)
46−instance {-# OVERLAPPING #-} EqTable Opaque
55+
56+
57+instance (EqTable a, EqTable b) => EqTable (a, b) where
58+ eqTable = htabulate \case
59+ HFst (GHField (HMapTableField i)) ->
60+ case hfield hspecs i of
61+ SSpec{} -> case hfield (eqTable @a) i of Dict -> Dict
62+
63+ HSnd (GHField (HMapTableField i)) ->
64+ case hfield hspecs i of
65+ SSpec{} -> case hfield (eqTable @b) i of Dict -> Dict
47
66
48
67
49-- | Compare two 'Table's for equality. This corresponds to comparing all
68-- | Compare two 'Table's for equality. This corresponds to comparing all
@@ -53,10 +72,8 @@ instance {-# OVERLAPPING #-} EqTable Opaque
53(toColumns -> as) ==: (toColumns -> bs) =
72(toColumns -> as) ==: (toColumns -> bs) =
54 foldl1' (&&.) $ getConst $ htabulateA $ \field ->
73 foldl1' (&&.) $ getConst $ htabulateA $ \field ->
55 case (hfield as field, hfield bs field) of
74 case (hfield as field, hfield bs field) of
56− (DB a, DB b) -> case hfield dicts field of
75+ (DB a, DB b) -> case hfield (eqTable @a) field of
57 Dict -> Const (pure (a ==. b))
76 Dict -> Const (pure (a ==. b))
58− where
59− dicts = hdicts @(Columns a) @(ConstrainDBType DBEq)
60infix 4 ==:
77infix 4 ==:
61
78
62
79
@@ -67,10 +84,8 @@ infix 4 ==:
67(toColumns -> as) /=: (toColumns -> bs) =
84(toColumns -> as) /=: (toColumns -> bs) =
68 foldl1' (||.) $ getConst $ htabulateA $ \field ->
85 foldl1' (||.) $ getConst $ htabulateA $ \field ->
69 case (hfield as field, hfield bs field) of
86 case (hfield as field, hfield bs field) of
70− (DB a, DB b) -> case hfield dicts field of
87+ (DB a, DB b) -> case hfield (eqTable @a) field of
71 Dict -> Const (pure (a /=. b))
88 Dict -> Const (pure (a /=. b))
72− where
73− dicts = hdicts @(Columns a) @(ConstrainDBType DBEq)
74infix 4 /=:
89infix 4 /=:
75
90
76
91
src/Rel8/Table/Ord.hs+19−19
@@ -1,4 +1,6 @@
1+{-# language AllowAmbiguousTypes #-}
1{-# language DataKinds #-}
2{-# language DataKinds #-}
3+{-# language DefaultSignatures #-}
2{-# language FlexibleInstances #-}
4{-# language FlexibleInstances #-}
3{-# language NamedFieldPuns #-}
5{-# language NamedFieldPuns #-}
4{-# language ScopedTypeVariables #-}
6{-# language ScopedTypeVariables #-}
@@ -10,7 +12,7 @@
10{-# language ViewPatterns #-}
12{-# language ViewPatterns #-}
11
13
12module Rel8.Table.Ord
14module Rel8.Table.Ord
13− ( OrdTable, (<:), (<=:), (>:), (>=:), least, greatest
15+ ( OrdTable( ordTable ), (<:), (<=:), (>:), (>=:), least, greatest
14 )
16 )
15where
17where
16
18
@@ -24,7 +26,6 @@ import Rel8.Expr ( Expr, Col(..) )
24import Rel8.Expr.Bool ( (||.), (&&.), false, true )
26import Rel8.Expr.Bool ( (||.), (&&.), false, true )
25import Rel8.Expr.Eq ( (==.) )
27import Rel8.Expr.Eq ( (==.) )
26import Rel8.Expr.Ord ( (<.), (>.) )
28import Rel8.Expr.Ord ( (<.), (>.) )
27−import Rel8.Opaque ( Opaque )
28import Rel8.Schema.Dict ( Dict( Dict ) )
29import Rel8.Schema.Dict ( Dict( Dict ) )
29import Rel8.Schema.HTable ( HConstrainTable, htabulateA, hfield, hdicts )
30import Rel8.Schema.HTable ( HConstrainTable, htabulateA, hfield, hdicts )
30import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
31import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
@@ -32,21 +33,24 @@ import Rel8.Table ( Columns, toColumns )
32import Rel8.Table.Bool ( bool )
33import Rel8.Table.Bool ( bool )
33import Rel8.Table.Eq ( EqTable )
34import Rel8.Table.Eq ( EqTable )
34import Rel8.Type.Ord ( DBOrd )
35import Rel8.Type.Ord ( DBOrd )
36+import Rel8.Schema.Nullability (Sql)
35
37
36
38
37-- | The class of 'Table's that can be ordered. Ordering on tables is defined
39-- | The class of 'Table's that can be ordered. Ordering on tables is defined
38-- by their lexicographic ordering of all columns, so this class means "all
40-- by their lexicographic ordering of all columns, so this class means "all
39-- columns in a 'Table' have an instance of 'DBOrd'".
41-- columns in a 'Table' have an instance of 'DBOrd'".
40type OrdTable :: Type -> Constraint
42type OrdTable :: Type -> Constraint
41−class
43+class EqTable a => OrdTable a where
42− ( EqTable a
44+ ordTable :: Columns a (Dict (ConstrainDBType DBOrd))
45+
43− , HConstrainTable (Columns a) (ConstrainDBType DBOrd)
46+ default ordTable :: HConstrainTable (Columns a) (ConstrainDBType DBOrd) => Columns a (Dict (ConstrainDBType DBOrd))
44− ) => OrdTable a
47+ ordTable = hdicts @(Columns a) @(ConstrainDBType DBOrd)
45−instance
48+
46− ( EqTable a
49+
47− , HConstrainTable (Columns a) (ConstrainDBType DBOrd)
50+instance (EqTable (t Expr), f ~ Expr, HConstrainTable (Columns (t Expr)) (ConstrainDBType DBOrd)) => OrdTable (t f)
48− ) => OrdTable a
51+
52+
49−instance {-# OVERLAPPING #-} OrdTable Opaque
53+instance Sql DBOrd a => OrdTable (Expr a)
50
54
51
55
52-- | Test if one 'Table' sorts before another. Corresponds to comparing all
56-- | Test if one 'Table' sorts before another. Corresponds to comparing all
@@ -55,10 +59,9 @@ instance {-# OVERLAPPING #-} OrdTable Opaque
55(toColumns -> as) <: (toColumns -> bs) =
59(toColumns -> as) <: (toColumns -> bs) =
56 foldr @[] go false $ getConst $ htabulateA $ \field ->
60 foldr @[] go false $ getConst $ htabulateA $ \field ->
57 case (hfield as field, hfield bs field) of
61 case (hfield as field, hfield bs field) of
58− (DB a, DB b) -> case hfield dicts field of
62+ (DB a, DB b) -> case hfield (ordTable @a) field of
59 Dict -> Const [(a <. b, a ==. b)]
63 Dict -> Const [(a <. b, a ==. b)]
60 where
64 where
61− dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
62 go (lt, eq) a = lt ||. (eq &&. a)
65 go (lt, eq) a = lt ||. (eq &&. a)
63infix 4 <:
66infix 4 <:
64
67
@@ -69,10 +72,9 @@ infix 4 <:
69(toColumns -> as) <=: (toColumns -> bs) =
72(toColumns -> as) <=: (toColumns -> bs) =
70 foldr @[] go true $ getConst $ htabulateA $ \field ->
73 foldr @[] go true $ getConst $ htabulateA $ \field ->
71 case (hfield as field, hfield bs field) of
74 case (hfield as field, hfield bs field) of
72− (DB a, DB b) -> case hfield dicts field of
75+ (DB a, DB b) -> case hfield (ordTable @a) field of
73 Dict -> Const [(a <. b, a ==. b)]
76 Dict -> Const [(a <. b, a ==. b)]
74 where
77 where
75− dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
76 go (lt, eq) a = lt ||. (eq &&. a)
78 go (lt, eq) a = lt ||. (eq &&. a)
77infix 4 <=:
79infix 4 <=:
78
80
@@ -83,10 +85,9 @@ infix 4 <=:
83(toColumns -> as) >: (toColumns -> bs) =
85(toColumns -> as) >: (toColumns -> bs) =
84 foldr @[] go false $ getConst $ htabulateA $ \field ->
86 foldr @[] go false $ getConst $ htabulateA $ \field ->
85 case (hfield as field, hfield bs field) of
87 case (hfield as field, hfield bs field) of
86− (DB a, DB b) -> case hfield dicts field of
88+ (DB a, DB b) -> case hfield (ordTable @a) field of
87 Dict -> Const [(a >. b, a ==. b)]
89 Dict -> Const [(a >. b, a ==. b)]
88 where
90 where
89− dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
90 go (gt, eq) a = gt ||. (eq &&. a)
91 go (gt, eq) a = gt ||. (eq &&. a)
91infix 4 >:
92infix 4 >:
92
93
@@ -97,10 +98,9 @@ infix 4 >:
97(toColumns -> as) >=: (toColumns -> bs) =
98(toColumns -> as) >=: (toColumns -> bs) =
98 foldr @[] go true $ getConst $ htabulateA $ \field ->
99 foldr @[] go true $ getConst $ htabulateA $ \field ->
99 case (hfield as field, hfield bs field) of
100 case (hfield as field, hfield bs field) of
100− (DB a, DB b) -> case hfield dicts field of
101+ (DB a, DB b) -> case hfield (ordTable @a) field of
101 Dict -> Const [(a >. b, a ==. b)]
102 Dict -> Const [(a >. b, a ==. b)]
102 where
103 where
103− dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
104 go (gt, eq) a = gt ||. (eq &&. a)
104 go (gt, eq) a = gt ||. (eq &&. a)
105infix 4 >=:
105infix 4 >=:
106
106
src/Rel8/Table/Order.hs+3−7
@@ -20,7 +20,7 @@ import Rel8.Expr ( unDB )
20import Rel8.Expr.Order ( asc, desc, nullsFirst, nullsLast )
20import Rel8.Expr.Order ( asc, desc, nullsFirst, nullsLast )
21import Rel8.Order ( Order )
21import Rel8.Order ( Order )
22import Rel8.Schema.Dict ( Dict( Dict ) )
22import Rel8.Schema.Dict ( Dict( Dict ) )
23−import Rel8.Schema.HTable (htabulateA, hfield, hdicts, hspecs)
23+import Rel8.Schema.HTable (htabulateA, hfield, hspecs)
24import Rel8.Schema.Nullability
24import Rel8.Schema.Nullability
25 ( Unnullify, Nullability( Nullable, NonNullable )
25 ( Unnullify, Nullability( Nullable, NonNullable )
26 , Sql, nullabilization
26 , Sql, nullabilization
@@ -37,13 +37,11 @@ import Rel8.Type.Ord
37ascTable :: forall a. OrdTable a => Order a
37ascTable :: forall a. OrdTable a => Order a
38ascTable = contramap toColumns $ getConst $
38ascTable = contramap toColumns $ getConst $
39 htabulateA @(Columns a) $ \field -> case hfield hspecs field of
39 htabulateA @(Columns a) $ \field -> case hfield hspecs field of
40− SSpec {} -> case hfield ords field of
40+ SSpec {} -> case hfield (ordTable @a) field of
41 dict@Dict -> case ord dict of
41 dict@Dict -> case ord dict of
42 Dict -> Const $ unDB . (`hfield` field) >$< case nullability dict of
42 Dict -> Const $ unDB . (`hfield` field) >$< case nullability dict of
43 Nullable -> nullsFirst asc
43 Nullable -> nullsFirst asc
44 NonNullable -> asc
44 NonNullable -> asc
45− where
46− ords = hdicts @(Columns a) @(ConstrainDBType DBOrd)
47
45
48
46
49-- | Construct an 'Order' for a 'Table' by sorting all columns into descending
47-- | Construct an 'Order' for a 'Table' by sorting all columns into descending
@@ -51,13 +49,11 @@ ascTable = contramap toColumns $ getConst $
51descTable :: forall a. OrdTable a => Order a
49descTable :: forall a. OrdTable a => Order a
52descTable = contramap toColumns $ getConst $
50descTable = contramap toColumns $ getConst $
53 htabulateA @(Columns a) $ \field -> case hfield hspecs field of
51 htabulateA @(Columns a) $ \field -> case hfield hspecs field of
54− SSpec {} -> case hfield ords field of
52+ SSpec {} -> case hfield (ordTable @a) field of
55 dict@Dict -> case ord dict of
53 dict@Dict -> case ord dict of
56 Dict -> Const $ unDB . (`hfield` field) >$< case nullability dict of
54 Dict -> Const $ unDB . (`hfield` field) >$< case nullability dict of
57 Nullable -> nullsLast desc
55 Nullable -> nullsLast desc
58 NonNullable -> desc
56 NonNullable -> desc
59− where
60− ords = hdicts @(Columns a) @(ConstrainDBType DBOrd)
61
57
62
58
63nullability :: Dict (ConstrainDBType DBOrd) ('Spec l n a) -> Nullability a
59nullability :: Dict (ConstrainDBType DBOrd) ('Spec l n a) -> Nullability a