git.iko.soy/rel8
on 11bcbbb help sign in
rel8/src/Rel8/Table/Ord.hs
115 lines 3.9 kB history raw
1{-# language DataKinds #-}
2{-# language FlexibleInstances #-}
3{-# language NamedFieldPuns #-}
4{-# language ScopedTypeVariables #-}
5{-# language StandaloneKindSignatures #-}
6{-# language TypeApplications #-}
7{-# language TypeFamilies #-}
8{-# language UndecidableInstances #-}
9{-# language UndecidableSuperClasses #-}
10{-# language ViewPatterns #-}
12module Rel8.Table.Ord
13 ( OrdTable, (<:), (<=:), (>:), (>=:), least, greatest
14 )
15where
17-- base
18import Data.Functor.Const ( Const( Const ), getConst )
19import Data.Kind ( Constraint, Type )
20import Prelude hiding ( seq )
22-- rel8
23import Rel8.Expr ( Expr, Col(..) )
24import Rel8.Expr.Bool ( (||.), (&&.), false, true )
25import Rel8.Expr.Eq ( (==.) )
26import Rel8.Expr.Ord ( (<.), (>.) )
27import Rel8.Opaque ( Opaque )
28import Rel8.Schema.Dict ( Dict( Dict ) )
29import Rel8.Schema.HTable ( HConstrainTable, htabulateA, hfield, hdicts )
30import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
31import Rel8.Table ( Columns, toColumns )
32import Rel8.Table.Bool ( bool )
33import Rel8.Table.Eq ( EqTable )
34import Rel8.Type.Ord ( DBOrd )
37-- | 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
39-- columns in a 'Table' have an instance of 'DBOrd'".
40type OrdTable :: Type -> Constraint
41class
42 ( EqTable a
43 , HConstrainTable (Columns a) (ConstrainDBType DBOrd)
44 ) => OrdTable a
45instance
46 ( EqTable a
47 , HConstrainTable (Columns a) (ConstrainDBType DBOrd)
48 ) => OrdTable a
49instance {-# OVERLAPPING #-} OrdTable Opaque
52-- | Test if one 'Table' sorts before another. Corresponds to comparing all
53-- columns with '<'.
54(<:) :: forall a. OrdTable a => a -> a -> Expr Bool
55(toColumns -> as) <: (toColumns -> bs) =
56 foldr @[] go false $ getConst $ htabulateA $ \field ->
57 case (hfield as field, hfield bs field) of
58 (DB a, DB b) -> case hfield dicts field of
59 Dict -> Const [(a <. b, a ==. b)]
60 where
61 dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
62 go (lt, eq) a = lt ||. (eq &&. a)
63infix 4 <:
66-- | Test if one 'Table' sorts before, or is equal to, another. Corresponds to
67-- comparing all columns with '<='.
68(<=:) :: forall a. OrdTable a => a -> a -> Expr Bool
69(toColumns -> as) <=: (toColumns -> bs) =
70 foldr @[] go true $ getConst $ htabulateA $ \field ->
71 case (hfield as field, hfield bs field) of
72 (DB a, DB b) -> case hfield dicts field of
73 Dict -> Const [(a <. b, a ==. b)]
74 where
75 dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
76 go (lt, eq) a = lt ||. (eq &&. a)
77infix 4 <=:
80-- | Test if one 'Table' sorts after another. Corresponds to comparing all
81-- columns with '>'.
82(>:) :: forall a. OrdTable a => a -> a -> Expr Bool
83(toColumns -> as) >: (toColumns -> bs) =
84 foldr @[] go false $ getConst $ htabulateA $ \field ->
85 case (hfield as field, hfield bs field) of
86 (DB a, DB b) -> case hfield dicts field of
87 Dict -> Const [(a >. b, a ==. b)]
88 where
89 dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
90 go (gt, eq) a = gt ||. (eq &&. a)
91infix 4 >:
94-- | Test if one 'Table' sorts after another. Corresponds to comparing all
95-- columns with '>='.
96(>=:) :: forall a. OrdTable a => a -> a -> Expr Bool
97(toColumns -> as) >=: (toColumns -> bs) =
98 foldr @[] go true $ getConst $ htabulateA $ \field ->
99 case (hfield as field, hfield bs field) of
100 (DB a, DB b) -> case hfield dicts field of
101 Dict -> Const [(a >. b, a ==. b)]
102 where
103 dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
104 go (gt, eq) a = gt ||. (eq &&. a)
105infix 4 >=:
108-- | Given two 'Table's, return the table that sorts before the other.
109least :: OrdTable a => a -> a -> a
110least a b = bool a b (a <: b)
113-- | Given two 'Table's, return the table that sorts after the other.
114greatest :: OrdTable a => a -> a -> a
115greatest a b = bool a b (a >: b)