git.iko.soy/rel8
on 00a36f5 help sign in
rel8/src/Rel8/Table/Eq.hs
88 lines 2.7 kB history raw
1{-# language DataKinds #-}
2{-# language FlexibleContexts #-}
3{-# language FlexibleInstances #-}
4{-# language NamedFieldPuns #-}
5{-# language ScopedTypeVariables #-}
6{-# language StandaloneKindSignatures #-}
7{-# language TypeApplications #-}
8{-# language TypeFamilies #-}
9{-# language UndecidableInstances #-}
10{-# language UndecidableSuperClasses #-}
11{-# language ViewPatterns #-}
13module Rel8.Table.Eq
14 ( EqTable, (==:), (/=:)
15 )
16where
18-- base
19import Data.Foldable ( foldl' )
20import Data.Functor.Const ( Const( Const ), getConst )
21import Data.Kind ( Constraint, Type )
22import Data.List.NonEmpty ( NonEmpty( (:|) ) )
23import Prelude hiding ( seq )
25-- rel8
26import Rel8.Expr ( Expr )
27import Rel8.Expr.Bool ( (||.), (&&.) )
28import Rel8.Expr.Eq ( seq, sne )
29import Rel8.Opaque ( Opaque )
30import Rel8.Schema.Context ( Col'(..) )
31import Rel8.Schema.Dict ( Dict( Dict ) )
32import Rel8.Schema.HTable
33 ( HConstrainTable
34 , htabulateA, hfield
35 , hdicts, hspecs
36 )
37import Rel8.Schema.Spec ( SSpec(..) )
38import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
39import Rel8.Table ( Table, Columns, toColumns )
40import Rel8.Type.Eq ( DBEq )
43type EqTable :: Type -> Constraint
44class
45 ( Table Expr a
46 , HConstrainTable (Columns a) (ConstrainDBType DBEq)
47 ) => EqTable a
48instance
49 ( Table Expr a
50 , HConstrainTable (Columns a) (ConstrainDBType DBEq)
51 ) => EqTable a
52instance {-# OVERLAPPING #-} EqTable Opaque
55-- | Compare two 'Table's for equality. This corresponds to comparing all
56-- columns inside each table for equality, and combining all comparisons with
57-- @AND@.
58(==:) :: forall a. EqTable a => a -> a -> Expr Bool
59(toColumns -> as) ==: (toColumns -> bs) =
60 foldl1' (&&.) $ getConst $ htabulateA $ \field ->
61 case (hfield as field, hfield bs field) of
62 (DB a, DB b) -> case hfield dicts field of
63 Dict -> case hfield specs field of
64 SSpec {nullability} -> Const (pure (seq nullability a b))
65 where
66 dicts = hdicts @(Columns a) @(ConstrainDBType DBEq)
67 specs = hspecs @(Columns a)
68infix 4 ==:
71-- | Test if two 'Table's are different. This corresponds to comparing all
72-- columns inside each table for inequality, and combining all comparisons with
73-- @OR@.
74(/=:) :: forall a. EqTable a => a -> a -> Expr Bool
75(toColumns -> as) /=: (toColumns -> bs) =
76 foldl1' (||.) $ getConst $ htabulateA $ \field ->
77 case (hfield as field, hfield bs field) of
78 (DB a, DB b) -> case hfield dicts field of
79 Dict -> case hfield specs field of
80 SSpec {nullability} -> Const (pure (sne nullability a b))
81 where
82 dicts = hdicts @(Columns a) @(ConstrainDBType DBEq)
83 specs = hspecs @(Columns a)
84infix 4 /=:
87foldl1' :: (a -> a -> a) -> NonEmpty a -> a
88foldl1' f (a :| as) = foldl' f a as