git.iko.soy/rel8
on 1c73ec6 help sign in
rel8/src/Rel8/Table/Ord.hs
184 lines 5.6 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 Data.Proxy ( Proxy )
25import GHC.Generics ( Rep )
26import Prelude hiding ( seq )
28-- rel8
29import Rel8.Expr ( Expr, Col(..) )
30import Rel8.Expr.Bool ( (||.), (&&.), false, true )
31import Rel8.Expr.Eq ( (==.) )
32import Rel8.Expr.Ord ( (<.), (>.) )
33import Rel8.FCF ( Eval, Exp )
34import Rel8.Generic.Record ( Record )
35import Rel8.Generic.Table ( GTable, GColumns, gtable )
36import Rel8.Schema.Dict ( Dict( Dict ) )
37import Rel8.Schema.HTable
38 ( HTable, HConstrainTable
39 , htabulateA, hfield, hdicts
40 )
41import Rel8.Schema.HTable.Type ( HType(..) )
42import Rel8.Schema.Kind ( Context )
43import Rel8.Schema.Null (Sql)
44import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
45import Rel8.Table ( Table, Columns, toColumns, TColumns )
46import Rel8.Table.Bool ( bool )
47import Rel8.Table.Eq ( EqTable )
48import Rel8.Type.Eq ( DBEq )
49import Rel8.Type.Ord ( DBOrd )
52-- | The class of 'Table's that can be ordered. Ordering on tables is defined
53-- by their lexicographic ordering of all columns, so this class means "all
54-- columns in a 'Table' have an instance of 'DBOrd'".
55type OrdTable :: Type -> Constraint
56class EqTable a => OrdTable a where
57 ordTable :: Columns a (Dict (ConstrainDBType DBOrd))
59 default ordTable ::
60 ( GTable TOrdTable TColumns (Dict (ConstrainDBType DBOrd)) (Rep (Record a))
61 , Columns a ~ GColumns TColumns (Rep (Record a))
62 )
63 => Columns a (Dict (ConstrainDBType DBOrd))
64 ordTable = gtable @TOrdTable @TColumns @_ @(Rep (Record a)) table
65 where
66 table (_ :: Proxy x) = ordTable @x
69data TOrdTable :: Type -> Exp Constraint
70type instance Eval (TOrdTable a) = OrdTable a
73instance
74 ( Table Expr (t (Expr :: Context))
75 , f ~ Expr
76 , HConstrainTable (Columns (t Expr)) (ConstrainDBType DBEq)
77 , HConstrainTable (Columns (t Expr)) (ConstrainDBType DBOrd)
78 )
79 => OrdTable (t f)
80 where
81 ordTable = hdicts @(Columns (t f)) @(ConstrainDBType DBOrd)
84instance
85 ( HTable t
86 , f ~ Col Expr
87 , HConstrainTable t (ConstrainDBType DBEq)
88 , HConstrainTable t (ConstrainDBType DBOrd)
89 )
90 => OrdTable (t f)
91 where
92 ordTable = hdicts @(Columns (t f)) @(ConstrainDBType DBOrd)
95instance Sql DBOrd a => OrdTable (Expr a) where
96 ordTable = HType Dict
99instance (OrdTable a, OrdTable b) => OrdTable (a, b)
102instance (OrdTable a, OrdTable b, OrdTable c) => OrdTable (a, b, c)
105instance (OrdTable a, OrdTable b, OrdTable c, OrdTable d) => OrdTable (a, b, c, d)
108instance (OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e) =>
109 OrdTable (a, b, c, d, e)
112instance
113 ( OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e, OrdTable f
114 )
115 => OrdTable (a, b, c, d, e, f)
118instance
119 ( OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e, OrdTable f
120 , OrdTable g
121 )
122 => OrdTable (a, b, c, d, e, f, g)
125-- | Test if one 'Table' sorts before another. Corresponds to comparing all
126-- columns with '<'.
127(<:) :: forall a. OrdTable a => a -> a -> Expr Bool
128(toColumns -> as) <: (toColumns -> bs) =
129 foldr @[] go false $ getConst $ htabulateA $ \field ->
130 case (hfield as field, hfield bs field) of
131 (DB a, DB b) -> case hfield (ordTable @a) field of
132 Dict -> Const [(a <. b, a ==. b)]
133 where
134 go (lt, eq) a = lt ||. (eq &&. a)
135infix 4 <:
138-- | Test if one 'Table' sorts before, or is equal to, another. Corresponds to
139-- comparing all columns with '<='.
140(<=:) :: forall a. OrdTable a => a -> a -> Expr Bool
141(toColumns -> as) <=: (toColumns -> bs) =
142 foldr @[] go true $ getConst $ htabulateA $ \field ->
143 case (hfield as field, hfield bs field) of
144 (DB a, DB b) -> case hfield (ordTable @a) field of
145 Dict -> Const [(a <. b, a ==. b)]
146 where
147 go (lt, eq) a = lt ||. (eq &&. a)
148infix 4 <=:
151-- | Test if one 'Table' sorts after another. Corresponds to comparing all
152-- columns with '>'.
153(>:) :: forall a. OrdTable a => a -> a -> Expr Bool
154(toColumns -> as) >: (toColumns -> bs) =
155 foldr @[] go false $ getConst $ htabulateA $ \field ->
156 case (hfield as field, hfield bs field) of
157 (DB a, DB b) -> case hfield (ordTable @a) field of
158 Dict -> Const [(a >. b, a ==. b)]
159 where
160 go (gt, eq) a = gt ||. (eq &&. a)
161infix 4 >:
164-- | Test if one 'Table' sorts after another. Corresponds to comparing all
165-- columns with '>='.
166(>=:) :: forall a. OrdTable a => a -> a -> Expr Bool
167(toColumns -> as) >=: (toColumns -> bs) =
168 foldr @[] go true $ getConst $ htabulateA $ \field ->
169 case (hfield as field, hfield bs field) of
170 (DB a, DB b) -> case hfield (ordTable @a) field of
171 Dict -> Const [(a >. b, a ==. b)]
172 where
173 go (gt, eq) a = gt ||. (eq &&. a)
174infix 4 >=:
177-- | Given two 'Table's, return the table that sorts before the other.
178least :: OrdTable a => a -> a -> a
179least a b = bool a b (a <: b)
182-- | Given two 'Table's, return the table that sorts after the other.
183greatest :: OrdTable a => a -> a -> a
184greatest a b = bool a b (a >: b)