git.iko.soy/rel8
on ca7aaef help sign in
rel8/src/Rel8/Table/Eq.hs
146 lines 4.2 kB history raw
1{-# language AllowAmbiguousTypes #-}
2{-# language BlockArguments #-}
3{-# language DataKinds #-}
4{-# language DefaultSignatures #-}
5{-# language DisambiguateRecordFields #-}
6{-# language FlexibleContexts #-}
7{-# language FlexibleInstances #-}
8{-# language LambdaCase #-}
9{-# language NamedFieldPuns #-}
10{-# language ScopedTypeVariables #-}
11{-# language StandaloneKindSignatures #-}
12{-# language TypeApplications #-}
13{-# language TypeFamilies #-}
14{-# language UndecidableInstances #-}
15{-# language UndecidableSuperClasses #-}
16{-# language ViewPatterns #-}
18module Rel8.Table.Eq
19 ( EqTable( eqTable ), (==:), (/=:)
20 )
21where
23-- base
24import Data.Foldable ( foldl' )
25import Data.Functor.Const ( Const( Const ), getConst )
26import Data.Kind ( Constraint, Type )
27import Data.List.NonEmpty ( NonEmpty( (:|) ) )
28import Prelude
30-- rel8
31import Rel8.Expr ( Expr, Col(..) )
32import Rel8.Expr.Bool ( (||.), (&&.) )
33import Rel8.Expr.Eq ( (==.), (/=.) )
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 )
41import Rel8.Schema.HTable.Pair ( HPair(..) )
42import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
43import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
44import Rel8.Schema.HTable.Trio ( HTrio(..) )
45import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
46import Rel8.Table ( Table, Columns, toColumns )
47import Rel8.Type.Eq ( DBEq )
48import Rel8.Schema.Nullability ( Sql )
51type EqTable :: Type -> Constraint
52class Table Expr a => EqTable a where
53 eqTable :: Columns a (Dict (ConstrainDBType DBEq))
55 default eqTable :: ()
56 => HConstrainTable (Columns a) (ConstrainDBType DBEq)
57 => Columns a (Dict (ConstrainDBType DBEq))
58 eqTable = hdicts @(Columns a) @(ConstrainDBType DBEq)
61instance
62 ( Table Expr (t Expr)
63 , f ~ Expr
64 , HConstrainTable (Columns (t Expr)) (ConstrainDBType DBEq)
65 )
66 => EqTable (t f)
69instance
70 ( HTable t
71 , f ~ Col Expr
72 , HConstrainTable t (ConstrainDBType DBEq)
73 )
74 => EqTable (t f)
77instance Sql DBEq a => EqTable (Expr a)
80instance (EqTable a, EqTable b) => EqTable (a, b) where
81 eqTable =
82 HPair
83 { hfst = hlabel hlabeler (eqTable @a)
84 , hsnd = hlabel hlabeler (eqTable @b)
85 }
88instance (EqTable a, EqTable b, EqTable c) => EqTable (a, b, c) where
89 eqTable =
90 HTrio
91 { hfst = hlabel hlabeler (eqTable @a)
92 , hsnd = hlabel hlabeler (eqTable @b)
93 , htrd = hlabel hlabeler (eqTable @c)
94 }
97instance (EqTable a, EqTable b, EqTable c, EqTable d) => EqTable (a, b, c, d)
98 where
99 eqTable =
100 HQuartet
101 { hfst = hlabel hlabeler (eqTable @a)
102 , hsnd = hlabel hlabeler (eqTable @b)
103 , htrd = hlabel hlabeler (eqTable @c)
104 , hfrt = hlabel hlabeler (eqTable @d)
105 }
108instance (EqTable a, EqTable b, EqTable c, EqTable d, EqTable e) =>
109 EqTable (a, b, c, d, e)
110 where
111 eqTable =
112 HQuintet
113 { hfst = hlabel hlabeler (eqTable @a)
114 , hsnd = hlabel hlabeler (eqTable @b)
115 , htrd = hlabel hlabeler (eqTable @c)
116 , hfrt = hlabel hlabeler (eqTable @d)
117 , hfft = hlabel hlabeler (eqTable @e)
118 }
121-- | Compare two 'Table's for equality. This corresponds to comparing all
122-- columns inside each table for equality, and combining all comparisons with
123-- @AND@.
124(==:) :: forall a. EqTable a => a -> a -> Expr Bool
125(toColumns -> as) ==: (toColumns -> bs) =
126 foldl1' (&&.) $ getConst $ htabulateA $ \field ->
127 case (hfield as field, hfield bs field) of
128 (DB a, DB b) -> case hfield (eqTable @a) field of
129 Dict -> Const (pure (a ==. b))
130infix 4 ==:
133-- | Test if two 'Table's are different. This corresponds to comparing all
134-- columns inside each table for inequality, and combining all comparisons with
135-- @OR@.
136(/=:) :: forall a. EqTable a => a -> a -> Expr Bool
137(toColumns -> as) /=: (toColumns -> bs) =
138 foldl1' (||.) $ getConst $ htabulateA $ \field ->
139 case (hfield as field, hfield bs field) of
140 (DB a, DB b) -> case hfield (eqTable @a) field of
141 Dict -> Const (pure (a /=. b))
142infix 4 /=:
145foldl1' :: (a -> a -> a) -> NonEmpty a -> a
146foldl1' f (a :| as) = foldl' f a as