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