git.iko.soy/rel8
on eb180fa help sign in
rel8/src/Rel8/Table/Ord.hs
120 lines 3.7 kB history raw
1{-# language DataKinds #-}
2{-# language FlexibleInstances #-}
3{-# language NamedFieldPuns #-}
4{-# language ScopedTypeVariables #-}
5{-# language StandaloneKindSignatures #-}
6{-# language TypeApplications #-}
7{-# language TypeFamilies #-}
8{-# language UndecidableInstances #-}
9{-# language UndecidableSuperClasses #-}
10{-# language ViewPatterns #-}
12module Rel8.Table.Ord
13 ( OrdTable, (<:), (<=:), (>:), (>=:), least, greatest
14 )
15where
17-- base
18import Data.Functor.Const ( Const( Const ), getConst )
19import Data.Kind ( Constraint, Type )
20import Prelude hiding ( seq )
22-- rel8
23import Rel8.Expr ( Expr )
24import Rel8.Expr.Bool ( (||.), (&&.), false, true )
25import Rel8.Expr.Eq ( seq )
26import Rel8.Expr.Ord ( slt, sgt)
27import Rel8.Opaque ( Opaque )
28import Rel8.Schema.Context ( Col'(..) )
29import Rel8.Schema.Dict ( Dict( Dict ) )
30import Rel8.Schema.HTable
31 ( HConstrainTable
32 , htabulateA, hfield
33 , hdicts, hspecs
34 )
35import Rel8.Schema.Spec ( SSpec(..) )
36import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
37import Rel8.Table ( Columns, toColumns )
38import Rel8.Table.Bool ( bool )
39import Rel8.Table.Eq ( EqTable )
40import Rel8.Type.Ord ( DBOrd )
43type OrdTable :: Type -> Constraint
44class
45 ( EqTable a
46 , HConstrainTable (Columns a) (ConstrainDBType DBOrd)
47 ) => OrdTable a
48instance
49 ( EqTable a
50 , HConstrainTable (Columns a) (ConstrainDBType DBOrd)
51 ) => OrdTable a
52instance {-# OVERLAPPING #-} OrdTable Opaque
55(<:) :: forall a. OrdTable a => a -> a -> Expr Bool
56(toColumns -> as) <: (toColumns -> bs) =
57 foldr @[] go false $ getConst $ htabulateA $ \field ->
58 case (hfield as field, hfield bs field) of
59 (DB a, DB b) -> case hfield dicts field of
60 Dict -> case hfield specs field of
61 SSpec {nullability} ->
62 Const [(slt nullability a b, seq nullability a b)]
63 where
64 dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
65 specs = hspecs @(Columns a)
66 go (lt, eq) a = lt ||. (eq &&. a)
67infix 4 <:
70(<=:) :: forall a. OrdTable a => a -> a -> Expr Bool
71(toColumns -> as) <=: (toColumns -> bs) =
72 foldr @[] go true $ getConst $ htabulateA $ \field ->
73 case (hfield as field, hfield bs field) of
74 (DB a, DB b) -> case hfield dicts field of
75 Dict -> case hfield specs field of
76 SSpec {nullability} ->
77 Const [(slt nullability a b, seq nullability a b)]
78 where
79 dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
80 specs = hspecs @(Columns a)
81 go (lt, eq) a = lt ||. (eq &&. a)
82infix 4 <=:
85(>:) :: forall a. OrdTable a => a -> a -> Expr Bool
86(toColumns -> as) >: (toColumns -> bs) =
87 foldr @[] go false $ getConst $ htabulateA $ \field ->
88 case (hfield as field, hfield bs field) of
89 (DB a, DB b) -> case hfield dicts field of
90 Dict -> case hfield specs field of
91 SSpec {nullability} ->
92 Const [(slt nullability a b, seq nullability a b)]
93 where
94 dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
95 specs = hspecs @(Columns a)
96 go (gt, eq) a = gt ||. (eq &&. a)
97infix 4 >:
100(>=:) :: forall a. OrdTable a => a -> a -> Expr Bool
101(toColumns -> as) >=: (toColumns -> bs) =
102 foldr @[] go true $ getConst $ htabulateA $ \field ->
103 case (hfield as field, hfield bs field) of
104 (DB a, DB b) -> case hfield dicts field of
105 Dict -> case hfield specs field of
106 SSpec {nullability} ->
107 Const [(sgt nullability a b, seq nullability a b)]
108 where
109 dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
110 specs = hspecs @(Columns a)
111 go (gt, eq) a = gt ||. (eq &&. a)
112infix 4 >=:
115least :: OrdTable a => a -> a -> a
116least a b = bool a b (a <: b)
119greatest :: OrdTable a => a -> a -> a
120greatest a b = bool a b (a >: b)