git.iko.soy/rel8
on master help sign in
Start work breaking down EqTable and OrdTable

This allows instance resolution like (EqTable a, EqTable b) => EqTable (a, b) which would previously have failed.

commit8127f14ae97c1c2c040da47a42eba2b1ecefa339 authorOllie Charles <ollie@ocharles.org.uk> dateFri 26 Mar 2021, 15:54 (6 years ago) parent0f3d157
6 files changed+62−53
compare with master
unifiedsplit
src/Rel8/Schema/HTable.hs+2 src/Rel8/Schema/HTable/Label.hs+1−1 src/Rel8/Table/Aggregate.hs+4−8 src/Rel8/Table/Eq.hs+33−18 src/Rel8/Table/Ord.hs+19−19 src/Rel8/Table/Order.hs+3−7
src/Rel8/Schema/HTable.hs+2
@@ -19,6 +19,8 @@ module Rel8.Schema.HTable
1919 , htabulateA
2020
2121 , HPair(..)
22+ , HPairField(..)
23+ , GHField(..)
2224 )
2325where
2426
src/Rel8/Schema/HTable/Label.hs+1−1
@@ -19,7 +19,7 @@
1919{-# language UndecidableInstances #-}
2020
2121module Rel8.Schema.HTable.Label
22− ( HLabel
22+ ( HLabel, Label
2323 , hlabel, hunlabel
2424 )
2525where
src/Rel8/Table/Aggregate.hs+4−8
@@ -23,25 +23,21 @@ import Rel8.Aggregate ( Aggregate, Aggregates, Col(..) )
2323import Rel8.Expr ( Expr, Col(..) )
2424import Rel8.Expr.Aggregate ( groupByExpr, listAggExpr, nonEmptyAggExpr )
2525import Rel8.Schema.Dict ( Dict( Dict ) )
26−import Rel8.Schema.HTable ( htabulate, hfield, hdicts )
26+import Rel8.Schema.HTable ( htabulate, hfield )
2727import Rel8.Schema.HTable.Vectorize ( hvectorize )
28−import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
29−import Rel8.Table ( Table, Columns, toColumns, fromColumns )
30−import Rel8.Table.Eq ( EqTable )
28+import Rel8.Table ( Table, toColumns, fromColumns )
29+import Rel8.Table.Eq ( EqTable, eqTable )
3130import Rel8.Table.List ( ListTable )
3231import Rel8.Table.NonEmpty ( NonEmptyTable )
33−import Rel8.Type.Eq ( DBEq )
3432
3533
3634-- | Group equal tables together. This works by aggregating each column in the
3735-- given table with 'groupByExpr'.
3836groupBy :: forall exprs. EqTable exprs => exprs -> Aggregate exprs
3937groupBy (toColumns -> exprs) = fromColumns $ htabulate $ \field ->
40− case hfield dicts field of
38+ case hfield (eqTable @exprs) field of
4139 Dict -> case hfield exprs field of
4240 DB expr -> Aggregation $ groupByExpr expr
43− where
44− dicts = hdicts @(Columns exprs) @(ConstrainDBType DBEq)
4541
4642
4743-- | 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 #-}
13{-# language DataKinds #-}
4+{-# language DefaultSignatures #-}
25{-# language FlexibleContexts #-}
36{-# language FlexibleInstances #-}
7+{-# language LambdaCase #-}
48{-# language NamedFieldPuns #-}
59{-# language ScopedTypeVariables #-}
610{-# language StandaloneKindSignatures #-}
@@ -11,7 +15,7 @@
1115{-# language ViewPatterns #-}
1216
1317module Rel8.Table.Eq
14− ( EqTable, (==:), (/=:)
18+ ( EqTable( eqTable ), (==:), (/=:)
1519 )
1620where
1721
@@ -26,24 +30,39 @@ import Prelude
2630import Rel8.Expr ( Expr, Col(..) )
2731import Rel8.Expr.Bool ( (||.), (&&.) )
2832import Rel8.Expr.Eq ( (==.), (/=.) )
29−import Rel8.Opaque ( Opaque )
3033import 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 )
3235import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
3336import Rel8.Table ( Table, Columns, toColumns )
3437import Rel8.Type.Eq ( DBEq )
38+import Rel8.Schema.HTable.MapTable ( HMapTableField(..) )
39+import Rel8.Schema.Spec ( SSpec( SSpec ) )
40+import Rel8.Schema.Nullability ( Sql )
3541
3642
3743type EqTable :: Type -> Constraint
38−class
39− ( Table Expr a
40− , HConstrainTable (Columns a) (ConstrainDBType DBEq)
41− ) => EqTable a
42−instance
43− ( Table Expr a
44− , HConstrainTable (Columns a) (ConstrainDBType DBEq)
45− ) => EqTable a
46−instance {-# OVERLAPPING #-} EqTable Opaque
44+class Table Expr a => EqTable a where
45+ eqTable :: Columns a (Dict (ConstrainDBType DBEq))
46+
47+ default eqTable :: HConstrainTable (Columns a) (ConstrainDBType DBEq) => Columns a (Dict (ConstrainDBType DBEq))
48+ eqTable = hdicts @(Columns a) @(ConstrainDBType DBEq)
49+
50+
51+instance (Table Expr (t Expr), f ~ Expr, HConstrainTable (Columns (t Expr)) (ConstrainDBType DBEq)) => EqTable (t f)
52+
53+
54+instance Sql DBEq a => EqTable (Expr a)
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
4766
4867
4968-- | Compare two 'Table's for equality. This corresponds to comparing all
@@ -53,10 +72,8 @@ instance {-# OVERLAPPING #-} EqTable Opaque
5372(toColumns -> as) ==: (toColumns -> bs) =
5473 foldl1' (&&.) $ getConst $ htabulateA $ \field ->
5574 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
5776 Dict -> Const (pure (a ==. b))
58− where
59− dicts = hdicts @(Columns a) @(ConstrainDBType DBEq)
6077infix 4 ==:
6178
6279
@@ -67,10 +84,8 @@ infix 4 ==:
6784(toColumns -> as) /=: (toColumns -> bs) =
6885 foldl1' (||.) $ getConst $ htabulateA $ \field ->
6986 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
7188 Dict -> Const (pure (a /=. b))
72− where
73− dicts = hdicts @(Columns a) @(ConstrainDBType DBEq)
7489infix 4 /=:
7590
7691
src/Rel8/Table/Ord.hs+19−19
@@ -1,4 +1,6 @@
1+{-# language AllowAmbiguousTypes #-}
12{-# language DataKinds #-}
3+{-# language DefaultSignatures #-}
24{-# language FlexibleInstances #-}
35{-# language NamedFieldPuns #-}
46{-# language ScopedTypeVariables #-}
@@ -10,7 +12,7 @@
1012{-# language ViewPatterns #-}
1113
1214module Rel8.Table.Ord
13− ( OrdTable, (<:), (<=:), (>:), (>=:), least, greatest
15+ ( OrdTable( ordTable ), (<:), (<=:), (>:), (>=:), least, greatest
1416 )
1517where
1618
@@ -24,7 +26,6 @@ import Rel8.Expr ( Expr, Col(..) )
2426import Rel8.Expr.Bool ( (||.), (&&.), false, true )
2527import Rel8.Expr.Eq ( (==.) )
2628import Rel8.Expr.Ord ( (<.), (>.) )
27−import Rel8.Opaque ( Opaque )
2829import Rel8.Schema.Dict ( Dict( Dict ) )
2930import Rel8.Schema.HTable ( HConstrainTable, htabulateA, hfield, hdicts )
3031import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
@@ -32,21 +33,24 @@ import Rel8.Table ( Columns, toColumns )
3233import Rel8.Table.Bool ( bool )
3334import Rel8.Table.Eq ( EqTable )
3435import Rel8.Type.Ord ( DBOrd )
36+import Rel8.Schema.Nullability (Sql)
3537
3638
3739-- | The class of 'Table's that can be ordered. Ordering on tables is defined
3840-- by their lexicographic ordering of all columns, so this class means "all
3941-- columns in a 'Table' have an instance of 'DBOrd'".
4042type OrdTable :: Type -> Constraint
41−class
42− ( EqTable a
43− , HConstrainTable (Columns a) (ConstrainDBType DBOrd)
44− ) => OrdTable a
45−instance
46− ( EqTable a
47− , HConstrainTable (Columns a) (ConstrainDBType DBOrd)
48− ) => OrdTable a
49−instance {-# OVERLAPPING #-} OrdTable Opaque
43+class EqTable a => OrdTable a where
44+ ordTable :: Columns a (Dict (ConstrainDBType DBOrd))
45+
46+ default ordTable :: HConstrainTable (Columns a) (ConstrainDBType DBOrd) => Columns a (Dict (ConstrainDBType DBOrd))
47+ ordTable = hdicts @(Columns a) @(ConstrainDBType DBOrd)
48+
49+
50+instance (EqTable (t Expr), f ~ Expr, HConstrainTable (Columns (t Expr)) (ConstrainDBType DBOrd)) => OrdTable (t f)
51+
52+
53+instance Sql DBOrd a => OrdTable (Expr a)
5054
5155
5256-- | Test if one 'Table' sorts before another. Corresponds to comparing all
@@ -55,10 +59,9 @@ instance {-# OVERLAPPING #-} OrdTable Opaque
5559(toColumns -> as) <: (toColumns -> bs) =
5660 foldr @[] go false $ getConst $ htabulateA $ \field ->
5761 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
5963 Dict -> Const [(a <. b, a ==. b)]
6064 where
61− dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
6265 go (lt, eq) a = lt ||. (eq &&. a)
6366infix 4 <:
6467
@@ -69,10 +72,9 @@ infix 4 <:
6972(toColumns -> as) <=: (toColumns -> bs) =
7073 foldr @[] go true $ getConst $ htabulateA $ \field ->
7174 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
7376 Dict -> Const [(a <. b, a ==. b)]
7477 where
75− dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
7678 go (lt, eq) a = lt ||. (eq &&. a)
7779infix 4 <=:
7880
@@ -83,10 +85,9 @@ infix 4 <=:
8385(toColumns -> as) >: (toColumns -> bs) =
8486 foldr @[] go false $ getConst $ htabulateA $ \field ->
8587 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
8789 Dict -> Const [(a >. b, a ==. b)]
8890 where
89− dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
9091 go (gt, eq) a = gt ||. (eq &&. a)
9192infix 4 >:
9293
@@ -97,10 +98,9 @@ infix 4 >:
9798(toColumns -> as) >=: (toColumns -> bs) =
9899 foldr @[] go true $ getConst $ htabulateA $ \field ->
99100 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
101102 Dict -> Const [(a >. b, a ==. b)]
102103 where
103− dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
104104 go (gt, eq) a = gt ||. (eq &&. a)
105105infix 4 >=:
106106
src/Rel8/Table/Order.hs+3−7
@@ -20,7 +20,7 @@ import Rel8.Expr ( unDB )
2020import Rel8.Expr.Order ( asc, desc, nullsFirst, nullsLast )
2121import Rel8.Order ( Order )
2222import Rel8.Schema.Dict ( Dict( Dict ) )
23−import Rel8.Schema.HTable (htabulateA, hfield, hdicts, hspecs)
23+import Rel8.Schema.HTable (htabulateA, hfield, hspecs)
2424import Rel8.Schema.Nullability
2525 ( Unnullify, Nullability( Nullable, NonNullable )
2626 , Sql, nullabilization
@@ -37,13 +37,11 @@ import Rel8.Type.Ord
3737ascTable :: forall a. OrdTable a => Order a
3838ascTable = contramap toColumns $ getConst $
3939 htabulateA @(Columns a) $ \field -> case hfield hspecs field of
40− SSpec {} -> case hfield ords field of
40+ SSpec {} -> case hfield (ordTable @a) field of
4141 dict@Dict -> case ord dict of
4242 Dict -> Const $ unDB . (`hfield` field) >$< case nullability dict of
4343 Nullable -> nullsFirst asc
4444 NonNullable -> asc
45− where
46− ords = hdicts @(Columns a) @(ConstrainDBType DBOrd)
4745
4846
4947-- | Construct an 'Order' for a 'Table' by sorting all columns into descending
@@ -51,13 +49,11 @@ ascTable = contramap toColumns $ getConst $
5149descTable :: forall a. OrdTable a => Order a
5250descTable = contramap toColumns $ getConst $
5351 htabulateA @(Columns a) $ \field -> case hfield hspecs field of
54− SSpec {} -> case hfield ords field of
52+ SSpec {} -> case hfield (ordTable @a) field of
5553 dict@Dict -> case ord dict of
5654 Dict -> Const $ unDB . (`hfield` field) >$< case nullability dict of
5755 Nullable -> nullsLast desc
5856 NonNullable -> desc
59− where
60− ords = hdicts @(Columns a) @(ConstrainDBType DBOrd)
6157
6258
6359nullability :: Dict (ConstrainDBType DBOrd) ('Spec l n a) -> Nullability a