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