git.iko.soy/rel8
on dec2074 help sign in
rel8/src/Rel8/Table/Ord.hs
132 lines 4.4 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 ( seq )
26import Rel8.Expr.Ord ( slt, sgt)
27import Rel8.Opaque ( Opaque )
28import Rel8.Schema.Dict ( Dict( Dict ) )
29import Rel8.Schema.HTable
30 ( HConstrainTable
31 , htabulateA, hfield
32 , hdicts, hspecs
33 )
34import Rel8.Schema.Spec ( SSpec(..) )
35import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
36import Rel8.Table ( Columns, toColumns )
37import Rel8.Table.Bool ( bool )
38import Rel8.Table.Eq ( EqTable )
39import Rel8.Type.Ord ( DBOrd )
42-- | The class of 'Table's that can be ordered. Ordering on tables is defined
43-- by their lexicographic ordering of all columns, so this class means "all
44-- columns in a 'Table' have an instance of 'DBOrd'".
45type OrdTable :: Type -> Constraint
46class
47 ( EqTable a
48 , HConstrainTable (Columns a) (ConstrainDBType DBOrd)
49 ) => OrdTable a
50instance
51 ( EqTable a
52 , HConstrainTable (Columns a) (ConstrainDBType DBOrd)
53 ) => OrdTable a
54instance {-# OVERLAPPING #-} OrdTable Opaque
57-- | Test if one 'Table' sorts before another. Corresponds to comparing all
58-- columns with '<'.
59(<:) :: forall a. OrdTable a => a -> a -> Expr Bool
60(toColumns -> as) <: (toColumns -> bs) =
61 foldr @[] go false $ getConst $ htabulateA $ \field ->
62 case (hfield as field, hfield bs field) of
63 (DB a, DB b) -> case hfield dicts field of
64 Dict -> case hfield specs field of
65 SSpec {nullability} ->
66 Const [(slt nullability a b, seq nullability a b)]
67 where
68 dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
69 specs = hspecs @(Columns a)
70 go (lt, eq) a = lt ||. (eq &&. a)
71infix 4 <:
74-- | Test if one 'Table' sorts before, or is equal to, another. Corresponds to
75-- comparing all columns with '<='.
76(<=:) :: forall a. OrdTable a => a -> a -> Expr Bool
77(toColumns -> as) <=: (toColumns -> bs) =
78 foldr @[] go true $ getConst $ htabulateA $ \field ->
79 case (hfield as field, hfield bs field) of
80 (DB a, DB b) -> case hfield dicts field of
81 Dict -> case hfield specs field of
82 SSpec {nullability} ->
83 Const [(slt nullability a b, seq nullability a b)]
84 where
85 dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
86 specs = hspecs @(Columns a)
87 go (lt, eq) a = lt ||. (eq &&. a)
88infix 4 <=:
91-- | Test if one 'Table' sorts after another. Corresponds to comparing all
92-- columns with '>'.
93(>:) :: forall a. OrdTable a => a -> a -> Expr Bool
94(toColumns -> as) >: (toColumns -> bs) =
95 foldr @[] go false $ getConst $ htabulateA $ \field ->
96 case (hfield as field, hfield bs field) of
97 (DB a, DB b) -> case hfield dicts field of
98 Dict -> case hfield specs field of
99 SSpec {nullability} ->
100 Const [(slt nullability a b, seq nullability a b)]
101 where
102 dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
103 specs = hspecs @(Columns a)
104 go (gt, eq) a = gt ||. (eq &&. a)
105infix 4 >:
108-- | Test if one 'Table' sorts after another. Corresponds to comparing all
109-- columns with '>='.
110(>=:) :: forall a. OrdTable a => a -> a -> Expr Bool
111(toColumns -> as) >=: (toColumns -> bs) =
112 foldr @[] go true $ getConst $ htabulateA $ \field ->
113 case (hfield as field, hfield bs field) of
114 (DB a, DB b) -> case hfield dicts field of
115 Dict -> case hfield specs field of
116 SSpec {nullability} ->
117 Const [(sgt nullability a b, seq nullability a b)]
118 where
119 dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
120 specs = hspecs @(Columns a)
121 go (gt, eq) a = gt ||. (eq &&. a)
122infix 4 >=:
125-- | Given two 'Table's, return the table that sorts before the other.
126least :: OrdTable a => a -> a -> a
127least a b = bool a b (a <: b)
130-- | Given two 'Table's, return the table that sorts after the other.
131greatest :: OrdTable a => a -> a -> a
132greatest a b = bool a b (a >: b)