git.iko.soy/rel8
on f47423e help sign in
rel8/src/Rel8/Table/Ord.hs
160 lines 4.8 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 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 GHC.Generics ( Rep )
24import Prelude hiding ( seq )
26-- rel8
27import Rel8.Expr ( Expr )
28import Rel8.Expr.Bool ( (||.), (&&.), false, true )
29import Rel8.Expr.Eq ( (==.) )
30import Rel8.Expr.Ord ( (<.), (>.) )
31import Rel8.FCF ( Eval, Exp )
32import Rel8.Generic.Record ( Record )
33import Rel8.Generic.Table.Record ( GTable, GColumns, gtable )
34import Rel8.Schema.Dict ( Dict( Dict ) )
35import Rel8.Schema.HTable ( htabulateA, hfield )
36import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
37import Rel8.Schema.Null (Sql)
38import Rel8.Table ( Columns, toColumns, TColumns, TFromExprs )
39import Rel8.Table.Bool ( bool )
40import Rel8.Table.Eq ( EqTable )
41import Rel8.Type.Ord ( DBOrd )
44-- | The class of 'Table's that can be ordered. Ordering on tables is defined
45-- by their lexicographic ordering of all columns, so this class means "all
46-- columns in a 'Table' have an instance of 'DBOrd'".
47type OrdTable :: Type -> Constraint
48class EqTable a => OrdTable a where
49 ordTable :: Columns a (Dict (Sql DBOrd))
51 default ordTable ::
52 ( GTable TOrdTable TColumns TFromExprs (Rep (Record a))
53 , Columns a ~ GColumns TColumns (Rep (Record a))
54 )
55 => Columns a (Dict (Sql DBOrd))
56 ordTable =
57 gtable
58 @TOrdTable
59 @TColumns
60 @TFromExprs
61 @(Rep (Record a))
62 table
63 where
64 table (_ :: proxy x) = ordTable @x
67data TOrdTable :: Type -> Exp Constraint
68type instance Eval (TOrdTable a) = OrdTable a
71instance Sql DBOrd a => OrdTable (Expr a) where
72 ordTable = HIdentity Dict
75instance (OrdTable a, OrdTable b) => OrdTable (a, b)
78instance (OrdTable a, OrdTable b, OrdTable c) => OrdTable (a, b, c)
81instance (OrdTable a, OrdTable b, OrdTable c, OrdTable d) => OrdTable (a, b, c, d)
84instance (OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e) =>
85 OrdTable (a, b, c, d, e)
88instance
89 ( OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e, OrdTable f
90 )
91 => OrdTable (a, b, c, d, e, f)
94instance
95 ( OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e, OrdTable f
96 , OrdTable g
97 )
98 => OrdTable (a, b, c, d, e, f, g)
101-- | Test if one 'Table' sorts before another. Corresponds to comparing all
102-- columns with '<'.
103(<:) :: forall a. OrdTable a => a -> a -> Expr Bool
104(toColumns -> as) <: (toColumns -> bs) =
105 foldr @[] go false $ getConst $ htabulateA $ \field ->
106 case (hfield as field, hfield bs field) of
107 (a, b) -> case hfield (ordTable @a) field of
108 Dict -> Const [(a <. b, a ==. b)]
109 where
110 go (lt, eq) a = lt ||. (eq &&. a)
111infix 4 <:
114-- | Test if one 'Table' sorts before, or is equal to, another. Corresponds to
115-- comparing all columns with '<='.
116(<=:) :: forall a. OrdTable a => a -> a -> Expr Bool
117(toColumns -> as) <=: (toColumns -> bs) =
118 foldr @[] go true $ getConst $ htabulateA $ \field ->
119 case (hfield as field, hfield bs field) of
120 (a, b) -> case hfield (ordTable @a) field of
121 Dict -> Const [(a <. b, a ==. b)]
122 where
123 go (lt, eq) a = lt ||. (eq &&. a)
124infix 4 <=:
127-- | Test if one 'Table' sorts after another. Corresponds to comparing all
128-- columns with '>'.
129(>:) :: forall a. OrdTable a => a -> a -> Expr Bool
130(toColumns -> as) >: (toColumns -> bs) =
131 foldr @[] go false $ getConst $ htabulateA $ \field ->
132 case (hfield as field, hfield bs field) of
133 (a, b) -> case hfield (ordTable @a) field of
134 Dict -> Const [(a >. b, a ==. b)]
135 where
136 go (gt, eq) a = gt ||. (eq &&. a)
137infix 4 >:
140-- | Test if one 'Table' sorts after another. Corresponds to comparing all
141-- columns with '>='.
142(>=:) :: forall a. OrdTable a => a -> a -> Expr Bool
143(toColumns -> as) >=: (toColumns -> bs) =
144 foldr @[] go true $ getConst $ htabulateA $ \field ->
145 case (hfield as field, hfield bs field) of
146 (a, b) -> case hfield (ordTable @a) field of
147 Dict -> Const [(a >. b, a ==. b)]
148 where
149 go (gt, eq) a = gt ||. (eq &&. a)
150infix 4 >=:
153-- | Given two 'Table's, return the table that sorts before the other.
154least :: OrdTable a => a -> a -> a
155least a b = bool a b (a <: b)
158-- | Given two 'Table's, return the table that sorts after the other.
159greatest :: OrdTable a => a -> a -> a
160greatest a b = bool a b (a >: b)