git.iko.soy/rel8
on fce7213 help sign in
rel8/src/Rel8/Table/Eq.hs
82 lines 2.4 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 ( DB( DB ) )
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 DB a
46 , HConstrainTable (Columns a) (ConstrainDBType DBEq)
47 ) => EqTable a
48instance
49 ( Table DB a
50 , HConstrainTable (Columns a) (ConstrainDBType DBEq)
51 ) => EqTable a
52instance {-# OVERLAPPING #-} EqTable Opaque
55(==:) :: forall a. EqTable a => a -> a -> Expr Bool
56(toColumns -> as) ==: (toColumns -> bs) =
57 foldl1' (&&.) $ 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} -> Const (pure (seq nullability a b))
62 where
63 dicts = hdicts @(Columns a) @(ConstrainDBType DBEq)
64 specs = hspecs @(Columns a)
65infix 4 ==:
68(/=:) :: forall a. EqTable a => a -> a -> Expr Bool
69(toColumns -> as) /=: (toColumns -> bs) =
70 foldl1' (||.) $ getConst $ htabulateA $ \field ->
71 case (hfield as field, hfield bs field) of
72 (DB a, DB b) -> case hfield dicts field of
73 Dict -> case hfield specs field of
74 SSpec {nullability} -> Const (pure (sne nullability a b))
75 where
76 dicts = hdicts @(Columns a) @(ConstrainDBType DBEq)
77 specs = hspecs @(Columns a)
78infix 4 /=:
81foldl1' :: (a -> a -> a) -> NonEmpty a -> a
82foldl1' f (a :| as) = foldl' f a as