git.iko.soy/rel8
on c8341c1 help sign in
rel8/src/Rel8/Table/Ord.hs
195 lines 5.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 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(..) )
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.Type ( HType(..) )
45import Rel8.Schema.Kind ( Context )
46import Rel8.Schema.Null (Sql)
47import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType, nullifier )
48import Rel8.Table ( Table, Columns, toColumns, TColumns )
49import Rel8.Table.Bool ( bool )
50import Rel8.Table.Eq ( EqTable )
51import Rel8.Type.Eq ( DBEq )
52import Rel8.Type.Ord ( DBOrd )
55-- | The class of 'Table's that can be ordered. Ordering on tables is defined
56-- by their lexicographic ordering of all columns, so this class means "all
57-- columns in a 'Table' have an instance of 'DBOrd'".
58type OrdTable :: Type -> Constraint
59class EqTable a => OrdTable a where
60 ordTable :: Columns a (Dict (ConstrainDBType DBOrd))
62 default ordTable ::
63 ( KnownAlgebra (GAlgebra (Rep (Record a)))
64 , Eval (GGTable (GAlgebra (Rep (Record a))) TOrdTable TColumns (Dict (ConstrainDBType DBOrd)) (Rep (Record a)))
65 , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))
66 )
67 => Columns a (Dict (ConstrainDBType DBOrd))
68 ordTable =
69 ggtable
70 @(GAlgebra (Rep (Record a)))
71 @TOrdTable
72 @TColumns
73 @(Rep (Record a))
74 table
75 nullifier
76 where
77 table (_ :: proxy x) = ordTable @x
80data TOrdTable :: Type -> Exp Constraint
81type instance Eval (TOrdTable a) = OrdTable a
84instance
85 ( Table Expr (t (Expr :: Context))
86 , f ~ Expr
87 , HConstrainTable (Columns (t Expr)) (ConstrainDBType DBEq)
88 , HConstrainTable (Columns (t Expr)) (ConstrainDBType DBOrd)
89 )
90 => OrdTable (t f)
91 where
92 ordTable = hdicts @(Columns (t f)) @(ConstrainDBType DBOrd)
95instance
96 ( HTable t
97 , f ~ Col Expr
98 , HConstrainTable t (ConstrainDBType DBEq)
99 , HConstrainTable t (ConstrainDBType DBOrd)
100 )
101 => OrdTable (t f)
102 where
103 ordTable = hdicts @(Columns (t f)) @(ConstrainDBType DBOrd)
106instance Sql DBOrd a => OrdTable (Expr a) where
107 ordTable = HType Dict
110instance (OrdTable a, OrdTable b) => OrdTable (a, b)
113instance (OrdTable a, OrdTable b, OrdTable c) => OrdTable (a, b, c)
116instance (OrdTable a, OrdTable b, OrdTable c, OrdTable d) => OrdTable (a, b, c, d)
119instance (OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e) =>
120 OrdTable (a, b, c, d, e)
123instance
124 ( OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e, OrdTable f
125 )
126 => OrdTable (a, b, c, d, e, f)
129instance
130 ( OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e, OrdTable f
131 , OrdTable g
132 )
133 => OrdTable (a, b, c, d, e, f, g)
136-- | Test if one 'Table' sorts before another. Corresponds to comparing all
137-- columns with '<'.
138(<:) :: forall a. OrdTable a => a -> a -> Expr Bool
139(toColumns -> as) <: (toColumns -> bs) =
140 foldr @[] go false $ getConst $ htabulateA $ \field ->
141 case (hfield as field, hfield bs field) of
142 (DB a, DB b) -> case hfield (ordTable @a) field of
143 Dict -> Const [(a <. b, a ==. b)]
144 where
145 go (lt, eq) a = lt ||. (eq &&. a)
146infix 4 <:
149-- | Test if one 'Table' sorts before, or is equal to, another. Corresponds to
150-- comparing all columns with '<='.
151(<=:) :: forall a. OrdTable a => a -> a -> Expr Bool
152(toColumns -> as) <=: (toColumns -> bs) =
153 foldr @[] go true $ getConst $ htabulateA $ \field ->
154 case (hfield as field, hfield bs field) of
155 (DB a, DB b) -> case hfield (ordTable @a) field of
156 Dict -> Const [(a <. b, a ==. b)]
157 where
158 go (lt, eq) a = lt ||. (eq &&. a)
159infix 4 <=:
162-- | Test if one 'Table' sorts after another. Corresponds to comparing all
163-- columns with '>'.
164(>:) :: forall a. OrdTable a => a -> a -> Expr Bool
165(toColumns -> as) >: (toColumns -> bs) =
166 foldr @[] go false $ getConst $ htabulateA $ \field ->
167 case (hfield as field, hfield bs field) of
168 (DB a, DB b) -> case hfield (ordTable @a) field of
169 Dict -> Const [(a >. b, a ==. b)]
170 where
171 go (gt, eq) a = gt ||. (eq &&. a)
172infix 4 >:
175-- | Test if one 'Table' sorts after another. Corresponds to comparing all
176-- columns with '>='.
177(>=:) :: forall a. OrdTable a => a -> a -> Expr Bool
178(toColumns -> as) >=: (toColumns -> bs) =
179 foldr @[] go true $ getConst $ htabulateA $ \field ->
180 case (hfield as field, hfield bs field) of
181 (DB a, DB b) -> case hfield (ordTable @a) field of
182 Dict -> Const [(a >. b, a ==. b)]
183 where
184 go (gt, eq) a = gt ||. (eq &&. a)
185infix 4 >=:
188-- | Given two 'Table's, return the table that sorts before the other.
189least :: OrdTable a => a -> a -> a
190least a b = bool a b (a <: b)
193-- | Given two 'Table's, return the table that sorts after the other.
194greatest :: OrdTable a => a -> a -> a
195greatest a b = bool a b (a >: b)