git.iko.soy/rel8
on 2ba99ea help sign in
rel8/src/Rel8/Table/Eq.hs
145 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 ScopedTypeVariables #-}
9{-# language StandaloneKindSignatures #-}
10{-# language TypeApplications #-}
11{-# language TypeFamilies #-}
12{-# language TypeOperators #-}
13{-# language UndecidableInstances #-}
14{-# language UndecidableSuperClasses #-}
15{-# language ViewPatterns #-}
17module Rel8.Table.Eq
18 ( EqTable( eqTable ), (==:), (/=:)
19 )
20where
22-- base
23import Data.Foldable ( foldl' )
24import Data.Functor.Const ( Const( Const ), getConst )
25import Data.Kind ( Constraint, Type )
26import Data.List.NonEmpty ( NonEmpty( (:|) ) )
27import GHC.Generics ( Rep )
28import Prelude
30-- rel8
31import Rel8.Expr ( Expr, Col( E ) )
32import Rel8.Expr.Bool ( (||.), (&&.) )
33import Rel8.Expr.Eq ( (==.), (/=.) )
34import Rel8.FCF ( Eval, Exp )
35import Rel8.Generic.Record ( Record )
36import Rel8.Generic.Table
37 ( GGTable, GGColumns, ggtable
38 , GAlgebra
39 )
40import Rel8.Kind.Algebra ( KnownAlgebra )
41import Rel8.Schema.Dict ( Dict( Dict ) )
42import Rel8.Schema.HTable
43 ( HTable, HConstrainTable
44 , htabulateA, hfield, hdicts
45 )
46import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )
47import Rel8.Schema.Null ( Sql )
48import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType, nullifier )
49import Rel8.Table ( Table, Columns, toColumns, TColumns )
50import Rel8.Type.Eq ( DBEq )
53-- | The class of 'Table's that can be compared for equality. Equality on
54-- tables is defined by equality of all columns all columns, so this class
55-- means "all columns in a 'Table' have an instance of 'DBEq'".
56type EqTable :: Type -> Constraint
57class Table Expr a => EqTable a where
58 eqTable :: Columns a (Dict (ConstrainDBType DBEq))
60 default eqTable ::
61 ( KnownAlgebra (GAlgebra (Rep (Record a)))
62 , Eval (GGTable (GAlgebra (Rep (Record a))) TEqTable TColumns (Dict (ConstrainDBType DBEq)) (Rep (Record a)))
63 , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))
64 )
65 => Columns a (Dict (ConstrainDBType DBEq))
66 eqTable =
67 ggtable
68 @(GAlgebra (Rep (Record a)))
69 @TEqTable
70 @TColumns
71 @(Rep (Record a))
72 table
73 nullifier
74 where
75 table (_ :: proxy x) = eqTable @x
78data TEqTable :: Type -> Exp Constraint
79type instance Eval (TEqTable a) = EqTable a
82instance
83 ( HTable t
84 , f ~ Col Expr
85 , HConstrainTable t (ConstrainDBType DBEq)
86 )
87 => EqTable (t f)
88 where
89 eqTable = hdicts @(Columns (t f)) @(ConstrainDBType DBEq)
92instance Sql DBEq a => EqTable (Expr a) where
93 eqTable = HType Dict
96instance (EqTable a, EqTable b) => EqTable (a, b)
99instance (EqTable a, EqTable b, EqTable c) => EqTable (a, b, c)
102instance (EqTable a, EqTable b, EqTable c, EqTable d) => EqTable (a, b, c, d)
105instance (EqTable a, EqTable b, EqTable c, EqTable d, EqTable e) =>
106 EqTable (a, b, c, d, e)
109instance (EqTable a, EqTable b, EqTable c, EqTable d, EqTable e, EqTable f) =>
110 EqTable (a, b, c, d, e, f)
113instance
114 ( EqTable a, EqTable b, EqTable c, EqTable d, EqTable e, EqTable f
115 , EqTable g
116 )
117 => EqTable (a, b, c, d, e, f, g)
120-- | Compare two 'Table's for equality. This corresponds to comparing all
121-- columns inside each table for equality, and combining all comparisons with
122-- @AND@.
123(==:) :: forall a. EqTable a => a -> a -> Expr Bool
124(toColumns -> as) ==: (toColumns -> bs) =
125 foldl1' (&&.) $ getConst $ htabulateA $ \field ->
126 case (hfield as field, hfield bs field) of
127 (E a, E b) -> case hfield (eqTable @a) field of
128 Dict -> Const (pure (a ==. b))
129infix 4 ==:
132-- | Test if two 'Table's are different. This corresponds to comparing all
133-- columns inside each table for inequality, and combining all comparisons with
134-- @OR@.
135(/=:) :: forall a. EqTable a => a -> a -> Expr Bool
136(toColumns -> as) /=: (toColumns -> bs) =
137 foldl1' (||.) $ getConst $ htabulateA $ \field ->
138 case (hfield as field, hfield bs field) of
139 (E a, E b) -> case hfield (eqTable @a) field of
140 Dict -> Const (pure (a /=. b))
141infix 4 /=:
144foldl1' :: (a -> a -> a) -> NonEmpty a -> a
145foldl1' f (a :| as) = foldl' f a as