git.iko.soy/rel8
on be54907 help sign in
rel8/src/Rel8/Table/Ord.hs
183 lines 5.5 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, Col( 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
35 ( GGTable, GGColumns, ggtable
36 , GAlgebra
37 )
38import Rel8.Kind.Algebra ( KnownAlgebra )
39import Rel8.Schema.Dict ( Dict( Dict ) )
40import Rel8.Schema.HTable
41 ( HTable, HConstrainTable
42 , htabulateA, hfield, hdicts
43 )
44import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )
45import Rel8.Schema.Null (Sql)
46import Rel8.Schema.Spec.Constrain ( ConstrainSpec )
47import Rel8.Table ( Columns, toColumns, TColumns )
48import Rel8.Table.Bool ( bool )
49import Rel8.Table.Eq ( EqTable )
50import Rel8.Type.Eq ( DBEq )
51import Rel8.Type.Ord ( DBOrd )
54-- | The class of 'Table's that can be ordered. Ordering on tables is defined
55-- by their lexicographic ordering of all columns, so this class means "all
56-- columns in a 'Table' have an instance of 'DBOrd'".
57type OrdTable :: Type -> Constraint
58class EqTable a => OrdTable a where
59 ordTable :: Columns a (Dict (ConstrainSpec (Sql DBOrd)))
61 default ordTable ::
62 ( KnownAlgebra (GAlgebra (Rep (Record a)))
63 , Eval (GGTable (GAlgebra (Rep (Record a))) TOrdTable TColumns (Dict (ConstrainSpec (Sql DBOrd))) (Rep (Record a)))
64 , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))
65 )
66 => Columns a (Dict (ConstrainSpec (Sql DBOrd)))
67 ordTable =
68 ggtable
69 @(GAlgebra (Rep (Record a)))
70 @TOrdTable
71 @TColumns
72 @(Rep (Record a))
73 table
74 (\_ Dict -> Dict)
75 where
76 table (_ :: proxy x) = ordTable @x
79data TOrdTable :: Type -> Exp Constraint
80type instance Eval (TOrdTable a) = OrdTable a
83instance
84 ( HTable t
85 , f ~ Col Expr
86 , HConstrainTable t (ConstrainSpec (Sql DBEq))
87 , HConstrainTable t (ConstrainSpec (Sql DBOrd))
88 )
89 => OrdTable (t f)
90 where
91 ordTable = hdicts @(Columns (t f)) @(ConstrainSpec (Sql DBOrd))
94instance Sql DBOrd a => OrdTable (Expr a) where
95 ordTable = HType Dict
98instance (OrdTable a, OrdTable b) => OrdTable (a, b)
101instance (OrdTable a, OrdTable b, OrdTable c) => OrdTable (a, b, c)
104instance (OrdTable a, OrdTable b, OrdTable c, OrdTable d) => OrdTable (a, b, c, d)
107instance (OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e) =>
108 OrdTable (a, b, c, d, e)
111instance
112 ( OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e, OrdTable f
113 )
114 => OrdTable (a, b, c, d, e, f)
117instance
118 ( OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e, OrdTable f
119 , OrdTable g
120 )
121 => OrdTable (a, b, c, d, e, f, g)
124-- | Test if one 'Table' sorts before another. Corresponds to comparing all
125-- columns with '<'.
126(<:) :: forall a. OrdTable a => a -> a -> Expr Bool
127(toColumns -> as) <: (toColumns -> bs) =
128 foldr @[] go false $ getConst $ htabulateA $ \field ->
129 case (hfield as field, hfield bs field) of
130 (E a, E b) -> case hfield (ordTable @a) field of
131 Dict -> Const [(a <. b, a ==. b)]
132 where
133 go (lt, eq) a = lt ||. (eq &&. a)
134infix 4 <:
137-- | Test if one 'Table' sorts before, or is equal to, another. Corresponds to
138-- comparing all columns with '<='.
139(<=:) :: forall a. OrdTable a => a -> a -> Expr Bool
140(toColumns -> as) <=: (toColumns -> bs) =
141 foldr @[] go true $ getConst $ htabulateA $ \field ->
142 case (hfield as field, hfield bs field) of
143 (E a, E b) -> case hfield (ordTable @a) field of
144 Dict -> Const [(a <. b, a ==. b)]
145 where
146 go (lt, eq) a = lt ||. (eq &&. a)
147infix 4 <=:
150-- | Test if one 'Table' sorts after another. Corresponds to comparing all
151-- columns with '>'.
152(>:) :: forall a. OrdTable a => a -> a -> Expr Bool
153(toColumns -> as) >: (toColumns -> bs) =
154 foldr @[] go false $ getConst $ htabulateA $ \field ->
155 case (hfield as field, hfield bs field) of
156 (E a, E b) -> case hfield (ordTable @a) field of
157 Dict -> Const [(a >. b, a ==. b)]
158 where
159 go (gt, eq) a = gt ||. (eq &&. a)
160infix 4 >:
163-- | Test if one 'Table' sorts after another. Corresponds to comparing all
164-- columns with '>='.
165(>=:) :: forall a. OrdTable a => a -> a -> Expr Bool
166(toColumns -> as) >=: (toColumns -> bs) =
167 foldr @[] go true $ getConst $ htabulateA $ \field ->
168 case (hfield as field, hfield bs field) of
169 (E a, E b) -> case hfield (ordTable @a) field of
170 Dict -> Const [(a >. b, a ==. b)]
171 where
172 go (gt, eq) a = gt ||. (eq &&. a)
173infix 4 >=:
176-- | Given two 'Table's, return the table that sorts before the other.
177least :: OrdTable a => a -> a -> a
178least a b = bool a b (a <: b)
181-- | Given two 'Table's, return the table that sorts after the other.
182greatest :: OrdTable a => a -> a -> a
183greatest a b = bool a b (a >: b)