git.iko.soy/rel8
on fb21075 help sign in
rel8/src/Rel8/Table/Ord.hs
195 lines 5.9 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, (:*:), K1, M1, Meta( MetaSel ), D, C, S )
25import GHC.TypeLits ( KnownSymbol )
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.Generic.Record ( Record )
34import Rel8.Schema.Context.Label ( hlabeler )
35import Rel8.Schema.Dict ( Dict( Dict ) )
36import Rel8.Schema.HTable
37 ( HTable, HConstrainTable
38 , htabulateA, hfield, hdicts
39 )
40import Rel8.Schema.HTable.Label ( HLabel, hlabel )
41import Rel8.Schema.HTable.Product ( HProduct(..) )
42import Rel8.Schema.HTable.Type ( HType(..) )
43import Rel8.Schema.Kind ( Context )
44import Rel8.Schema.Null (Sql)
45import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
46import Rel8.Table ( Table, Columns, toColumns, GColumns )
47import Rel8.Table.Bool ( bool )
48import Rel8.Table.Eq ( EqTable )
49import Rel8.Type.Eq ( DBEq )
50import Rel8.Type.Ord ( DBOrd )
53-- | The class of 'Table's that can be ordered. Ordering on tables is defined
54-- by their lexicographic ordering of all columns, so this class means "all
55-- columns in a 'Table' have an instance of 'DBOrd'".
56type OrdTable :: Type -> Constraint
57class EqTable a => OrdTable a where
58 ordTable :: Columns a (Dict (ConstrainDBType DBOrd))
60 default ordTable ::
61 ( GColumns (Rep (Record a)) ~ Columns a
62 , GOrdTable (Rep (Record a))
63 )
64 => Columns a (Dict (ConstrainDBType DBOrd))
65 ordTable = gordTable @(Rep (Record a))
68type GOrdTable :: (Type -> Type) -> Constraint
69class GOrdTable rep where
70 gordTable :: GColumns rep (Dict (ConstrainDBType DBOrd))
73instance GOrdTable rep => GOrdTable (M1 D c rep) where
74 gordTable = gordTable @rep
77instance GOrdTable rep => GOrdTable (M1 C c rep) where
78 gordTable = gordTable @rep
81instance (GOrdTable rep1, GOrdTable rep2) => GOrdTable (rep1 :*: rep2) where
82 gordTable = HProduct (gordTable @rep1) (gordTable @rep2)
85instance
86 ( OrdTable a
87 , KnownSymbol label
88 , GColumns (M1 S meta k1) ~ HLabel label (Columns a)
89 , meta ~ 'MetaSel ('Just label) _su _ss _ds
90 , k1 ~ K1 i a
91 )
92 => GOrdTable (M1 S meta k1)
93 where
94 gordTable = hlabel hlabeler (ordTable @a)
97instance
98 ( Table Expr (t (Expr :: Context))
99 , f ~ Expr
100 , HConstrainTable (Columns (t Expr)) (ConstrainDBType DBEq)
101 , HConstrainTable (Columns (t Expr)) (ConstrainDBType DBOrd)
102 )
103 => OrdTable (t f)
104 where
105 ordTable = hdicts @(Columns (t f)) @(ConstrainDBType DBOrd)
108instance
109 ( HTable t
110 , f ~ Col Expr
111 , HConstrainTable t (ConstrainDBType DBEq)
112 , HConstrainTable t (ConstrainDBType DBOrd)
113 )
114 => OrdTable (t f)
115 where
116 ordTable = hdicts @(Columns (t f)) @(ConstrainDBType DBOrd)
119instance Sql DBOrd a => OrdTable (Expr a) where
120 ordTable = HType Dict
123instance (OrdTable a, OrdTable b) => OrdTable (a, b)
126instance (OrdTable a, OrdTable b, OrdTable c) => OrdTable (a, b, c)
129instance (OrdTable a, OrdTable b, OrdTable c, OrdTable d) => OrdTable (a, b, c, d)
132instance (OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e) =>
133 OrdTable (a, b, c, d, e)
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)