git.iko.soy/rel8
on 97d89cf help sign in
rel8/src/Rel8/Table/Ord.hs
162 lines 5.0 kB history raw
1{-# language AllowAmbiguousTypes #-}
2{-# language DataKinds #-}
3{-# language DefaultSignatures #-}
4{-# language DisambiguateRecordFields #-}
5{-# language FlexibleContexts #-}
6{-# language FlexibleInstances #-}
7{-# language ScopedTypeVariables #-}
8{-# language StandaloneKindSignatures #-}
9{-# language TypeApplications #-}
10{-# language TypeFamilies #-}
11{-# language TypeOperators #-}
12{-# language UndecidableInstances #-}
13{-# language UndecidableSuperClasses #-}
14{-# language ViewPatterns #-}
16module Rel8.Table.Ord
17 ( OrdTable( ordTable ), (<:), (<=:), (>:), (>=:), least, greatest
18 )
19where
21-- base
22import Data.Functor.Const ( Const( Const ), getConst )
23import Data.Kind ( Constraint, Type )
24import GHC.Generics ( Rep )
25import Prelude hiding ( seq )
27-- rel8
28import Rel8.Expr ( Expr( E ) )
29import Rel8.Expr.Bool ( (||.), (&&.), false, true )
30import Rel8.Expr.Eq ( (==.) )
31import Rel8.Expr.Ord ( (<.), (>.) )
32import Rel8.FCF ( Eval, Exp )
33import Rel8.Generic.Record ( Record )
34import Rel8.Generic.Table.Record ( GTable, GColumns, gtable )
35import Rel8.Schema.Dict ( Dict( Dict ) )
36import Rel8.Schema.HTable ( htabulateA, hfield )
37import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )
38import Rel8.Schema.Null (Sql)
39import Rel8.Schema.Spec.Constrain ( ConstrainSpec )
40import Rel8.Table ( Columns, toColumns, TColumns, TFromExprs )
41import Rel8.Table.Bool ( bool )
42import Rel8.Table.Eq ( EqTable )
43import Rel8.Type.Ord ( DBOrd )
46-- | The class of 'Table's that can be ordered. Ordering on tables is defined
47-- by their lexicographic ordering of all columns, so this class means "all
48-- columns in a 'Table' have an instance of 'DBOrd'".
49type OrdTable :: Type -> Constraint
50class EqTable a => OrdTable a where
51 ordTable :: Columns a (Dict (ConstrainSpec (Sql DBOrd)))
53 default ordTable ::
54 ( GTable TOrdTable TColumns TFromExprs (Rep (Record a))
55 , Columns a ~ GColumns TColumns (Rep (Record a))
56 )
57 => Columns a (Dict (ConstrainSpec (Sql DBOrd)))
58 ordTable =
59 gtable
60 @TOrdTable
61 @TColumns
62 @TFromExprs
63 @(Rep (Record a))
64 table
65 where
66 table (_ :: proxy x) = ordTable @x
69data TOrdTable :: Type -> Exp Constraint
70type instance Eval (TOrdTable a) = OrdTable a
73instance Sql DBOrd a => OrdTable (Expr a) where
74 ordTable = HType Dict
77instance (OrdTable a, OrdTable b) => OrdTable (a, b)
80instance (OrdTable a, OrdTable b, OrdTable c) => OrdTable (a, b, c)
83instance (OrdTable a, OrdTable b, OrdTable c, OrdTable d) => OrdTable (a, b, c, d)
86instance (OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e) =>
87 OrdTable (a, b, c, d, e)
90instance
91 ( OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e, OrdTable f
92 )
93 => OrdTable (a, b, c, d, e, f)
96instance
97 ( OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e, OrdTable f
98 , OrdTable g
99 )
100 => OrdTable (a, b, c, d, e, f, g)
103-- | Test if one 'Table' sorts before another. Corresponds to comparing all
104-- columns with '<'.
105(<:) :: forall a. OrdTable a => a -> a -> Expr Bool
106(toColumns -> as) <: (toColumns -> bs) =
107 foldr @[] go false $ getConst $ htabulateA $ \field ->
108 case (hfield as field, hfield bs field) of
109 (E a, E b) -> case hfield (ordTable @a) field of
110 Dict -> Const [(a <. b, a ==. b)]
111 where
112 go (lt, eq) a = lt ||. (eq &&. a)
113infix 4 <:
116-- | Test if one 'Table' sorts before, or is equal to, another. Corresponds to
117-- comparing all columns with '<='.
118(<=:) :: forall a. OrdTable a => a -> a -> Expr Bool
119(toColumns -> as) <=: (toColumns -> bs) =
120 foldr @[] go true $ getConst $ htabulateA $ \field ->
121 case (hfield as field, hfield bs field) of
122 (E a, E b) -> case hfield (ordTable @a) field of
123 Dict -> Const [(a <. b, a ==. b)]
124 where
125 go (lt, eq) a = lt ||. (eq &&. a)
126infix 4 <=:
129-- | Test if one 'Table' sorts after another. Corresponds to comparing all
130-- columns with '>'.
131(>:) :: forall a. OrdTable a => a -> a -> Expr Bool
132(toColumns -> as) >: (toColumns -> bs) =
133 foldr @[] go false $ getConst $ htabulateA $ \field ->
134 case (hfield as field, hfield bs field) of
135 (E a, E b) -> case hfield (ordTable @a) field of
136 Dict -> Const [(a >. b, a ==. b)]
137 where
138 go (gt, eq) a = gt ||. (eq &&. a)
139infix 4 >:
142-- | Test if one 'Table' sorts after another. Corresponds to comparing all
143-- columns with '>='.
144(>=:) :: forall a. OrdTable a => a -> a -> Expr Bool
145(toColumns -> as) >=: (toColumns -> bs) =
146 foldr @[] go true $ getConst $ htabulateA $ \field ->
147 case (hfield as field, hfield bs field) of
148 (E a, E b) -> case hfield (ordTable @a) field of
149 Dict -> Const [(a >. b, a ==. b)]
150 where
151 go (gt, eq) a = gt ||. (eq &&. a)
152infix 4 >=:
155-- | Given two 'Table's, return the table that sorts before the other.
156least :: OrdTable a => a -> a -> a
157least a b = bool a b (a <: b)
160-- | Given two 'Table's, return the table that sorts after the other.
161greatest :: OrdTable a => a -> a -> a
162greatest a b = bool a b (a >: b)