git.iko.soy/rel8
on 4e90af3 help sign in
rel8/src/Rel8/Table/Ord.hs
181 lines 5.6 kB history raw
1{-# language AllowAmbiguousTypes #-}
2{-# language DataKinds #-}
3{-# language DefaultSignatures #-}
4{-# language DisambiguateRecordFields #-}
5{-# language FlexibleInstances #-}
6{-# language ScopedTypeVariables #-}
7{-# language StandaloneKindSignatures #-}
8{-# language TypeApplications #-}
9{-# language TypeFamilies #-}
10{-# language UndecidableInstances #-}
11{-# language UndecidableSuperClasses #-}
12{-# language ViewPatterns #-}
14module Rel8.Table.Ord
15 ( OrdTable( ordTable ), (<:), (<=:), (>:), (>=:), least, greatest
16 )
17where
19-- base
20import Data.Functor.Const ( Const( Const ), getConst )
21import Data.Kind ( Constraint, Type )
22import Prelude hiding ( seq )
24-- rel8
25import Rel8.Expr ( Expr, Col(..) )
26import Rel8.Expr.Bool ( (||.), (&&.), false, true )
27import Rel8.Expr.Eq ( (==.) )
28import Rel8.Expr.Ord ( (<.), (>.) )
29import Rel8.Schema.Context.Label ( hlabeler )
30import Rel8.Schema.Dict ( Dict( Dict ) )
31import Rel8.Schema.HTable
32 ( HTable, HConstrainTable
33 , htabulateA, hfield, hdicts
34 )
35import Rel8.Schema.HTable.Label ( hlabel )
36import Rel8.Schema.HTable.Pair ( HPair(..) )
37import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
38import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
39import Rel8.Schema.HTable.Trio ( HTrio(..) )
40import Rel8.Schema.Null (Sql)
41import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
42import Rel8.Table ( Table, Columns, toColumns )
43import Rel8.Table.Bool ( bool )
44import Rel8.Table.Eq ( EqTable )
45import Rel8.Type.Eq ( DBEq )
46import Rel8.Type.Ord ( DBOrd )
49-- | The class of 'Table's that can be ordered. Ordering on tables is defined
50-- by their lexicographic ordering of all columns, so this class means "all
51-- columns in a 'Table' have an instance of 'DBOrd'".
52type OrdTable :: Type -> Constraint
53class EqTable a => OrdTable a where
54 ordTable :: Columns a (Dict (ConstrainDBType DBOrd))
56 default ordTable :: HConstrainTable (Columns a) (ConstrainDBType DBOrd) => Columns a (Dict (ConstrainDBType DBOrd))
57 ordTable = hdicts @(Columns a) @(ConstrainDBType DBOrd)
60instance
61 ( Table Expr (t Expr)
62 , f ~ Expr
63 , HConstrainTable (Columns (t Expr)) (ConstrainDBType DBEq)
64 , HConstrainTable (Columns (t Expr)) (ConstrainDBType DBOrd)
65 )
66 => OrdTable (t f)
69instance
70 ( HTable t
71 , f ~ Col Expr
72 , HConstrainTable t (ConstrainDBType DBEq)
73 , HConstrainTable t (ConstrainDBType DBOrd)
74 )
75 => OrdTable (t f)
78instance Sql DBOrd a => OrdTable (Expr a)
81instance (OrdTable a, OrdTable b) => OrdTable (a, b) where
82 ordTable =
83 HPair
84 { hfst = hlabel hlabeler (ordTable @a)
85 , hsnd = hlabel hlabeler (ordTable @b)
86 }
89instance (OrdTable a, OrdTable b, OrdTable c) => OrdTable (a, b, c) where
90 ordTable =
91 HTrio
92 { hfst = hlabel hlabeler (ordTable @a)
93 , hsnd = hlabel hlabeler (ordTable @b)
94 , htrd = hlabel hlabeler (ordTable @c)
95 }
98instance (OrdTable a, OrdTable b, OrdTable c, OrdTable d) => OrdTable (a, b, c, d)
99 where
100 ordTable =
101 HQuartet
102 { hfst = hlabel hlabeler (ordTable @a)
103 , hsnd = hlabel hlabeler (ordTable @b)
104 , htrd = hlabel hlabeler (ordTable @c)
105 , hfrt = hlabel hlabeler (ordTable @d)
106 }
109instance (OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e) =>
110 OrdTable (a, b, c, d, e)
111 where
112 ordTable =
113 HQuintet
114 { hfst = hlabel hlabeler (ordTable @a)
115 , hsnd = hlabel hlabeler (ordTable @b)
116 , htrd = hlabel hlabeler (ordTable @c)
117 , hfrt = hlabel hlabeler (ordTable @d)
118 , hfft = hlabel hlabeler (ordTable @e)
119 }
122-- | Test if one 'Table' sorts before another. Corresponds to comparing all
123-- columns with '<'.
124(<:) :: forall a. OrdTable a => a -> a -> Expr Bool
125(toColumns -> as) <: (toColumns -> bs) =
126 foldr @[] go false $ getConst $ htabulateA $ \field ->
127 case (hfield as field, hfield bs field) of
128 (DB a, DB b) -> case hfield (ordTable @a) field of
129 Dict -> Const [(a <. b, a ==. b)]
130 where
131 go (lt, eq) a = lt ||. (eq &&. a)
132infix 4 <:
135-- | Test if one 'Table' sorts before, or is equal to, another. Corresponds to
136-- comparing all columns with '<='.
137(<=:) :: forall a. OrdTable a => a -> a -> Expr Bool
138(toColumns -> as) <=: (toColumns -> bs) =
139 foldr @[] go true $ getConst $ htabulateA $ \field ->
140 case (hfield as field, hfield bs field) of
141 (DB a, DB b) -> case hfield (ordTable @a) field of
142 Dict -> Const [(a <. b, a ==. b)]
143 where
144 go (lt, eq) a = lt ||. (eq &&. a)
145infix 4 <=:
148-- | Test if one 'Table' sorts after another. Corresponds to comparing all
149-- columns with '>'.
150(>:) :: forall a. OrdTable a => a -> a -> Expr Bool
151(toColumns -> as) >: (toColumns -> bs) =
152 foldr @[] go false $ getConst $ htabulateA $ \field ->
153 case (hfield as field, hfield bs field) of
154 (DB a, DB b) -> case hfield (ordTable @a) field of
155 Dict -> Const [(a >. b, a ==. b)]
156 where
157 go (gt, eq) a = gt ||. (eq &&. a)
158infix 4 >:
161-- | Test if one 'Table' sorts after another. Corresponds to comparing all
162-- columns with '>='.
163(>=:) :: forall a. OrdTable a => a -> a -> Expr Bool
164(toColumns -> as) >=: (toColumns -> bs) =
165 foldr @[] go true $ getConst $ htabulateA $ \field ->
166 case (hfield as field, hfield bs field) of
167 (DB a, DB b) -> case hfield (ordTable @a) field of
168 Dict -> Const [(a >. b, a ==. b)]
169 where
170 go (gt, eq) a = gt ||. (eq &&. a)
171infix 4 >=:
174-- | Given two 'Table's, return the table that sorts before the other.
175least :: OrdTable a => a -> a -> a
176least a b = bool a b (a <: b)
179-- | Given two 'Table's, return the table that sorts after the other.
180greatest :: OrdTable a => a -> a -> a
181greatest a b = bool a b (a >: b)