{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}

-- | Supports writing 'Set algebra' expressions, using overloaded set operations, that can
--   be applied to a variety of Basic types (Set, List, Map, BiMap etc). Also supports
--   a mechanism to evaluate them efficiently, choosing datatype specific algorithms.
--   This mechanism uses run-time rewrite rules to get the best algorithm. If there are
--   no rewrite rules for a specific expression, falls back to a less efficient generic algorithm.
module Control.Iterate.SetAlgebra where

import Control.Iterate.BaseTypes
  ( BaseRep (..),
    Basic (..),
    Embed (..),
    Iter (..),
    Sett (..),
    Single (..),
    fromPairs,
  )
import Control.Iterate.Collect (Collect, front, one, rear, runCollect, when)
import Control.Iterate.Exp
  ( Exp (..),
    Query (..),
    -- semantic meaning functions for Query

    andD,
    andPD,
    chainD,
    -- Operations on Fun

    constant,
    first,
    nEgate,
    plus,
    projD,
    rngElem,
    rngFst,
    rngSnd,
    second,
  )
import Data.BiMap (BiMap (..), biMapEmpty, biMapFromList, removeval)
import qualified Data.Map.Strict as Map
import Data.MapExtras
  ( disjointMapSetFold,
    intersectDomP,
    intersectDomPLeft,
    intersectMapSetFold,
    keysEqual,
    noKeys,
  )
import qualified Data.Set as Set
import Data.UMap (Tag (..), View (..))
import qualified Data.UMap as UM
import Prelude hiding (lookup)

-- ===============================================================================

-- | Compile the (Exp (f k v)) to a Query iterator, and a BaseRep that indicates
--   how to materialize the iterator to the correct type. Recall the iterator
--   can be used to constuct many things using runCollect, but here we want
--   to materialize it to the same type as the (Exp (f k v)), i.e. (f k v).
compile :: Exp (f k v) -> (Query k v, BaseRep f k v)
compile :: Exp (f k v) -> (Query k v, BaseRep f k v)
compile (Base BaseRep f k v
rep f k v
relation) = (BaseRep f k v -> f k v -> Query k v
forall (f :: * -> * -> *) k v.
(Iter f, Ord k) =>
BaseRep f k v -> f k v -> Query k v
BaseD BaseRep f k v
rep f k v
relation, BaseRep f k v
BaseRep f k v
rep)
compile (Singleton k
d v
r) = (BaseRep Single k v -> Single k v -> Query k v
forall (f :: * -> * -> *) k v.
(Iter f, Ord k) =>
BaseRep f k v -> f k v -> Query k v
BaseD BaseRep Single k v
forall k v. Basic Single => BaseRep Single k v
SingleR (k -> v -> Single k v
forall k v. k -> v -> Single k v
Single k
d v
r), BaseRep f k v
forall k v. Basic Single => BaseRep Single k v
SingleR)
compile (SetSingleton k
d) = (BaseRep Single k () -> Single k () -> Query k ()
forall (f :: * -> * -> *) k v.
(Iter f, Ord k) =>
BaseRep f k v -> f k v -> Query k v
BaseD BaseRep Single k ()
forall k v. Basic Single => BaseRep Single k v
SingleR (k -> Single k ()
forall k. k -> Single k ()
SetSingle k
d), BaseRep f k v
forall k v. Basic Single => BaseRep Single k v
SingleR)
compile (Dom (Base BaseRep f k v
SetR f k v
rel)) = (BaseRep Sett k () -> Sett k () -> Query k ()
forall (f :: * -> * -> *) k v.
(Iter f, Ord k) =>
BaseRep f k v -> f k v -> Query k v
BaseD BaseRep Sett k ()
forall k. Basic Sett => BaseRep Sett k ()
SetR f k v
Sett k ()
rel, BaseRep f k v
forall k. Basic Sett => BaseRep Sett k ()
SetR)
compile (Dom (Singleton k
k v
_v)) = (BaseRep Sett k () -> Sett k () -> Query k ()
forall (f :: * -> * -> *) k v.
(Iter f, Ord k) =>
BaseRep f k v -> f k v -> Query k v
BaseD BaseRep Sett k ()
forall k. Basic Sett => BaseRep Sett k ()
SetR (Set k -> Sett k ()
forall k. Set k -> Sett k ()
Sett (k -> Set k
forall a. a -> Set a
Set.singleton k
k)), BaseRep f k v
forall k. Basic Sett => BaseRep Sett k ()
SetR)
compile (Dom (SetSingleton k
k)) = (BaseRep Sett k () -> Sett k () -> Query k ()
forall (f :: * -> * -> *) k v.
(Iter f, Ord k) =>
BaseRep f k v -> f k v -> Query k v
BaseD BaseRep Sett k ()
forall k. Basic Sett => BaseRep Sett k ()
SetR (Set k -> Sett k ()
forall k. Set k -> Sett k ()
Sett (k -> Set k
forall a. a -> Set a
Set.singleton k
k)), BaseRep f k v
forall k. Basic Sett => BaseRep Sett k ()
SetR)
compile (Dom Exp (f k v)
x) = (Query k v -> Fun (k -> v -> ()) -> Query k ()
forall k v u. Ord k => Query k v -> Fun (k -> v -> u) -> Query k u
projD ((Query k v, BaseRep f k v) -> Query k v
forall a b. (a, b) -> a
fst (Exp (f k v) -> (Query k v, BaseRep f k v)
forall (f :: * -> * -> *) k v.
Exp (f k v) -> (Query k v, BaseRep f k v)
compile Exp (f k v)
x)) (() -> Fun (k -> v -> ())
forall c a b. Show c => c -> Fun (a -> b -> c)
constant ()), BaseRep f k v
forall k. Basic Sett => BaseRep Sett k ()
SetR)
compile (Rng (Base BaseRep f k v
SetR f k v
_rel)) = (BaseRep Sett () () -> Sett () () -> Query () ()
forall (f :: * -> * -> *) k v.
(Iter f, Ord k) =>
BaseRep f k v -> f k v -> Query k v
BaseD BaseRep Sett () ()
forall k. Basic Sett => BaseRep Sett k ()
SetR (Set () -> Sett () ()
forall k. Set k -> Sett k ()
Sett (() -> Set ()
forall a. a -> Set a
Set.singleton ())), BaseRep f k v
forall k. Basic Sett => BaseRep Sett k ()
SetR)
compile (Rng (Singleton k
_k v
v)) = (BaseRep Sett v () -> Sett v () -> Query v ()
forall (f :: * -> * -> *) k v.
(Iter f, Ord k) =>
BaseRep f k v -> f k v -> Query k v
BaseD BaseRep Sett v ()
forall k. Basic Sett => BaseRep Sett k ()
SetR (Set v -> Sett v ()
forall k. Set k -> Sett k ()
Sett (v -> Set v
forall a. a -> Set a
Set.singleton v
v)), BaseRep f k v
forall k. Basic Sett => BaseRep Sett k ()
SetR)
compile (Rng (SetSingleton k
_k)) = (BaseRep Sett () () -> Sett () () -> Query () ()
forall (f :: * -> * -> *) k v.
(Iter f, Ord k) =>
BaseRep f k v -> f k v -> Query k v
BaseD BaseRep Sett () ()
forall k. Basic Sett => BaseRep Sett k ()
SetR (Set () -> Sett () ()
forall k. Set k -> Sett k ()
Sett (() -> Set ()
forall a. a -> Set a
Set.singleton ())), BaseRep f k v
forall k. Basic Sett => BaseRep Sett k ()
SetR)
compile (Rng Exp (f k v)
f) = (BaseRep Sett v () -> Sett v () -> Query v ()
forall (f :: * -> * -> *) k v.
(Iter f, Ord k) =>
BaseRep f k v -> f k v -> Query k v
BaseD BaseRep Sett v ()
forall k. Basic Sett => BaseRep Sett k ()
SetR (BaseRep Sett v () -> Collect (v, ()) -> Sett v ()
forall k (f :: * -> * -> *) v.
Ord k =>
BaseRep f k v -> Collect (k, v) -> f k v
materialize BaseRep Sett v ()
forall k. Basic Sett => BaseRep Sett k ()
SetR (Query k v -> Collect (v, ())
forall (f :: * -> * -> *) a a. Iter f => f a a -> Collect (a, ())
loop Query k v
query)), BaseRep f k v
forall k. Basic Sett => BaseRep Sett k ()
SetR) -- We really ought to memoize this. It might be computed many times.
  where
    query :: Query k v
query = (Query k v, BaseRep f k v) -> Query k v
forall a b. (a, b) -> a
fst (Exp (f k v) -> (Query k v, BaseRep f k v)
forall (f :: * -> * -> *) k v.
Exp (f k v) -> (Query k v, BaseRep f k v)
compile Exp (f k v)
f)
    loop :: f a a -> Collect (a, ())
loop f a a
x = do (a
_k, a
v, f a a
x2) <- f a a -> Collect (a, a, f a a)
forall (f :: * -> * -> *) a b.
Iter f =>
f a b -> Collect (a, b, f a b)
nxt f a a
x; (a, ()) -> Collect (a, ()) -> Collect (a, ())
forall t. t -> Collect t -> Collect t
front (a
v, ()) (f a a -> Collect (a, ())
loop f a a
x2)
compile (DRestrict Exp (g k ())
set Exp (f k v)
rel) = (Query k ((), v) -> Fun (k -> ((), v) -> v) -> Query k v
forall k v u. Ord k => Query k v -> Fun (k -> v -> u) -> Query k u
projD (Query k () -> Query k v -> Query k ((), v)
forall k v1 v2.
Ord k =>
Query k v1 -> Query k v2 -> Query k (v1, v2)
andD ((Query k (), BaseRep g k ()) -> Query k ()
forall a b. (a, b) -> a
fst (Exp (g k ()) -> (Query k (), BaseRep g k ())
forall (f :: * -> * -> *) k v.
Exp (f k v) -> (Query k v, BaseRep f k v)
compile Exp (g k ())
set)) Query k v
reld) Fun (k -> ((), v) -> v)
forall x a b. Fun (x -> (a, b) -> b)
rngSnd, BaseRep f k v
BaseRep f k v
rep)
  where
    (Query k v
reld, BaseRep f k v
rep) = Exp (f k v) -> (Query k v, BaseRep f k v)
forall (f :: * -> * -> *) k v.
Exp (f k v) -> (Query k v, BaseRep f k v)
compile Exp (f k v)
rel
compile (DExclude Exp (g k ())
set Exp (f k v)
rel) = (Query k v -> Query k () -> Query k v
forall k v u. Ord k => Query k v -> Query k u -> Query k v
DiffD Query k v
reld ((Query k (), BaseRep g k ()) -> Query k ()
forall a b. (a, b) -> a
fst (Exp (g k ()) -> (Query k (), BaseRep g k ())
forall (f :: * -> * -> *) k v.
Exp (f k v) -> (Query k v, BaseRep f k v)
compile Exp (g k ())
set)), BaseRep f k v
BaseRep f k v
rep)
  where
    (Query k v
reld, BaseRep f k v
rep) = Exp (f k v) -> (Query k v, BaseRep f k v)
forall (f :: * -> * -> *) k v.
Exp (f k v) -> (Query k v, BaseRep f k v)
compile Exp (f k v)
rel
compile (RRestrict Exp (f k v)
rel Exp (g v ())
set) =
  case (Exp (f k v) -> (Query k v, BaseRep f k v)
forall (f :: * -> * -> *) k v.
Exp (f k v) -> (Query k v, BaseRep f k v)
compile Exp (f k v)
rel, Exp (g v ()) -> (Query v (), BaseRep g v ())
forall (f :: * -> * -> *) k v.
Exp (f k v) -> (Query k v, BaseRep f k v)
compile Exp (g v ())
set) of
    ((Query k v
reld, BaseRep f k v
rep), (BaseD BaseRep f v ()
_ f v ()
x, BaseRep g v ()
_)) -> (Query k v -> Fun (k -> v -> Bool) -> Query k v
forall k v. Ord k => Query k v -> Fun (k -> v -> Bool) -> Query k v
GuardD Query k v
reld (f v () -> Fun (k -> v -> Bool)
forall rng (f :: * -> * -> *) v dom.
(Ord rng, Iter f) =>
f rng v -> Fun (dom -> rng -> Bool)
rngElem f v ()
x), BaseRep f k v
BaseRep f k v
rep)
    ((Query k v
reld, BaseRep f k v
rep), (Query v ()
setd, BaseRep g v ()
_)) -> (Query k v -> Query v () -> Fun (k -> (v, ()) -> v) -> Query k v
forall k v w u.
(Ord k, Ord v) =>
Query k v -> Query v w -> Fun (k -> (v, w) -> u) -> Query k u
chainD Query k v
reld Query v ()
setd Fun (k -> (v, ()) -> v)
forall x a b. Fun (x -> (a, b) -> a)
rngFst, BaseRep f k v
BaseRep f k v
rep)
compile (RExclude Exp (f k v)
rel Exp (g v ())
set) =
  case (Exp (f k v) -> (Query k v, BaseRep f k v)
forall (f :: * -> * -> *) k v.
Exp (f k v) -> (Query k v, BaseRep f k v)
compile Exp (f k v)
rel, Exp (g v ()) -> (Query v (), BaseRep g v ())
forall (f :: * -> * -> *) k v.
Exp (f k v) -> (Query k v, BaseRep f k v)
compile Exp (g v ())
set) of
    ((Query k v
reld, BaseRep f k v
rep), (BaseD BaseRep f v ()
_ f v ()
x, BaseRep g v ()
_)) -> (Query k v -> Fun (k -> v -> Bool) -> Query k v
forall k v. Ord k => Query k v -> Fun (k -> v -> Bool) -> Query k v
GuardD Query k v
reld (Fun (k -> v -> Bool) -> Fun (k -> v -> Bool)
forall k v. Fun (k -> v -> Bool) -> Fun (k -> v -> Bool)
nEgate (f v () -> Fun (k -> v -> Bool)
forall rng (f :: * -> * -> *) v dom.
(Ord rng, Iter f) =>
f rng v -> Fun (dom -> rng -> Bool)
rngElem f v ()
x)), BaseRep f k v
BaseRep f k v
rep)
    ((Query k v
reld, BaseRep f k v
rep), (Query v (), BaseRep g v ())
_) -> (Query k v -> Fun (k -> v -> Bool) -> Query k v
forall k v. Ord k => Query k v -> Fun (k -> v -> Bool) -> Query k v
GuardD Query k v
reld (Fun (k -> v -> Bool) -> Fun (k -> v -> Bool)
forall k v. Fun (k -> v -> Bool) -> Fun (k -> v -> Bool)
nEgate (g v () -> Fun (k -> v -> Bool)
forall rng (f :: * -> * -> *) v dom.
(Ord rng, Iter f) =>
f rng v -> Fun (dom -> rng -> Bool)
rngElem (Exp (g v ()) -> g v ()
forall t. Exp t -> t
compute Exp (g v ())
set))), BaseRep f k v
BaseRep f k v
rep) -- This could be expensive
compile (UnionOverrideLeft Exp (f k v)
rel1 Exp (g k v)
rel2) = (Query k v -> Query k v -> Fun (v -> v -> v) -> Query k v
forall k v.
Ord k =>
Query k v -> Query k v -> Fun (v -> v -> v) -> Query k v
OrD Query k v
rel1d ((Query k v, BaseRep g k v) -> Query k v
forall a b. (a, b) -> a
fst (Exp (g k v) -> (Query k v, BaseRep g k v)
forall (f :: * -> * -> *) k v.
Exp (f k v) -> (Query k v, BaseRep f k v)
compile Exp (g k v)
rel2)) Fun (v -> v -> v)
forall v s. Fun (v -> s -> v)
first, BaseRep f k v
BaseRep f k v
rep) -- first uses value from rel1 to override value from rel2
  where
    (Query k v
rel1d, BaseRep f k v
rep) = Exp (f k v) -> (Query k v, BaseRep f k v)
forall (f :: * -> * -> *) k v.
Exp (f k v) -> (Query k v, BaseRep f k v)
compile Exp (f k v)
rel1
compile (UnionOverrideRight Exp (f k v)
rel1 Exp (g k v)
rel2) = (Query k v -> Query k v -> Fun (v -> v -> v) -> Query k v
forall k v.
Ord k =>
Query k v -> Query k v -> Fun (v -> v -> v) -> Query k v
OrD Query k v
rel1d ((Query k v, BaseRep g k v) -> Query k v
forall a b. (a, b) -> a
fst (Exp (g k v) -> (Query k v, BaseRep g k v)
forall (f :: * -> * -> *) k v.
Exp (f k v) -> (Query k v, BaseRep f k v)
compile Exp (g k v)
rel2)) Fun (v -> v -> v)
forall v s. Fun (v -> s -> s)
second, BaseRep f k v
BaseRep f k v
rep) -- second uses value from rel2 to override value from rel1
  where
    (Query k v
rel1d, BaseRep f k v
rep) = Exp (f k v) -> (Query k v, BaseRep f k v)
forall (f :: * -> * -> *) k v.
Exp (f k v) -> (Query k v, BaseRep f k v)
compile Exp (f k v)
rel1
compile (UnionPlus Exp (f k n)
rel1 Exp (g k n)
rel2) = (Query k n -> Query k n -> Fun (n -> n -> n) -> Query k n
forall k v.
Ord k =>
Query k v -> Query k v -> Fun (v -> v -> v) -> Query k v
OrD Query k n
rel1d ((Query k n, BaseRep g k n) -> Query k n
forall a b. (a, b) -> a
fst (Exp (g k n) -> (Query k n, BaseRep g k n)
forall (f :: * -> * -> *) k v.
Exp (f k v) -> (Query k v, BaseRep f k v)
compile Exp (g k n)
rel2)) Fun (n -> n -> n)
forall t. Monoid t => Fun (t -> t -> t)
plus, BaseRep f k v
BaseRep f k n
rep)
  where
    (Query k n
rel1d, BaseRep f k n
rep) = Exp (f k n) -> (Query k n, BaseRep f k n)
forall (f :: * -> * -> *) k v.
Exp (f k v) -> (Query k v, BaseRep f k v)
compile Exp (f k n)
rel1
compile (Intersect Exp (f k v)
rel1 Exp (g k u)
rel2) = (Query k v -> Query k u -> Fun (k -> (v, u) -> ()) -> Query k ()
forall k v1 u v.
Ord k =>
Query k v1 -> Query k u -> Fun (k -> (v1, u) -> v) -> Query k v
andPD ((Query k v, BaseRep f k v) -> Query k v
forall a b. (a, b) -> a
fst (Exp (f k v) -> (Query k v, BaseRep f k v)
forall (f :: * -> * -> *) k v.
Exp (f k v) -> (Query k v, BaseRep f k v)
compile Exp (f k v)
rel1)) ((Query k u, BaseRep g k u) -> Query k u
forall a b. (a, b) -> a
fst (Exp (g k u) -> (Query k u, BaseRep g k u)
forall (f :: * -> * -> *) k v.
Exp (f k v) -> (Query k v, BaseRep f k v)
compile Exp (g k u)
rel2)) (() -> Fun (k -> (v, u) -> ())
forall c a b. Show c => c -> Fun (a -> b -> c)
constant ()), BaseRep f k v
forall k. Basic Sett => BaseRep Sett k ()
SetR)
compile (SetDiff Exp (f k v)
rel1 Exp (g k u)
rel2) = (Query k v -> Query k u -> Query k v
forall k v u. Ord k => Query k v -> Query k u -> Query k v
DiffD Query k v
rel1d ((Query k u, BaseRep g k u) -> Query k u
forall a b. (a, b) -> a
fst (Exp (g k u) -> (Query k u, BaseRep g k u)
forall (f :: * -> * -> *) k v.
Exp (f k v) -> (Query k v, BaseRep f k v)
compile Exp (g k u)
rel2)), BaseRep f k v
BaseRep f k v
rep)
  where
    (Query k v
rel1d, BaseRep f k v
rep) = Exp (f k v) -> (Query k v, BaseRep f k v)
forall (f :: * -> * -> *) k v.
Exp (f k v) -> (Query k v, BaseRep f k v)
compile Exp (f k v)
rel1

compileSubterm :: Exp a -> Exp (f k v) -> Query k v
compileSubterm :: Exp a -> Exp (f k v) -> Query k v
compileSubterm Exp a
_whole Exp (f k v)
sub = (Query k v, BaseRep f k v) -> Query k v
forall a b. (a, b) -> a
fst (Exp (f k v) -> (Query k v, BaseRep f k v)
forall (f :: * -> * -> *) k v.
Exp (f k v) -> (Query k v, BaseRep f k v)
compile Exp (f k v)
sub)

-- ===========================================================================
-- The second part of the generic algorithm is to run the compiled code.
-- This involves materiaizing every sub-expression, and then applying generic
-- operations to the sub-expressions to get the answer.  Some Exp's (ones built
-- with (Base baserep value) are aready materialized, so they only need be
-- transformed to the target type. If the target type, is the same type as the real
-- 'value' stored in (Base baserep value). Then this is a no-op, if not use the
-- function (materialize :: Ord k => BaseRep f k v -> Collect (k, v) -> f k v) to
-- convert it.
-- ===========================================================================

run :: (Ord k) => (Query k v, BaseRep f k v) -> f k v
run :: (Query k v, BaseRep f k v) -> f k v
run (BaseD BaseRep f k v
SetR f k v
x, BaseRep f k v
SetR) = f k v
f k v
x -- If it is already data (BaseD)
run (BaseD BaseRep f k v
MapR f k v
x, BaseRep f k v
MapR) = f k v
f k v
x -- and in the right form (the BaseRep's match)
run (BaseD BaseRep f k v
SingleR f k v
x, BaseRep f k v
SingleR) = f k v
f k v
x -- just return the data
run (BaseD BaseRep f k v
BiMapR f k v
x, BaseRep f k v
BiMapR) = f k v
f k v
x -- only need to materialize data
run (BaseD BaseRep f k v
ListR f k v
x, BaseRep f k v
ListR) = f k v
f k v
x -- if the forms do not match.
run (BaseD BaseRep f k v
_source f k v
x, BaseRep f k v
ListR) = BaseRep List k v -> Collect (k, v) -> List k v
forall k (f :: * -> * -> *) v.
Ord k =>
BaseRep f k v -> Collect (k, v) -> f k v
materialize BaseRep List k v
forall k v. Basic List => BaseRep List k v
ListR (f k v -> Collect (k, v)
forall (f :: * -> * -> *) k v. Iter f => f k v -> Collect (k, v)
fifo f k v
x) -- use fifo, since the order matters for Lists.
run (BaseD BaseRep f k v
_source f k v
x, BaseRep f k v
target) = BaseRep f k v -> Collect (k, v) -> f k v
forall k (f :: * -> * -> *) v.
Ord k =>
BaseRep f k v -> Collect (k, v) -> f k v
materialize BaseRep f k v
target (f k v -> Collect (k, v)
forall (f :: * -> * -> *) k v. Iter f => f k v -> Collect (k, v)
lifo f k v
x) -- use lifo, for others
run (Query k v
other, BaseRep f k v
ListR) = BaseRep List k v -> Collect (k, v) -> List k v
forall k (f :: * -> * -> *) v.
Ord k =>
BaseRep f k v -> Collect (k, v) -> f k v
materialize BaseRep List k v
forall k v. Basic List => BaseRep List k v
ListR (Query k v -> Collect (k, v)
forall (f :: * -> * -> *) k v. Iter f => f k v -> Collect (k, v)
fifo Query k v
other) -- If it is a compound Iterator, for List, than materialize it using fifo
run (Query k v
other, BaseRep f k v
target) = BaseRep f k v -> Collect (k, v) -> f k v
forall k (f :: * -> * -> *) v.
Ord k =>
BaseRep f k v -> Collect (k, v) -> f k v
materialize BaseRep f k v
target (Query k v -> Collect (k, v)
forall (f :: * -> * -> *) k v. Iter f => f k v -> Collect (k, v)
lifo Query k v
other) -- If it is a compund Iterator, for anything else than materialize it using lifo

testing :: Bool
testing :: Bool
testing = Bool
False

runBoolExp :: Exp Bool -> Bool
runBoolExp :: Exp Bool -> Bool
runBoolExp Exp Bool
e =
  if Bool
testing
    then [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error ([Char]
"In Testing mode, SetAlgebra expression: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp Bool -> [Char]
forall a. Show a => a -> [Char]
show Exp Bool
e [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" falls through to slow mode.")
    else Exp Bool -> Bool
runBool Exp Bool
e

runSetExp :: Ord k => Exp (f k v) -> f k v
runSetExp :: Exp (f k v) -> f k v
runSetExp Exp (f k v)
e =
  if Bool
testing
    then [Char] -> f k v
forall a. HasCallStack => [Char] -> a
error ([Char]
"In Testing mode, SetAlgebra expression: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp (f k v) -> [Char]
forall a. Show a => a -> [Char]
show Exp (f k v)
e [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" falls through to slow mode.")
    else (Query k v, BaseRep f k v) -> f k v
forall k v (f :: * -> * -> *).
Ord k =>
(Query k v, BaseRep f k v) -> f k v
run (Exp (f k v) -> (Query k v, BaseRep f k v)
forall (f :: * -> * -> *) k v.
Exp (f k v) -> (Query k v, BaseRep f k v)
compile Exp (f k v)
e)

-- The following ar only for use in the SetAlgebra internal tests

runSet :: Ord k => Exp (f k v) -> f k v
runSet :: Exp (f k v) -> f k v
runSet Exp (f k v)
e = (Query k v, BaseRep f k v) -> f k v
forall k v (f :: * -> * -> *).
Ord k =>
(Query k v, BaseRep f k v) -> f k v
run (Exp (f k v) -> (Query k v, BaseRep f k v)
forall (f :: * -> * -> *) k v.
Exp (f k v) -> (Query k v, BaseRep f k v)
compile Exp (f k v)
e)

runBool :: Exp Bool -> Bool
runBool :: Exp Bool -> Bool
runBool (Elem k
k Exp (g k ())
v) = k -> g k () -> Bool
forall (f :: * -> * -> *) key b.
(Iter f, Ord key) =>
key -> f key b -> Bool
haskey k
k (Exp (g k ()) -> g k ()
forall t. Exp t -> t
compute Exp (g k ())
v)
runBool (NotElem k
k Exp (g k ())
set) = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ k -> g k () -> Bool
forall (f :: * -> * -> *) key b.
(Iter f, Ord key) =>
key -> f key b -> Bool
haskey k
k (Exp (g k ()) -> g k ()
forall t. Exp t -> t
compute Exp (g k ())
set)
runBool (w :: Exp Bool
w@(KeyEqual Exp (f k v)
x Exp (g k u)
y)) = Query k v -> Query k u -> Bool
forall k (f :: * -> * -> *) (g :: * -> * -> *) b c.
(Ord k, Iter f, Iter g) =>
f k b -> g k c -> Bool
sameDomain (Exp Bool -> Exp (f k v) -> Query k v
forall a (f :: * -> * -> *) k v. Exp a -> Exp (f k v) -> Query k v
compileSubterm Exp Bool
w Exp (f k v)
x) (Exp Bool -> Exp (g k u) -> Query k u
forall a (f :: * -> * -> *) k v. Exp a -> Exp (f k v) -> Query k v
compileSubterm Exp Bool
w Exp (g k u)
y)
runBool (w :: Exp Bool
w@(Subset Exp (f k v)
x Exp (g k u)
y)) = Collect (k, v) -> Bool -> ((k, v) -> Bool -> Bool) -> Bool
forall tuple.
Collect tuple -> forall ans. ans -> (tuple -> ans -> ans) -> ans
runCollect (Query k v -> Collect (k, v)
forall (f :: * -> * -> *) k v. Iter f => f k v -> Collect (k, v)
lifo Query k v
left) Bool
True (\(k
k, v
_v) Bool
ans -> k -> Query k u -> Bool
forall (f :: * -> * -> *) key b.
(Iter f, Ord key) =>
key -> f key b -> Bool
haskey k
k Query k u
right Bool -> Bool -> Bool
&& Bool
ans)
  where
    left :: Query k v
left = Exp Bool -> Exp (f k v) -> Query k v
forall a (f :: * -> * -> *) k v. Exp a -> Exp (f k v) -> Query k v
compileSubterm Exp Bool
w Exp (f k v)
x
    right :: Query k u
right = Exp Bool -> Exp (g k u) -> Query k u
forall a (f :: * -> * -> *) k v. Exp a -> Exp (f k v) -> Query k v
compileSubterm Exp Bool
w Exp (g k u)
y

-- | cost O(min (size m) (size n) * log(max (size m) (size n))), BUT the constants are high, too slow except for small maps.
sameDomain :: (Ord k, Iter f, Iter g) => f k b -> g k c -> Bool
sameDomain :: f k b -> g k c -> Bool
sameDomain f k b
m g k c
n = Maybe (k, b, f k b) -> Maybe (k, c, g k c) -> Bool
forall a (f :: * -> * -> *) (f :: * -> * -> *) b b.
(Ord a, Iter f, Iter f) =>
Maybe (a, b, f a b) -> Maybe (a, b, f a b) -> Bool
loop (f k b -> Maybe (k, b, f k b)
forall (f :: * -> * -> *) a b.
Iter f =>
f a b -> Maybe (a, b, f a b)
hasNxt f k b
m) (g k c -> Maybe (k, c, g k c)
forall (f :: * -> * -> *) a b.
Iter f =>
f a b -> Maybe (a, b, f a b)
hasNxt g k c
n)
  where
    loop :: Maybe (a, b, f a b) -> Maybe (a, b, f a b) -> Bool
loop (Just (a
k1, b
_, f a b
nextm)) (Just (a
k2, b
_, f a b
nextn)) =
      case a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
k1 a
k2 of
        Ordering
EQ -> Maybe (a, b, f a b) -> Maybe (a, b, f a b) -> Bool
loop (f a b -> Maybe (a, b, f a b)
forall (f :: * -> * -> *) a b.
Iter f =>
f a b -> Maybe (a, b, f a b)
hasNxt f a b
nextm) (f a b -> Maybe (a, b, f a b)
forall (f :: * -> * -> *) a b.
Iter f =>
f a b -> Maybe (a, b, f a b)
hasNxt f a b
nextn)
        Ordering
LT -> Bool
False
        Ordering
GT -> Bool
False
    loop Maybe (a, b, f a b)
Nothing Maybe (a, b, f a b)
Nothing = Bool
True
    loop Maybe (a, b, f a b)
_ Maybe (a, b, f a b)
_ = Bool
False

-- ==============================================================================================
-- The faster strategy involves applying (type-specific) rewrite rules using the
-- function (compute :: Exp t -> t), This pattern matches against the GADT constructors
-- so this allows runtime choice of type specific algortihms of Exp
-- Evaluate an (Exp t) into real data of type t. Try domain and type specific algorithms first,
-- and if those fail. Compile the formula as an iterator, then run the iterator to get an answer.
-- Here are some sample of the type specific algorithms we incorporate
--  x  ∈ (dom y)            haskey
--  x  ∉ (dom y)            not . haskey
-- x ∪ (singleton y)        addpair
-- (Set.singleton x) ⋪ y    removekey
-- x ⋫ (Set.singleton y)    easy on Bimap  remove val
-- (dom x) ⊆ (dom y)
-- ===============================================================================================

compute :: Exp t -> t
compute :: Exp t -> t
compute (Base BaseRep f k v
_rep f k v
relation) = t
f k v
relation
compute (Dom (Base BaseRep f k v
SetR f k v
rel)) = t
f k v
rel
compute (Dom (Base BaseRep f k v
MapR f k v
x)) = Set k -> Sett k ()
forall k. Set k -> Sett k ()
Sett (Map k v -> Set k
forall k a. Map k a -> Set k
Map.keysSet f k v
Map k v
x)
compute (Dom (Singleton k
k v
_v)) = Set k -> Sett k ()
forall k. Set k -> Sett k ()
Sett (k -> Set k
forall a. a -> Set a
Set.singleton k
k)
compute (Dom (SetSingleton k
k)) = Set k -> Sett k ()
forall k. Set k -> Sett k ()
Sett (k -> Set k
forall a. a -> Set a
Set.singleton k
k)
compute (Dom (Base BaseRep f k v
_rep f k v
rel)) = Set k -> Sett k ()
forall k. Set k -> Sett k ()
Sett (f k v -> Set k
forall (f :: * -> * -> *) k v. (Basic f, Ord k) => f k v -> Set k
domain f k v
rel)
-- (dom (Map(62)? ▷ (setSingleton _ )))
compute (Dom (RRestrict (Base BaseRep f k v
MapR f k v
xs) (SetSingleton k
v))) = Set k -> Sett k ()
forall k. Set k -> Sett k ()
Sett ((Set k -> k -> k -> Set k) -> Set k -> Map k k -> Set k
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' Set k -> k -> k -> Set k
accum Set k
forall a. Set a
Set.empty f k v
Map k k
xs)
  where
    accum :: Set k -> k -> k -> Set k
accum Set k
ans k
k k
u = if k
u k -> k -> Bool
forall a. Eq a => a -> a -> Bool
== k
v then k -> Set k -> Set k
forall a. Ord a => a -> Set a -> Set a
Set.insert k
k Set k
ans else Set k
ans
compute (Dom (RRestrict (Base BaseRep f k v
MapR f k v
xs) (Base BaseRep f k v
SetR (Sett set)))) = Set k -> Sett k ()
forall k. Set k -> Sett k ()
Sett ((Set k -> k -> k -> Set k) -> Set k -> Map k k -> Set k
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' Set k -> k -> k -> Set k
accum Set k
forall a. Set a
Set.empty f k v
Map k k
xs)
  where
    accum :: Set k -> k -> k -> Set k
accum Set k
ans k
k k
u = if k -> Set k -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member k
u Set k
set then k -> Set k -> Set k
forall a. Ord a => a -> Set a -> Set a
Set.insert k
k Set k
ans else Set k
ans
compute (Dom (RExclude (Base BaseRep f k v
MapR f k v
xs) (SetSingleton k
v))) = Set k -> Sett k ()
forall k. Set k -> Sett k ()
Sett ((Set k -> k -> k -> Set k) -> Set k -> Map k k -> Set k
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' Set k -> k -> k -> Set k
accum Set k
forall a. Set a
Set.empty f k v
Map k k
xs)
  where
    accum :: Set k -> k -> k -> Set k
accum Set k
ans k
k k
u = if Bool -> Bool
not (k
u k -> k -> Bool
forall a. Eq a => a -> a -> Bool
== k
v) then k -> Set k -> Set k
forall a. Ord a => a -> Set a -> Set a
Set.insert k
k Set k
ans else Set k
ans
compute (Dom (RExclude (Base BaseRep f k v
MapR f k v
xs) (Base BaseRep f k v
SetR (Sett set)))) = Set k -> Sett k ()
forall k. Set k -> Sett k ()
Sett ((Set k -> k -> k -> Set k) -> Set k -> Map k k -> Set k
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' Set k -> k -> k -> Set k
accum Set k
forall a. Set a
Set.empty f k v
Map k k
xs)
  where
    accum :: Set k -> k -> k -> Set k
accum Set k
ans k
k k
u = if Bool -> Bool
not (k -> Set k -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member k
u Set k
set) then k -> Set k -> Set k
forall a. Ord a => a -> Set a -> Set a
Set.insert k
k Set k
ans else Set k
ans
compute (Dom (DRestrict (SetSingleton k
v) (Base BaseRep f k v
MapR f k v
xs))) = Set k -> Sett k ()
forall k. Set k -> Sett k ()
Sett ((k -> v -> Set k -> Set k) -> Map k v -> Set k -> Set k -> Set k
forall k v ans.
Ord k =>
(k -> v -> ans -> ans) -> Map k v -> Set k -> ans -> ans
intersectMapSetFold k -> v -> Set k -> Set k
forall a p. Ord a => a -> p -> Set a -> Set a
accum f k v
Map k v
xs (k -> Set k
forall a. a -> Set a
Set.singleton k
v) Set k
forall a. Set a
Set.empty)
  where
    accum :: a -> p -> Set a -> Set a
accum a
k p
_u Set a
ans = a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.insert a
k Set a
ans
compute (Dom (DRestrict (Base BaseRep f k v
SetR (Sett set)) (Base BaseRep f k v
MapR f k v
xs))) = Set k -> Sett k ()
forall k. Set k -> Sett k ()
Sett ((k -> v -> Set k -> Set k) -> Map k v -> Set k -> Set k -> Set k
forall k v ans.
Ord k =>
(k -> v -> ans -> ans) -> Map k v -> Set k -> ans -> ans
intersectMapSetFold k -> v -> Set k -> Set k
forall a p. Ord a => a -> p -> Set a -> Set a
accum f k v
Map k v
xs Set k
Set k
set Set k
forall a. Set a
Set.empty)
  where
    accum :: a -> p -> Set a -> Set a
accum a
k p
_u Set a
ans = a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.insert a
k Set a
ans
compute (Dom (DExclude (SetSingleton k
v) (Base BaseRep f k v
MapR f k v
xs))) = Set k -> Sett k ()
forall k. Set k -> Sett k ()
Sett ((k -> v -> Set k -> Set k) -> Map k v -> Set k -> Set k -> Set k
forall k v ans.
Ord k =>
(k -> v -> ans -> ans) -> Map k v -> Set k -> ans -> ans
disjointMapSetFold k -> v -> Set k -> Set k
forall a p. Ord a => a -> p -> Set a -> Set a
accum f k v
Map k v
xs (k -> Set k
forall a. a -> Set a
Set.singleton k
v) Set k
forall a. Set a
Set.empty)
  where
    accum :: a -> p -> Set a -> Set a
accum a
k p
_u Set a
ans = a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.insert a
k Set a
ans
compute (Dom (DExclude (Base BaseRep f k v
SetR (Sett set)) (Base BaseRep f k v
MapR f k v
xs))) = Set k -> Sett k ()
forall k. Set k -> Sett k ()
Sett ((k -> v -> Set k -> Set k) -> Map k v -> Set k -> Set k -> Set k
forall k v ans.
Ord k =>
(k -> v -> ans -> ans) -> Map k v -> Set k -> ans -> ans
disjointMapSetFold k -> v -> Set k -> Set k
forall a p. Ord a => a -> p -> Set a -> Set a
accum f k v
Map k v
xs Set k
Set k
set Set k
forall a. Set a
Set.empty)
  where
    accum :: a -> p -> Set a -> Set a
accum a
k p
_u Set a
ans = a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.insert a
k Set a
ans
compute (Rng (Base BaseRep f k v
SetR f k v
_rel)) = Set () -> Sett () ()
forall k. Set k -> Sett k ()
Sett (() -> Set ()
forall a. a -> Set a
Set.singleton ())
compute (Rng (Singleton k
_k v
v)) = Set v -> Sett v ()
forall k. Set k -> Sett k ()
Sett (v -> Set v
forall a. a -> Set a
Set.singleton v
v)
compute (Rng (SetSingleton k
_k)) = Set () -> Sett () ()
forall k. Set k -> Sett k ()
Sett (() -> Set ()
forall a. a -> Set a
Set.singleton ())
compute (Rng (Base BaseRep f k v
_rep f k v
rel)) = Set v -> Sett v ()
forall k. Set k -> Sett k ()
Sett (f k v -> Set v
forall (f :: * -> * -> *) v k. (Basic f, Ord v) => f k v -> Set v
range f k v
rel)
compute (DRestrict (Base BaseRep f k v
SetR (Sett set)) (Base BaseRep f k v
MapR f k v
m)) = Map k v -> Set k -> Map k v
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys f k v
Map k v
m Set k
Set k
set
compute (DRestrict (SetSingleton k
k) (Base BaseRep f k v
MapR f k v
m)) = Map k v -> Set k -> Map k v
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys f k v
Map k v
m (k -> Set k
forall a. a -> Set a
Set.singleton k
k)
compute (DRestrict (Singleton k
k v
_v) (Base BaseRep f k v
MapR f k v
m)) = Map k v -> Set k -> Map k v
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys f k v
Map k v
m (k -> Set k
forall a. a -> Set a
Set.singleton k
k)
compute (DRestrict (Dom (Base BaseRep f k v
MapR f k v
x)) (Base BaseRep f k v
MapR f k v
y)) = Map k v -> Map k v -> Map k v
forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.intersection f k v
Map k v
y f k v
Map k v
x
compute (DRestrict (Dom (Base (ViewR Tag coin cred pool ptr k v
_) f k v
x)) (Base BaseRep f k v
MapR f k v
y)) = View coin cred pool ptr k v -> Map k v -> Map k v
forall cr ptr coin pool k v u.
(Ord cr, Ord ptr) =>
View coin cr pool ptr k v -> Map k u -> Map k u
UM.domRestrict f k v
View coin cred pool ptr k v
x f k v
Map k v
y
-- This case inspired by set expression in EpochBoundary.hs
-- (dom (delegs ▷ Set.singleton hk) ◁ stake) in EpochBoundart.hs
-- ((dom (Map(62)? ▷ (setSingleton _ ))) ◁ Map(63)?) which has this structure
-- materialize MapR (do { (x,y,z) <- delegs `domEq` stake; when (y==hk); one(x,z) })
compute (DRestrict (Dom (RRestrict (Base BaseRep f k v
MapR f k v
delegs) (SetSingleton k
hk))) (Base BaseRep f k v
MapR f k v
stake)) =
  (k -> k -> Bool) -> Map k v -> Map k k -> Map k v
forall k v2 v1.
Ord k =>
(k -> v2 -> Bool) -> Map k v1 -> Map k v2 -> Map k v1
intersectDomPLeft (\k
_k k
v2 -> k
v2 k -> k -> Bool
forall a. Eq a => a -> a -> Bool
== k
hk) f k v
Map k v
stake f k v
Map k k
delegs
compute (DRestrict (Dom (RRestrict (Base BaseRep f k v
MapR f k v
delegs) (Base BaseRep f k v
_ f k v
rngf))) (Base BaseRep f k v
MapR f k v
stake)) =
  (k -> k -> Bool) -> Map k v -> Map k k -> Map k v
forall k v2 v1.
Ord k =>
(k -> v2 -> Bool) -> Map k v1 -> Map k v2 -> Map k v1
intersectDomPLeft (\k
_k k
v2 -> k -> f k v -> Bool
forall (f :: * -> * -> *) key b.
(Iter f, Ord key) =>
key -> f key b -> Bool
haskey k
v2 f k v
rngf) f k v
Map k v
stake f k v
Map k k
delegs
compute (DRestrict Exp (g k ())
set (Base BaseRep f k v
MapR f k v
ys)) = Map k v -> Set k -> Map k v
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys f k v
Map k v
ys Set k
set2 -- Pay the cost of materializing set to use O(n* log n) restictKeys
  where
    Sett Set k
set2 = BaseRep Sett k () -> Collect (k, ()) -> Sett k ()
forall k (f :: * -> * -> *) v.
Ord k =>
BaseRep f k v -> Collect (k, v) -> f k v
materialize BaseRep Sett k ()
forall k. Basic Sett => BaseRep Sett k ()
SetR (g k () -> Collect (k, ())
forall (f :: * -> * -> *) k v. Iter f => f k v -> Collect (k, v)
lifo (Exp (g k ()) -> g k ()
forall t. Exp t -> t
compute Exp (g k ())
set))
compute (DRestrict (Base BaseRep f k v
SetR (Sett s1)) (Base BaseRep f k v
SetR (Sett s2))) = Set k -> Sett k ()
forall k. Set k -> Sett k ()
Sett (Set k -> Set k -> Set k
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set k
s1 Set k
Set k
s2)
compute (DRestrict (Base BaseRep f k v
SetR f k v
x1) (Base BaseRep f k v
rep f k v
x2)) = BaseRep f k v -> Collect (k, v) -> f k v
forall k (f :: * -> * -> *) v.
Ord k =>
BaseRep f k v -> Collect (k, v) -> f k v
materialize BaseRep f k v
rep (Collect (k, v) -> f k v) -> Collect (k, v) -> f k v
forall a b. (a -> b) -> a -> b
$ do (k
x, v
_, v
z) <- f k v
x1 f k v -> f k v -> Collect (k, v, v)
forall k (f :: * -> * -> *) (g :: * -> * -> *) b c.
(Ord k, Iter f, Iter g) =>
f k b -> g k c -> Collect (k, b, c)
`domEq` f k v
f k v
x2; (k, v) -> Collect (k, v)
forall t. t -> Collect t
one (k
x, v
z)
compute (DRestrict (Dom (Base BaseRep f k v
_ f k v
x1)) (Base BaseRep f k v
rep f k v
x2)) = BaseRep f k v -> Collect (k, v) -> f k v
forall k (f :: * -> * -> *) v.
Ord k =>
BaseRep f k v -> Collect (k, v) -> f k v
materialize BaseRep f k v
rep (Collect (k, v) -> f k v) -> Collect (k, v) -> f k v
forall a b. (a -> b) -> a -> b
$ do (k
x, v
_, v
z) <- f k v
x1 f k v -> f k v -> Collect (k, v, v)
forall k (f :: * -> * -> *) (g :: * -> * -> *) b c.
(Ord k, Iter f, Iter g) =>
f k b -> g k c -> Collect (k, b, c)
`domEq` f k v
f k v
x2; (k, v) -> Collect (k, v)
forall t. t -> Collect t
one (k
x, v
z)
compute (DRestrict (SetSingleton k
k) (Base BaseRep f k v
rep f k v
x2)) = BaseRep f k v -> Collect (k, v) -> f k v
forall k (f :: * -> * -> *) v.
Ord k =>
BaseRep f k v -> Collect (k, v) -> f k v
materialize BaseRep f k v
rep (Collect (k, v) -> f k v) -> Collect (k, v) -> f k v
forall a b. (a -> b) -> a -> b
$ do (k
x, ()
_, v
z) <- (k -> Single k ()
forall k. k -> Single k ()
SetSingle k
k) Single k () -> f k v -> Collect (k, (), v)
forall k (f :: * -> * -> *) (g :: * -> * -> *) b c.
(Ord k, Iter f, Iter g) =>
f k b -> g k c -> Collect (k, b, c)
`domEq` f k v
f k v
x2; (k, v) -> Collect (k, v)
forall t. t -> Collect t
one (k
x, v
z)
compute (DRestrict (Dom (Singleton k
k v
_)) (Base BaseRep f k v
rep f k v
x2)) = BaseRep f k v -> Collect (k, v) -> f k v
forall k (f :: * -> * -> *) v.
Ord k =>
BaseRep f k v -> Collect (k, v) -> f k v
materialize BaseRep f k v
rep (Collect (k, v) -> f k v) -> Collect (k, v) -> f k v
forall a b. (a -> b) -> a -> b
$ do (k
x, ()
_, v
z) <- (k -> Single k ()
forall k. k -> Single k ()
SetSingle k
k) Single k () -> f k v -> Collect (k, (), v)
forall k (f :: * -> * -> *) (g :: * -> * -> *) b c.
(Ord k, Iter f, Iter g) =>
f k b -> g k c -> Collect (k, b, c)
`domEq` f k v
f k v
x2; (k, v) -> Collect (k, v)
forall t. t -> Collect t
one (k
x, v
z)
compute (DRestrict (Rng (Singleton k
_ v
v)) (Base BaseRep f k v
rep f k v
x2)) = BaseRep f k v -> Collect (k, v) -> f k v
forall k (f :: * -> * -> *) v.
Ord k =>
BaseRep f k v -> Collect (k, v) -> f k v
materialize BaseRep f k v
rep (Collect (k, v) -> f k v) -> Collect (k, v) -> f k v
forall a b. (a -> b) -> a -> b
$ do (v
x, ()
_, v
z) <- (v -> Single v ()
forall k. k -> Single k ()
SetSingle v
v) Single v () -> f v v -> Collect (v, (), v)
forall k (f :: * -> * -> *) (g :: * -> * -> *) b c.
(Ord k, Iter f, Iter g) =>
f k b -> g k c -> Collect (k, b, c)
`domEq` f v v
f k v
x2; (v, v) -> Collect (v, v)
forall t. t -> Collect t
one (v
x, v
z)
compute (DExclude (SetSingleton k
n) (Base BaseRep f k v
MapR f k v
m)) = Map k v -> Set k -> Map k v
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.withoutKeys f k v
Map k v
m (k -> Set k
forall a. a -> Set a
Set.singleton k
n)
compute (DExclude (Dom (Singleton k
n v
_v)) (Base BaseRep f k v
MapR f k v
m)) = Map k v -> Set k -> Map k v
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.withoutKeys f k v
Map k v
m (k -> Set k
forall a. a -> Set a
Set.singleton k
n)
compute (DExclude (Rng (Singleton k
_n v
v)) (Base BaseRep f k v
MapR f k v
m)) = Map k v -> Set k -> Map k v
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.withoutKeys f k v
Map k v
m (v -> Set v
forall a. a -> Set a
Set.singleton v
v)
compute (DExclude (Base BaseRep f k v
SetR (Sett x1)) (Base BaseRep f k v
MapR f k v
x2)) = Map k v -> Set k -> Map k v
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.withoutKeys f k v
Map k v
x2 Set k
Set k
x1
compute (DExclude (Dom (Base BaseRep f k v
MapR f k v
x1)) (Base BaseRep f k v
MapR f k v
x2)) = Map k v -> Map k v -> Map k v
forall k a b. Ord k => Map k a -> Map k b -> Map k a
noKeys f k v
Map k v
x2 f k v
Map k v
x1
compute (DExclude (SetSingleton k
k) (Base BaseRep f k v
BiMapR f k v
x)) = k -> f k v -> f k v
forall (f :: * -> * -> *) k v.
(Basic f, Ord k) =>
k -> f k v -> f k v
removekey k
k f k v
f k v
x
compute (DExclude (Dom (Singleton k
k v
_)) (Base BaseRep f k v
BiMapR f k v
x)) = k -> f k v -> f k v
forall (f :: * -> * -> *) k v.
(Basic f, Ord k) =>
k -> f k v -> f k v
removekey k
k f k v
f k v
x
compute (DExclude (Rng (Singleton k
_ v
v)) (Base BaseRep f k v
BiMapR f k v
x)) = v -> f v v -> f v v
forall (f :: * -> * -> *) k v.
(Basic f, Ord k) =>
k -> f k v -> f k v
removekey v
v f v v
f k v
x
compute (RExclude (Base BaseRep f k v
BiMapR f k v
x) (SetSingleton k
k)) = k -> BiMap k k k -> BiMap k k k
forall k v. (Ord k, Ord v) => v -> BiMap v k v -> BiMap v k v
removeval k
k f k v
BiMap k k k
x
compute (RExclude (Base BaseRep f k v
BiMapR f k v
x) (Dom (Singleton k
k v
_v))) = k -> BiMap k k k -> BiMap k k k
forall k v. (Ord k, Ord v) => v -> BiMap v k v -> BiMap v k v
removeval k
k f k v
BiMap k k k
x
compute (RExclude (Base BaseRep f k v
BiMapR f k v
x) (Rng (Singleton k
_k v
v))) = v -> BiMap v k v -> BiMap v k v
forall k v. (Ord k, Ord v) => v -> BiMap v k v -> BiMap v k v
removeval v
v f k v
BiMap v k v
x
compute (RExclude (Base BaseRep f k v
MapR f k v
xs) (Base BaseRep f k v
SetR (Sett y))) = (k -> Bool) -> Map k k -> Map k k
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (\k
x -> Bool -> Bool
not (k -> Set k -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member k
x Set k
y)) f k v
Map k k
xs
compute (RExclude (Base BaseRep f k v
MapR f k v
xs) (SetSingleton k
k)) = (k -> Bool) -> Map k k -> Map k k
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Bool -> Bool
not (Bool -> Bool) -> (k -> Bool) -> k -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (k -> k -> Bool
forall a. Eq a => a -> a -> Bool
== k
k)) f k v
Map k k
xs
compute (RExclude (Base BaseRep f k v
_rep f k v
lhs) (Base BaseRep f k v
SetR (Sett rhs))) | Set k -> Bool
forall a. Set a -> Bool
Set.null Set k
rhs = t
f k v
lhs
compute (RExclude (Base BaseRep f k v
_rep f k v
lhs) (Base BaseRep f k v
SingleR f k v
Fail)) = t
f k v
lhs
compute (RExclude (Base BaseRep f k v
rep f k v
lhs) Exp (g v ())
y) =
  BaseRep f k v -> Collect (k, v) -> f k v
forall k (f :: * -> * -> *) v.
Ord k =>
BaseRep f k v -> Collect (k, v) -> f k v
materialize BaseRep f k v
rep (Collect (k, v) -> f k v) -> Collect (k, v) -> f k v
forall a b. (a -> b) -> a -> b
$ do (k
a, v
b) <- f k v -> Collect (k, v)
forall (f :: * -> * -> *) k v. Iter f => f k v -> Collect (k, v)
lifo f k v
lhs; Bool -> Collect ()
when (Bool -> Bool
not (v -> Query v () -> Bool
forall (f :: * -> * -> *) key b.
(Iter f, Ord key) =>
key -> f key b -> Bool
haskey v
b Query v ()
Query v ()
rhs)); (k, v) -> Collect (k, v)
forall t. t -> Collect t
one (k
a, v
b)
  where
    (Query v ()
rhs, BaseRep g v ()
_) = Exp (g v ()) -> (Query v (), BaseRep g v ())
forall (f :: * -> * -> *) k v.
Exp (f k v) -> (Query k v, BaseRep f k v)
compile Exp (g v ())
y

-- (dom (Map(16)? ▷ (setSingleton _ )))
compute (RRestrict (Base BaseRep f k v
MapR f k v
xs) (SetSingleton k
k)) = (k -> Bool) -> Map k k -> Map k k
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (\k
x -> k
x k -> k -> Bool
forall a. Eq a => a -> a -> Bool
== k
k) f k v
Map k k
xs
-- ((dom rewards' ◁ delegs) ▷ dom poolParams)  in LedgerState.hs
compute (RRestrict (DRestrict (Dom (Base BaseRep f k v
MapR f k v
x)) (Base BaseRep f k v
MapR f k v
y)) (Dom (Base BaseRep f k v
MapR f k v
z))) = (k -> k -> Bool) -> Map k v -> Map k k -> Map k k
forall k v2 v1.
Ord k =>
(k -> v2 -> Bool) -> Map k v1 -> Map k v2 -> Map k v2
intersectDomP (\k
_k k
v -> k -> Map k v -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member k
v f k v
Map k v
z) f k v
Map k v
x f k v
Map k k
y
compute (RRestrict (DRestrict (Dom (Base BaseRep f k v
_r1 f k v
stkcreds)) (Base BaseRep f k v
r2 f k v
delegs)) (Dom (Base BaseRep f k v
_r3 f k v
stpools))) =
  BaseRep f k v -> Collect (k, v) -> f k v
forall k (f :: * -> * -> *) v.
Ord k =>
BaseRep f k v -> Collect (k, v) -> f k v
materialize BaseRep f k v
r2 (Collect (k, v) -> f k v) -> Collect (k, v) -> f k v
forall a b. (a -> b) -> a -> b
$ do (k
x, v
_, v
y) <- f k v
stkcreds f k v -> f k v -> Collect (k, v, v)
forall k (f :: * -> * -> *) (g :: * -> * -> *) b c.
(Ord k, Iter f, Iter g) =>
f k b -> g k c -> Collect (k, b, c)
`domEq` f k v
f k v
delegs; v
y v -> f v v -> Collect ()
forall (f :: * -> * -> *) k v.
(Iter f, Ord k) =>
k -> f k v -> Collect ()
`element` f v v
f k v
stpools; (k, v) -> Collect (k, v)
forall t. t -> Collect t
one (k
x, v
y)
compute (Elem k
k (Dom (Base BaseRep f k v
_rep f k v
x))) = k -> f k v -> Bool
forall (f :: * -> * -> *) key b.
(Iter f, Ord key) =>
key -> f key b -> Bool
haskey k
k f k v
f k v
x
compute (Elem k
k (Base BaseRep f k v
_rep f k v
rel)) = k -> f k v -> Bool
forall (f :: * -> * -> *) key b.
(Iter f, Ord key) =>
key -> f key b -> Bool
haskey k
k f k v
f k v
rel
compute (Elem k
k (Dom (Singleton k
key v
_v))) = k
k k -> k -> Bool
forall a. Eq a => a -> a -> Bool
== k
k
key
compute (Elem k
k (Rng (Singleton k
_ v
key))) = k
k k -> k -> Bool
forall a. Eq a => a -> a -> Bool
== k
v
key
compute (Elem k
k (SetSingleton k
key)) = k
k k -> k -> Bool
forall a. Eq a => a -> a -> Bool
== k
k
key
compute (Elem k
k (UnionOverrideLeft (Base BaseRep f k v
SetR (Sett x)) (Base BaseRep f k v
SetR (Sett y)))) = (k -> Set k -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member k
k Set k
Set k
x Bool -> Bool -> Bool
|| k -> Set k -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member k
k Set k
Set k
y)
compute (Elem k
k (UnionOverrideRight (Base BaseRep f k v
SetR (Sett x)) (Base BaseRep f k v
SetR (Sett y)))) = (k -> Set k -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member k
k Set k
Set k
x Bool -> Bool -> Bool
|| k -> Set k -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member k
k Set k
Set k
y)
compute (Elem k
k (UnionPlus (Base BaseRep f k v
SetR (Sett x)) (Base BaseRep f k v
SetR (Sett y)))) = (k -> Set k -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member k
k Set k
Set k
x Bool -> Bool -> Bool
|| k -> Set k -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member k
k Set k
Set k
y)
compute (Elem k
k (Intersect (Base BaseRep f k v
SetR (Sett x)) (Base BaseRep f k v
SetR (Sett y)))) = (k -> Set k -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member k
k Set k
Set k
x Bool -> Bool -> Bool
&& k -> Set k -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member k
k Set k
Set k
y)
compute (Elem k
k (DRestrict Exp (g k ())
s1 Exp (f k v)
m1)) = Exp Bool -> Bool
forall t. Exp t -> t
compute (k -> Exp (g k ()) -> Exp Bool
forall k (g :: * -> * -> *).
(Ord k, Iter g, Show k) =>
k -> Exp (g k ()) -> Exp Bool
Elem k
k Exp (g k ())
Exp (g k ())
s1) Bool -> Bool -> Bool
&& Exp Bool -> Bool
forall t. Exp t -> t
compute (k -> Exp (f k ()) -> Exp Bool
forall k (g :: * -> * -> *).
(Ord k, Iter g, Show k) =>
k -> Exp (g k ()) -> Exp Bool
Elem k
k Exp (f k ())
Exp (f k v)
m1)
compute (Elem k
k (DExclude Exp (g k ())
s1 Exp (f k v)
m1)) = Bool -> Bool
not (Exp Bool -> Bool
forall t. Exp t -> t
compute (k -> Exp (g k ()) -> Exp Bool
forall k (g :: * -> * -> *).
(Ord k, Iter g, Show k) =>
k -> Exp (g k ()) -> Exp Bool
Elem k
k Exp (g k ())
Exp (g k ())
s1)) Bool -> Bool -> Bool
&& Exp Bool -> Bool
forall t. Exp t -> t
compute (k -> Exp (f k ()) -> Exp Bool
forall k (g :: * -> * -> *).
(Ord k, Iter g, Show k) =>
k -> Exp (g k ()) -> Exp Bool
Elem k
k Exp (f k ())
Exp (f k v)
m1)
compute (NotElem k
k (Dom (Base BaseRep f k v
_rep f k v
x))) = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ k -> f k v -> Bool
forall (f :: * -> * -> *) key b.
(Iter f, Ord key) =>
key -> f key b -> Bool
haskey k
k f k v
f k v
x
compute (NotElem k
k (Base BaseRep f k v
_rep f k v
rel)) = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ k -> f k v -> Bool
forall (f :: * -> * -> *) key b.
(Iter f, Ord key) =>
key -> f key b -> Bool
haskey k
k f k v
f k v
rel
compute (NotElem k
k (Dom (Singleton k
key v
_v))) = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ k
k k -> k -> Bool
forall a. Eq a => a -> a -> Bool
== k
k
key
compute (NotElem k
k (Rng (Singleton k
_ v
key))) = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ k
k k -> k -> Bool
forall a. Eq a => a -> a -> Bool
== k
v
key
compute (NotElem k
k (SetSingleton k
key)) = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ k
k k -> k -> Bool
forall a. Eq a => a -> a -> Bool
== k
k
key
compute (NotElem k
k (UnionOverrideLeft (Base BaseRep f k v
SetR (Sett x)) (Base BaseRep f k v
SetR (Sett y)))) = Bool -> Bool
not (k -> Set k -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member k
k Set k
Set k
x Bool -> Bool -> Bool
|| k -> Set k -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member k
k Set k
Set k
y)
compute (NotElem k
k (UnionOverrideRight (Base BaseRep f k v
SetR (Sett x)) (Base BaseRep f k v
SetR (Sett y)))) = Bool -> Bool
not (k -> Set k -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member k
k Set k
Set k
x Bool -> Bool -> Bool
|| k -> Set k -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member k
k Set k
Set k
y)
compute (NotElem k
k (UnionPlus (Base BaseRep f k v
SetR (Sett x)) (Base BaseRep f k v
SetR (Sett y)))) = Bool -> Bool
not (k -> Set k -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member k
k Set k
Set k
x Bool -> Bool -> Bool
|| k -> Set k -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member k
k Set k
Set k
y)
compute (NotElem k
k (Intersect (Base BaseRep f k v
SetR (Sett x)) (Base BaseRep f k v
SetR (Sett y)))) = Bool -> Bool
not (k -> Set k -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member k
k Set k
Set k
x Bool -> Bool -> Bool
&& k -> Set k -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member k
k Set k
Set k
y)
compute (Subset (Base BaseRep f k v
SetR (Sett x)) (Base BaseRep f k v
SetR (Sett y))) = Set k -> Set k -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.isSubsetOf Set k
x Set k
Set k
y
compute (Subset (Base BaseRep f k v
SetR (Sett x)) (Base BaseRep f k v
MapR f k v
y)) = (k -> Bool) -> Set k -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (k -> Map k v -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` f k v
Map k v
y) Set k
Set k
x
compute (Subset (Base BaseRep f k v
SetR (Sett x)) (Dom (Base BaseRep f k v
MapR f k v
y))) = (k -> Bool) -> Set k -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (k -> Map k v -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` f k v
Map k v
y) Set k
Set k
x
compute (Subset (Base BaseRep f k v
MapR f k v
x) (Base BaseRep f k v
MapR f k v
y)) = (k -> v -> Bool -> Bool) -> Bool -> Map k v -> Bool
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey k -> v -> Bool -> Bool
accum Bool
True f k v
Map k v
x
  where
    accum :: k -> v -> Bool -> Bool
accum k
k v
_a Bool
ans = k -> Map k v -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member k
k f k v
Map k v
y Bool -> Bool -> Bool
&& Bool
ans
compute (Subset (Dom (Base BaseRep f k v
MapR f k v
x)) (Dom (Base BaseRep f k v
MapR f k v
y))) = (k -> v -> Bool -> Bool) -> Bool -> Map k v -> Bool
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey k -> v -> Bool -> Bool
accum Bool
True f k v
Map k v
x
  where
    accum :: k -> v -> Bool -> Bool
accum k
k v
_a Bool
ans = k -> Map k v -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member k
k f k v
Map k v
y Bool -> Bool -> Bool
&& Bool
ans
compute (Intersect (Base BaseRep f k v
SetR (Sett x)) (Base BaseRep f k v
SetR (Sett y))) = Set k -> Sett k ()
forall k. Set k -> Sett k ()
Sett (Set k -> Set k -> Set k
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set k
x Set k
Set k
y)
compute (Intersect (Base BaseRep f k v
MapR f k v
x) (Base BaseRep f k v
MapR f k v
y)) = Set k -> Sett k ()
forall k. Set k -> Sett k ()
Sett (Map k v -> Set k
forall k a. Map k a -> Set k
Map.keysSet (Map k v -> Map k v -> Map k v
forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.intersection f k v
Map k v
x f k v
Map k v
y))
compute (SetDiff (Base BaseRep f k v
SetR (Sett x)) (Base BaseRep f k v
SetR (Sett y))) = Set k -> Sett k ()
forall k. Set k -> Sett k ()
Sett (Set k -> Set k -> Set k
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set k
x Set k
Set k
y)
compute (SetDiff (Base BaseRep f k v
SetR (Sett x)) (Base BaseRep f k v
MapR f k v
y)) = Set k -> Sett k ()
forall k. Set k -> Sett k ()
Sett ((k -> Bool) -> Set k -> Set k
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (\k
e -> Bool -> Bool
not (k -> Map k v -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member k
e f k v
Map k v
y)) Set k
Set k
x)
compute (SetDiff (Base BaseRep f k v
SetR (Sett x)) (Dom (Base BaseRep f k v
MapR f k v
y))) = Set k -> Sett k ()
forall k. Set k -> Sett k ()
Sett ((k -> Bool) -> Set k -> Set k
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (\k
e -> Bool -> Bool
not (k -> Map k v -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member k
e f k v
Map k v
y)) Set k
Set k
x)
compute (SetDiff (Base BaseRep f k v
MapR f k v
x) (Dom (Base BaseRep f k v
MapR f k v
y))) = Map k v -> Map k v -> Map k v
forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.difference f k v
Map k v
x f k v
Map k v
y
compute (SetDiff (Base BaseRep f k v
MapR f k v
x) (Base BaseRep f k v
MapR f k v
y)) = (Map k v -> Map k v -> Map k v
forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.difference f k v
Map k v
x f k v
Map k v
y)
compute (SetDiff (Base BaseRep f k v
MapR f k v
x) (Base BaseRep f k v
SetR (Sett y))) = (Map k v -> Set k -> Map k v
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.withoutKeys f k v
Map k v
x Set k
Set k
y)
compute (UnionOverrideLeft (Base BaseRep f k v
_rep f k v
x) (Singleton k
k v
v)) = (k, v) -> f k v -> (v -> v -> v) -> f k v
forall (f :: * -> * -> *) k v.
(Basic f, Ord k) =>
(k, v) -> f k v -> (v -> v -> v) -> f k v
addkv (k
k, v
v) f k v
f k v
x (\v
old v
_new -> v
old) -- The value on the left is preferred over the right, so 'addkv' chooses 'old'
compute (UnionOverrideLeft (Base BaseRep f k v
MapR f k v
d0) (Base BaseRep f k v
MapR f k v
d1)) = Map k v -> Map k v -> Map k v
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union f k v
Map k v
d0 f k v
Map k v
d1 -- 'Map.union' is left biased, just what we want.
compute (UnionOverrideLeft (Base BaseRep f k v
SetR (Sett x)) (Base BaseRep f k v
SetR (Sett y))) = Set k -> Sett k ()
forall k. Set k -> Sett k ()
Sett (Set k -> Set k -> Set k
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set k
x Set k
Set k
y)
compute (UnionOverrideLeft (DExclude (SetSingleton k
k) (Base BaseRep f k v
MapR f k v
xs)) (Base BaseRep f k v
MapR f k v
ys)) = Map k v -> Map k v -> Map k v
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (k -> Map k v -> Map k v
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete k
k f k v
Map k v
xs) f k v
Map k v
ys
compute (UnionOverrideLeft (DExclude (Base BaseRep f k v
SetR (Sett s1)) (Base BaseRep f k v
MapR f k v
m2)) (Base BaseRep f k v
MapR f k v
m3)) = Map k v -> Map k v -> Map k v
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (Map k v -> Set k -> Map k v
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.withoutKeys f k v
Map k v
m2 Set k
Set k
s1) f k v
Map k v
m3
compute (UnionOverrideRight (Base BaseRep f k v
_rep f k v
x) (Singleton k
k v
v)) = (k, v) -> f k v -> (v -> v -> v) -> f k v
forall (f :: * -> * -> *) k v.
(Basic f, Ord k) =>
(k, v) -> f k v -> (v -> v -> v) -> f k v
addkv (k
k, v
v) f k v
f k v
x (\v
_old v
new -> v
new) -- The value on the right is preferred over the left, so 'addkv' chooses 'new'
compute (UnionOverrideRight (Base BaseRep f k v
MapR f k v
d0) (Base BaseRep f k v
MapR f k v
d1)) = Map k v -> Map k v -> Map k v
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union f k v
Map k v
d1 f k v
Map k v
d0 -- we pass @d1@ as first argument, since 'Map.union' is left biased.
compute (UnionOverrideRight (Base BaseRep f k v
SetR (Sett x)) (Base BaseRep f k v
SetR (Sett y))) = Set k -> Sett k ()
forall k. Set k -> Sett k ()
Sett (Set k -> Set k -> Set k
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set k
x Set k
Set k
y)
compute (UnionPlus (Base BaseRep f k v
MapR f k v
x) (Base BaseRep f k v
MapR f k v
y)) = (v -> v -> v) -> Map k v -> Map k v -> Map k v
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith v -> v -> v
forall a. Semigroup a => a -> a -> a
(<>) f k v
Map k v
x f k v
Map k v
y
compute (UnionPlus (Base BaseRep f k v
SetR (Sett x)) (Base BaseRep f k v
SetR (Sett y))) = Set k -> Sett k ()
forall k. Set k -> Sett k ()
Sett (Set k -> Set k -> Set k
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set k
x Set k
Set k
y) -- Recall (Sett k):: f k (), so () <> () = ()
compute (Singleton k
k v
v) = k -> v -> Single k v
forall k v. k -> v -> Single k v
Single k
k v
v
compute (SetSingleton k
k) = (k -> Single k ()
forall k. k -> Single k ()
SetSingle k
k)
compute (KeyEqual (Base BaseRep f k v
MapR f k v
m) (Base BaseRep f k v
MapR f k v
n)) = Map k v -> Map k v -> Bool
forall k v1 v2. Ord k => Map k v1 -> Map k v2 -> Bool
keysEqual f k v
Map k v
m f k v
Map k v
n
compute (KeyEqual (Base BaseRep f k v
BiMapR (MkBiMap m _)) (Base BaseRep f k v
BiMapR (MkBiMap n _))) = Map k v -> Map k v -> Bool
forall k v1 v2. Ord k => Map k v1 -> Map k v2 -> Bool
keysEqual Map k v
m Map k v
Map k v
n
compute (KeyEqual (Dom (Base BaseRep f k v
MapR f k v
m)) (Dom (Base BaseRep f k v
MapR f k v
n))) = Map k v -> Map k v -> Bool
forall k v1 v2. Ord k => Map k v1 -> Map k v2 -> Bool
keysEqual f k v
Map k v
m f k v
Map k v
n
compute (KeyEqual (Dom (Base BaseRep f k v
BiMapR (MkBiMap m _))) (Dom (Base BaseRep f k v
BiMapR (MkBiMap n _)))) = Map k v -> Map k v -> Bool
forall k v1 v2. Ord k => Map k v1 -> Map k v2 -> Bool
keysEqual Map k v
m Map k v
Map k v
n
compute (KeyEqual (Base BaseRep f k v
SetR (Sett m)) (Base BaseRep f k v
SetR (Sett n))) = Set k
n Set k -> Set k -> Bool
forall a. Eq a => a -> a -> Bool
== Set k
Set k
m
compute (KeyEqual (Base BaseRep f k v
MapR f k v
xs) (Base BaseRep f k v
SetR (Sett ys))) = Map k v -> Set k
forall k a. Map k a -> Set k
Map.keysSet f k v
Map k v
xs Set k -> Set k -> Bool
forall a. Eq a => a -> a -> Bool
== Set k
Set k
ys
compute Exp t
x = Exp t -> t
forall t. Exp t -> t
computeSlow Exp t
x

eval :: Embed s t => Exp t -> s
eval :: Exp t -> s
eval Exp t
x = t -> s
forall concrete base. Embed concrete base => base -> concrete
fromBase (Exp t -> t
forall t. Exp t -> t
compute Exp t
x)

computeSlow :: Exp t -> t
computeSlow :: Exp t -> t
computeSlow (Base BaseRep f k v
_ f k v
t) = t
f k v
t
computeSlow (e :: Exp t
e@(Dom Exp (f k v)
_)) = Exp (Sett k ()) -> Sett k ()
forall k (f :: * -> * -> *) v. Ord k => Exp (f k v) -> f k v
runSetExp Exp t
Exp (Sett k ())
e
computeSlow (e :: Exp t
e@(Rng Exp (f k v)
_)) = Exp (Sett v ()) -> Sett v ()
forall k (f :: * -> * -> *) v. Ord k => Exp (f k v) -> f k v
runSetExp Exp t
Exp (Sett v ())
e
computeSlow (e :: Exp t
e@(DRestrict Exp (g k ())
_ Exp (f k v)
_)) = Exp (f k v) -> f k v
forall k (f :: * -> * -> *) v. Ord k => Exp (f k v) -> f k v
runSetExp Exp t
Exp (f k v)
e
computeSlow (e :: Exp t
e@(DExclude Exp (g k ())
_ Exp (f k v)
_)) = Exp (f k v) -> f k v
forall k (f :: * -> * -> *) v. Ord k => Exp (f k v) -> f k v
runSetExp Exp t
Exp (f k v)
e
computeSlow (e :: Exp t
e@(RExclude Exp (f k v)
_ Exp (g v ())
_)) = Exp (f k v) -> f k v
forall k (f :: * -> * -> *) v. Ord k => Exp (f k v) -> f k v
runSetExp Exp t
Exp (f k v)
e
computeSlow (e :: Exp t
e@(RRestrict Exp (f k v)
_ Exp (g v ())
_)) = Exp (f k v) -> f k v
forall k (f :: * -> * -> *) v. Ord k => Exp (f k v) -> f k v
runSetExp Exp t
Exp (f k v)
e
computeSlow (e :: Exp t
e@(Elem k
_ Exp (g k ())
_)) = Exp Bool -> Bool
runBoolExp Exp t
Exp Bool
e
computeSlow (e :: Exp t
e@(NotElem k
_ Exp (g k ())
_)) = Exp Bool -> Bool
runBoolExp Exp t
Exp Bool
e
computeSlow (e :: Exp t
e@(Subset Exp (f k v)
_ Exp (g k u)
_)) = Exp Bool -> Bool
runBoolExp Exp t
Exp Bool
e
computeSlow (e :: Exp t
e@(Intersect Exp (f k v)
_ Exp (g k u)
_)) = Exp (Sett k ()) -> Sett k ()
forall k (f :: * -> * -> *) v. Ord k => Exp (f k v) -> f k v
runSetExp Exp t
Exp (Sett k ())
e
computeSlow (e :: Exp t
e@(SetDiff Exp (f k v)
_ Exp (g k u)
_)) = Exp (f k v) -> f k v
forall k (f :: * -> * -> *) v. Ord k => Exp (f k v) -> f k v
runSetExp Exp t
Exp (f k v)
e
computeSlow (e :: Exp t
e@(UnionOverrideLeft Exp (f k v)
_ Exp (g k v)
_)) = Exp (f k v) -> f k v
forall k (f :: * -> * -> *) v. Ord k => Exp (f k v) -> f k v
runSetExp Exp t
Exp (f k v)
e
computeSlow (e :: Exp t
e@(UnionOverrideRight Exp (f k v)
_ Exp (g k v)
_)) = Exp (f k v) -> f k v
forall k (f :: * -> * -> *) v. Ord k => Exp (f k v) -> f k v
runSetExp Exp t
Exp (f k v)
e
computeSlow (e :: Exp t
e@(UnionPlus Exp (f k n)
_ Exp (g k n)
_)) = Exp (f k n) -> f k n
forall k (f :: * -> * -> *) v. Ord k => Exp (f k v) -> f k v
runSetExp Exp t
Exp (f k n)
e
computeSlow (Singleton k
k v
v) = k -> v -> Single k v
forall k v. k -> v -> Single k v
Single k
k v
v
computeSlow (SetSingleton k
k) = (k -> Single k ()
forall k. k -> Single k ()
SetSingle k
k)
computeSlow (e :: Exp t
e@(KeyEqual Exp (f k v)
_ Exp (g k u)
_)) = Exp Bool -> Bool
runBoolExp Exp t
Exp Bool
e

-- ==========================================================================
-- The most basic operation of iteration, where (Iter f) is to use the 'nxt'
-- operator on (f k v) to create a (Collect k v). The two possible
-- ways to produce their elements are in LIFO or FIFO order.
-- ===========================================================================

lifo :: Iter f => f k v -> Collect (k, v)
lifo :: f k v -> Collect (k, v)
lifo f k v
x = do (k
k, v
v, f k v
x2) <- f k v -> Collect (k, v, f k v)
forall (f :: * -> * -> *) a b.
Iter f =>
f a b -> Collect (a, b, f a b)
nxt f k v
x; (k, v) -> Collect (k, v) -> Collect (k, v)
forall t. t -> Collect t -> Collect t
front (k
k, v
v) (f k v -> Collect (k, v)
forall (f :: * -> * -> *) k v. Iter f => f k v -> Collect (k, v)
lifo f k v
x2)

fifo :: Iter f => f k v -> Collect (k, v)
fifo :: f k v -> Collect (k, v)
fifo f k v
x = do (k
k, v
v, f k v
x2) <- f k v -> Collect (k, v, f k v)
forall (f :: * -> * -> *) a b.
Iter f =>
f a b -> Collect (a, b, f a b)
nxt f k v
x; Collect (k, v) -> (k, v) -> Collect (k, v)
forall t. Collect t -> t -> Collect t
rear (f k v -> Collect (k, v)
forall (f :: * -> * -> *) k v. Iter f => f k v -> Collect (k, v)
fifo f k v
x2) (k
k, v
v)

-- ================================================================================
-- A witness (BaseRep) can be used to specifiy how to build a specifc datatype from
-- a CONCRETE sequence of tuples (a [(k,v)]). This is a way to import a type from from
--  a list. But unlike 'materialize' an arbitray [(k,v)] may have duplicate keys,
--  so when that happens, use 'combine' to merge the associated values.
-- ================================================================================

addp :: (Ord k, Basic f) => (v -> v -> v) -> (k, v) -> f k v -> f k v
addp :: (v -> v -> v) -> (k, v) -> f k v -> f k v
addp v -> v -> v
combine (k
k, v
v) f k v
xs = (k, v) -> f k v -> (v -> v -> v) -> f k v
forall (f :: * -> * -> *) k v.
(Basic f, Ord k) =>
(k, v) -> f k v -> (v -> v -> v) -> f k v
addkv (k
k, v
v) f k v
xs v -> v -> v
combine

-- The combine function comb = (\ earlier later -> later) will let values
-- later in the list override ones earlier in the list, and comb =
-- (\ earlier later -> earlier) will keep the value that appears first in the list

fromList :: Ord k => BaseRep f k v -> (v -> v -> v) -> [(k, v)] -> f k v
fromList :: BaseRep f k v -> (v -> v -> v) -> [(k, v)] -> f k v
fromList BaseRep f k v
MapR v -> v -> v
combine [(k, v)]
xs = (v -> v -> v) -> [(k, v)] -> Map k v
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith v -> v -> v
combine [(k, v)]
xs
fromList BaseRep f k v
ListR v -> v -> v
combine [(k, v)]
xs = (v -> v -> v) -> [(k, v)] -> List k v
forall k v. Ord k => (v -> v -> v) -> [(k, v)] -> List k v
fromPairs v -> v -> v
combine [(k, v)]
xs
fromList BaseRep f k v
SetR v -> v -> v
combine [(k, v)]
xs = ((k, v) -> Sett k v -> Sett k v)
-> Sett k v -> [(k, v)] -> Sett k v
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((v -> v -> v) -> (k, v) -> Sett k v -> Sett k v
forall k (f :: * -> * -> *) v.
(Ord k, Basic f) =>
(v -> v -> v) -> (k, v) -> f k v -> f k v
addp v -> v -> v
combine) (Set k -> Sett k ()
forall k. Set k -> Sett k ()
Sett (Set k
forall a. Set a
Set.empty)) [(k, v)]
xs
fromList BaseRep f k v
BiMapR v -> v -> v
combine [(k, v)]
xs = (v -> v -> v) -> [(k, v)] -> BiMap v k v
forall k v.
(Ord k, Ord v) =>
(v -> v -> v) -> [(k, v)] -> BiMap v k v
biMapFromList v -> v -> v
combine [(k, v)]
xs
fromList BaseRep f k v
SingleR v -> v -> v
combine [(k, v)]
xs = ((k, v) -> Single k v -> Single k v)
-> Single k v -> [(k, v)] -> Single k v
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((v -> v -> v) -> (k, v) -> Single k v -> Single k v
forall k (f :: * -> * -> *) v.
(Ord k, Basic f) =>
(v -> v -> v) -> (k, v) -> f k v -> f k v
addp v -> v -> v
combine) Single k v
forall k v. Single k v
Fail [(k, v)]
xs
fromList (ViewR Tag coin cred pool ptr k v
Rew) v -> v -> v
combine [(k, v)]
xs = ((k, v) -> View v k pool ptr k v -> View v k pool ptr k v)
-> View v k pool ptr k v -> [(k, v)] -> View v k pool ptr k v
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((v -> v -> v)
-> (k, v) -> View v k pool ptr k v -> View v k pool ptr k v
forall k (f :: * -> * -> *) v.
(Ord k, Basic f) =>
(v -> v -> v) -> (k, v) -> f k v -> f k v
addp v -> v -> v
combine) (UMap v k pool ptr -> View v k pool ptr k v
forall coin cr pl ptr.
UMap coin cr pl ptr -> View coin cr pl ptr cr coin
Rewards UMap v k pool ptr
forall coin cr pool ptr. UMap coin cr pool ptr
UM.empty) [(k, v)]
xs
fromList (ViewR Tag coin cred pool ptr k v
Del) v -> v -> v
combine [(k, v)]
xs = ((k, v) -> View coin k v ptr k v -> View coin k v ptr k v)
-> View coin k v ptr k v -> [(k, v)] -> View coin k v ptr k v
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((v -> v -> v)
-> (k, v) -> View coin k v ptr k v -> View coin k v ptr k v
forall k (f :: * -> * -> *) v.
(Ord k, Basic f) =>
(v -> v -> v) -> (k, v) -> f k v -> f k v
addp v -> v -> v
combine) (UMap coin k v ptr -> View coin k v ptr k v
forall coin cr pl ptr.
UMap coin cr pl ptr -> View coin cr pl ptr cr pl
Delegations UMap coin k v ptr
forall coin cr pool ptr. UMap coin cr pool ptr
UM.empty) [(k, v)]
xs
fromList (ViewR Tag coin cred pool ptr k v
Ptr) v -> v -> v
combine [(k, v)]
xs = ((k, v) -> View coin v pool k k v -> View coin v pool k k v)
-> View coin v pool k k v -> [(k, v)] -> View coin v pool k k v
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((v -> v -> v)
-> (k, v) -> View coin v pool k k v -> View coin v pool k k v
forall k (f :: * -> * -> *) v.
(Ord k, Basic f) =>
(v -> v -> v) -> (k, v) -> f k v -> f k v
addp v -> v -> v
combine) (UMap coin v pool k -> View coin v pool k k v
forall coin cr pl ptr.
UMap coin cr pl ptr -> View coin cr pl ptr ptr cr
Ptrs UMap coin v pool k
forall coin cr pool ptr. UMap coin cr pool ptr
UM.empty) [(k, v)]
xs

-- =======================================================================================

-- | A witness (BaseRep) can be used to materialize a (Collect k v) into the type witnessed by the BaseRep.
-- Recall a (Collect k v) has no intrinsic type (it is just an ABSTRACT sequence of tuples), so
-- the witness describes how to turn them into the chosen datatype. Note that materialize is meant
-- to be applied to a collection built by iterating over a Query. This produces the keys in
-- ascending order, with no duplicate keys. So we do not need to specify how to merge duplicate values.
materialize :: (Ord k) => BaseRep f k v -> Collect (k, v) -> f k v
materialize :: BaseRep f k v -> Collect (k, v) -> f k v
materialize BaseRep f k v
ListR Collect (k, v)
x = (v -> v -> v) -> [(k, v)] -> List k v
forall k v. Ord k => (v -> v -> v) -> [(k, v)] -> List k v
fromPairs (\v
l v
_r -> v
l) (Collect (k, v)
-> [(k, v)] -> ((k, v) -> [(k, v)] -> [(k, v)]) -> [(k, v)]
forall tuple.
Collect tuple -> forall ans. ans -> (tuple -> ans -> ans) -> ans
runCollect Collect (k, v)
x [] (:))
materialize BaseRep f k v
MapR Collect (k, v)
x = Collect (k, v)
-> Map k v -> ((k, v) -> Map k v -> Map k v) -> Map k v
forall tuple.
Collect tuple -> forall ans. ans -> (tuple -> ans -> ans) -> ans
runCollect Collect (k, v)
x Map k v
forall k a. Map k a
Map.empty (\(k
k, v
v) Map k v
ans -> k -> v -> Map k v -> Map k v
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
k v
v Map k v
ans)
materialize BaseRep f k v
SetR Collect (k, v)
x = Set k -> Sett k ()
forall k. Set k -> Sett k ()
Sett (Collect (k, v) -> Set k -> ((k, v) -> Set k -> Set k) -> Set k
forall tuple.
Collect tuple -> forall ans. ans -> (tuple -> ans -> ans) -> ans
runCollect Collect (k, v)
x Set k
forall a. Set a
Set.empty (\(k
k, v
_) Set k
ans -> k -> Set k -> Set k
forall a. Ord a => a -> Set a -> Set a
Set.insert k
k Set k
ans))
materialize BaseRep f k v
BiMapR Collect (k, v)
x = Collect (k, v)
-> BiMap v k v
-> ((k, v) -> BiMap v k v -> BiMap v k v)
-> BiMap v k v
forall tuple.
Collect tuple -> forall ans. ans -> (tuple -> ans -> ans) -> ans
runCollect Collect (k, v)
x BiMap v k v
forall v k. BiMap v k v
biMapEmpty (\(k
k, v
v) BiMap v k v
ans -> k -> v -> BiMap v k v -> BiMap v k v
forall (f :: * -> * -> *) k v.
(Basic f, Ord k) =>
k -> v -> f k v -> f k v
addpair k
k v
v BiMap v k v
ans)
materialize BaseRep f k v
SingleR Collect (k, v)
x = Collect (k, v)
-> Single k v -> ((k, v) -> Single k v -> Single k v) -> Single k v
forall tuple.
Collect tuple -> forall ans. ans -> (tuple -> ans -> ans) -> ans
runCollect Collect (k, v)
x Single k v
forall k v. Single k v
Fail (\(k
k, v
v) Single k v
_ignore -> k -> v -> Single k v
forall k v. k -> v -> Single k v
Single k
k v
v)
materialize (ViewR Tag coin cred pool ptr k v
Rew) Collect (k, v)
x = Collect (k, v)
-> View v k pool ptr k v
-> ((k, v) -> View v k pool ptr k v -> View v k pool ptr k v)
-> View v k pool ptr k v
forall tuple.
Collect tuple -> forall ans. ans -> (tuple -> ans -> ans) -> ans
runCollect Collect (k, v)
x (UMap v k pool ptr -> View v k pool ptr k v
forall coin cr pl ptr.
UMap coin cr pl ptr -> View coin cr pl ptr cr coin
Rewards UMap v k pool ptr
forall coin cr pool ptr. UMap coin cr pool ptr
UM.empty) (\(k
k, v
v) View v k pool ptr k v
ans -> k -> v -> View v k pool ptr k v -> View v k pool ptr k v
forall cr coin ptr k v pool.
(Ord cr, Monoid coin, Ord ptr) =>
k -> v -> View coin cr pool ptr k v -> View coin cr pool ptr k v
UM.insert' k
k v
v View v k pool ptr k v
ans)
materialize (ViewR Tag coin cred pool ptr k v
Del) Collect (k, v)
x = Collect (k, v)
-> View coin k v ptr k v
-> ((k, v) -> View coin k v ptr k v -> View coin k v ptr k v)
-> View coin k v ptr k v
forall tuple.
Collect tuple -> forall ans. ans -> (tuple -> ans -> ans) -> ans
runCollect Collect (k, v)
x (UMap coin k v ptr -> View coin k v ptr k v
forall coin cr pl ptr.
UMap coin cr pl ptr -> View coin cr pl ptr cr pl
Delegations UMap coin k v ptr
forall coin cr pool ptr. UMap coin cr pool ptr
UM.empty) (\(k
k, v
v) View coin k v ptr k v
ans -> k -> v -> View coin k v ptr k v -> View coin k v ptr k v
forall cr coin ptr k v pool.
(Ord cr, Monoid coin, Ord ptr) =>
k -> v -> View coin cr pool ptr k v -> View coin cr pool ptr k v
UM.insert' k
k v
v View coin k v ptr k v
ans)
materialize (ViewR Tag coin cred pool ptr k v
Ptr) Collect (k, v)
x = Collect (k, v)
-> View coin v pool k k v
-> ((k, v) -> View coin v pool k k v -> View coin v pool k k v)
-> View coin v pool k k v
forall tuple.
Collect tuple -> forall ans. ans -> (tuple -> ans -> ans) -> ans
runCollect Collect (k, v)
x (UMap coin v pool k -> View coin v pool k k v
forall coin cr pl ptr.
UMap coin cr pl ptr -> View coin cr pl ptr ptr cr
Ptrs UMap coin v pool k
forall coin cr pool ptr. UMap coin cr pool ptr
UM.empty) (\(k
k, v
v) View coin v pool k k v
ans -> k -> v -> View coin v pool k k v -> View coin v pool k k v
forall cr coin ptr k v pool.
(Ord cr, Monoid coin, Ord ptr) =>
k -> v -> View coin cr pool ptr k v -> View coin cr pool ptr k v
UM.insert' k
k v
v View coin v pool k k v
ans)

-- =========================================================================================
-- Now we make an iterator that collects triples, on the intersection
-- of the domain of the two Iter types 'f' and 'g'. An answer of (k,b,c) means that
-- (k,b) is in m::f k a, and (k,c) is in n::g k c. All the other possible triples
-- are skipped over.  This is an instance of a thing called a "Generic Join"
-- See https://arxiv.org/pdf/1310.3314.pdf  or  http://personales.dcc.uchile.cl/~pbarcelo/ngo.pdf
-- The number of tuples it touches is proportional to the size of the output (modulo log factors).
-- It's cost is unrelated to the size of its inputs (modulo log factors)
-- This is a very specific version of the AndD compound iterator. It is used in the function 'eval'
-- =========================================================================================

(⨝) :: (Ord k, Iter f, Iter g) => f k b -> g k c -> Collect (k, b, c)
⨝ :: f k b -> g k c -> Collect (k, b, c)
(⨝) = f k b -> g k c -> Collect (k, b, c)
forall k (f :: * -> * -> *) (g :: * -> * -> *) b c.
(Ord k, Iter f, Iter g) =>
f k b -> g k c -> Collect (k, b, c)
domEq

domEq :: (Ord k, Iter f, Iter g) => f k b -> g k c -> Collect (k, b, c)
domEq :: f k b -> g k c -> Collect (k, b, c)
domEq f k b
m g k c
n = do
  (k, b, f k b)
triplem <- f k b -> Collect (k, b, f k b)
forall (f :: * -> * -> *) a b.
Iter f =>
f a b -> Collect (a, b, f a b)
nxt f k b
m
  (k, c, g k c)
triplen <- g k c -> Collect (k, c, g k c)
forall (f :: * -> * -> *) a b.
Iter f =>
f a b -> Collect (a, b, f a b)
nxt g k c
n
  let loop :: (k, b, f k b) -> (k, b, f k b) -> Collect (k, b, b)
loop (mt :: (k, b, f k b)
mt@(k
k1, b
b, f k b
nextm)) (nt :: (k, b, f k b)
nt@(k
k2, b
c, f k b
nextn)) =
        case k -> k -> Ordering
forall a. Ord a => a -> a -> Ordering
compare k
k1 k
k2 of
          Ordering
EQ -> (k, b, b) -> Collect (k, b, b) -> Collect (k, b, b)
forall t. t -> Collect t -> Collect t
front (k
k1, b
b, b
c) (f k b -> f k b -> Collect (k, b, b)
forall k (f :: * -> * -> *) (g :: * -> * -> *) b c.
(Ord k, Iter f, Iter g) =>
f k b -> g k c -> Collect (k, b, c)
domEq f k b
nextm f k b
nextn)
          Ordering
LT -> do (k, b, f k b)
mt' <- k -> f k b -> Collect (k, b, f k b)
forall (f :: * -> * -> *) k b.
(Iter f, Ord k) =>
k -> f k b -> Collect (k, b, f k b)
lub k
k2 f k b
nextm; (k, b, f k b) -> (k, b, f k b) -> Collect (k, b, b)
loop (k, b, f k b)
mt' (k, b, f k b)
nt
          Ordering
GT -> do (k, b, f k b)
nt' <- k -> f k b -> Collect (k, b, f k b)
forall (f :: * -> * -> *) k b.
(Iter f, Ord k) =>
k -> f k b -> Collect (k, b, f k b)
lub k
k1 f k b
nextn; (k, b, f k b) -> (k, b, f k b) -> Collect (k, b, b)
loop (k, b, f k b)
mt (k, b, f k b)
nt'
  (k, b, f k b) -> (k, c, g k c) -> Collect (k, b, c)
forall k (f :: * -> * -> *) (f :: * -> * -> *) b b.
(Ord k, Iter f, Iter f) =>
(k, b, f k b) -> (k, b, f k b) -> Collect (k, b, b)
loop (k, b, f k b)
triplem (k, c, g k c)
triplen

-- This is included here for the benchmark tests. It is much slower because it does not use lub.

domEqSlow :: (Ord k, Iter f, Iter g) => f k b -> g k c -> Collect (k, b, c)
domEqSlow :: f k b -> g k c -> Collect (k, b, c)
domEqSlow f k b
m g k c
n = do
  (k, b, f k b)
triplem <- f k b -> Collect (k, b, f k b)
forall (f :: * -> * -> *) a b.
Iter f =>
f a b -> Collect (a, b, f a b)
nxt f k b
m
  (k, c, g k c)
triplen <- g k c -> Collect (k, c, g k c)
forall (f :: * -> * -> *) a b.
Iter f =>
f a b -> Collect (a, b, f a b)
nxt g k c
n
  let loop :: (a, b, f a b) -> (a, b, f a b) -> Collect (a, b, b)
loop (mt :: (a, b, f a b)
mt@(a
k1, b
b, f a b
nextm)) (nt :: (a, b, f a b)
nt@(a
k2, b
c, f a b
nextn)) =
        case a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
k1 a
k2 of
          Ordering
EQ -> (a, b, b) -> Collect (a, b, b) -> Collect (a, b, b)
forall t. t -> Collect t -> Collect t
front (a
k1, b
b, b
c) (f a b -> f a b -> Collect (a, b, b)
forall k (f :: * -> * -> *) (g :: * -> * -> *) b c.
(Ord k, Iter f, Iter g) =>
f k b -> g k c -> Collect (k, b, c)
domEqSlow f a b
nextm f a b
nextn)
          Ordering
LT -> do (a, b, f a b)
mt' <- f a b -> Collect (a, b, f a b)
forall (f :: * -> * -> *) a b.
Iter f =>
f a b -> Collect (a, b, f a b)
nxt f a b
nextm; (a, b, f a b) -> (a, b, f a b) -> Collect (a, b, b)
loop (a, b, f a b)
mt' (a, b, f a b)
nt
          Ordering
GT -> do (a, b, f a b)
nt' <- f a b -> Collect (a, b, f a b)
forall (f :: * -> * -> *) a b.
Iter f =>
f a b -> Collect (a, b, f a b)
nxt f a b
nextn; (a, b, f a b) -> (a, b, f a b) -> Collect (a, b, b)
loop (a, b, f a b)
mt (a, b, f a b)
nt'
  (k, b, f k b) -> (k, c, g k c) -> Collect (k, b, c)
forall k (f :: * -> * -> *) (f :: * -> * -> *) b b.
(Ord k, Iter f, Iter f) =>
(k, b, f k b) -> (k, b, f k b) -> Collect (k, b, b)
loop (k, b, f k b)
triplem (k, c, g k c)
triplen

-- ================================================================================