{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}


module Control.Iterate.SetAlgebra where

import Cardano.Binary
  ( Decoder,
    FromCBOR (..),
    ToCBOR (..),
    decodeListLen,
    decodeMapSkel,
    dropMap,
  )
import Codec.CBOR.Encoding (encodeListLen)
import Control.DeepSeq (NFData (rnf))
import Control.Iterate.Collect
import Control.Monad (void)
import Data.Coders (invalidKey)
import Data.List (sortBy)
import qualified Data.List as List
import Data.Map.Internal (Map (..), link, link2)
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import qualified Data.Set as Set
import NoThunks.Class (NoThunks (..))
import Text.PrettyPrint.ANSI.Leijen (Doc, align, parens, text, vsep, (<+>))
import Prelude hiding (lookup)

-- ==================================================================================================
-- | In order to build typed Exp (which are a typed deep embedding) of Set operations, we need to know
-- what kind of basic types of Maps and Sets can be embedded. Every Basic type has a few operations
-- for creating one from a list, for adding and removing key-value pairs, looking up a value given a key.
-- Instances of this algebra are functional in that every key has exactly one value associated with it.
-- ===================================================================================================

class Iter f => Basic f where
  -- | in addpair the new value always prevails, to make a choice use 'addkv' which has a combining function that allows choice.
  addpair:: (Ord k) => k -> v -> f k v -> f k v
  addpair k
k v
v f k v
f = (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 (\ v
_old v
new -> v
new)
  -- | use (\ old new -> old) if you want the v in (f k v) to prevail, and use (\ old new -> new) if you want the v in (k,v) to prevail
  addkv :: Ord k => (k,v) -> f k v -> (v -> v -> v) -> f k v
  removekey:: (Ord k) => k -> f k v -> f k v
  domain:: Ord k => f k v -> Set k
  range:: Ord v => f k v -> Set v
  emptyc:: Ord k => f k v
  emptyc = [Char] -> f k v
forall a. HasCallStack => [Char] -> a
error ([Char]
"emptyc only works on some types.")

-- ========== Basic List ==============

-- | The constructor for List is hidden, since it requires some invariants. Use fromPairs to build an initial List.

instance Basic List where
   addkv :: (k, v) -> List k v -> (v -> v -> v) -> List k v
addkv (k
k,v
v) (UnSafeList [(k, v)]
xs) v -> v -> v
comb = [(k, v)] -> List k v
forall k v. Ord k => [(k, v)] -> List k v
UnSafeList([(k, v)] -> [(k, v)]
insert [(k, v)]
xs) where
       insert :: [(k, v)] -> [(k, v)]
insert [] = [(k
k,v
v)]
       insert ((k
key,v
u):[(k, v)]
ys) =
         case k -> k -> Ordering
forall a. Ord a => a -> a -> Ordering
compare k
key k
k of
           Ordering
LT -> (k
key,v
u) (k, v) -> [(k, v)] -> [(k, v)]
forall a. a -> [a] -> [a]
: [(k, v)] -> [(k, v)]
insert [(k, v)]
ys
           Ordering
GT -> (k
k,v
v) (k, v) -> [(k, v)] -> [(k, v)]
forall a. a -> [a] -> [a]
: (k
key,v
u) (k, v) -> [(k, v)] -> [(k, v)]
forall a. a -> [a] -> [a]
: [(k, v)]
ys
           Ordering
EQ -> (k
key,v -> v -> v
comb v
u v
v)(k, v) -> [(k, v)] -> [(k, v)]
forall a. a -> [a] -> [a]
:[(k, v)]
ys
   removekey :: k -> List k v -> List k v
removekey k
k (UnSafeList [(k, v)]
xs) = [(k, v)] -> List k v
forall k v. Ord k => [(k, v)] -> List k v
UnSafeList([(k, v)] -> [(k, v)]
remove [(k, v)]
xs) where
       remove :: [(k, v)] -> [(k, v)]
remove [] = []
       remove ((k
key,v
u):[(k, v)]
ys) = if k
keyk -> k -> Bool
forall a. Eq a => a -> a -> Bool
==k
k then [(k, v)]
ys else (k
k,v
u)(k, v) -> [(k, v)] -> [(k, v)]
forall a. a -> [a] -> [a]
:([(k, v)] -> [(k, v)]
remove [(k, v)]
ys)
   domain :: List k v -> Set k
domain (UnSafeList [(k, v)]
xs) = ((k, v) -> Set k -> Set k) -> Set k -> [(k, v)] -> Set k
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ (k
k,v
_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) Set k
forall a. Set a
Set.empty [(k, v)]
xs
   range :: List k v -> Set v
range (UnSafeList [(k, v)]
xs) = ((k, v) -> Set v -> Set v) -> Set v -> [(k, v)] -> Set v
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ (k
_k,v
v) Set v
ans -> v -> Set v -> Set v
forall a. Ord a => a -> Set a -> Set a
Set.insert v
v Set v
ans) Set v
forall a. Set a
Set.empty [(k, v)]
xs
   emptyc :: List k v
emptyc = ([(k, v)] -> List k v
forall k v. Ord k => [(k, v)] -> List k v
UnSafeList [])


fromPairs:: Ord k => (v -> v -> v) -> [(k,v)] -> List k v
fromPairs :: (v -> v -> v) -> [(k, v)] -> List k v
fromPairs v -> v -> v
combine [(k, v)]
xs = [(k, v)] -> List k v
forall k v. Ord k => [(k, v)] -> List k v
UnSafeList((v -> v -> v) -> [(k, v)] -> [(k, v)]
forall k v. Ord k => (v -> v -> v) -> [(k, v)] -> [(k, v)]
normalize v -> v -> v
combine (((k, v) -> (k, v) -> Ordering) -> [(k, v)] -> [(k, v)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\ (k, v)
x (k, v)
y -> k -> k -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ((k, v) -> k
forall a b. (a, b) -> a
fst (k, v)
x) ((k, v) -> k
forall a b. (a, b) -> a
fst (k, v)
y)) [(k, v)]
xs))

normalize :: Ord k => (v -> v -> v) -> [(k,v)] -> [(k,v)]
normalize :: (v -> v -> v) -> [(k, v)] -> [(k, v)]
normalize v -> v -> v
_combine [] = []
normalize v -> v -> v
_combine [(k
k,v
v)] = [(k
k,v
v)]
normalize v -> v -> v
combine ((k
k1,v
v1):(k
k2,v
v2):[(k, v)]
more) | k
k1k -> k -> Bool
forall a. Eq a => a -> a -> Bool
==k
k2 = (v -> v -> v) -> [(k, v)] -> [(k, v)]
forall k v. Ord k => (v -> v -> v) -> [(k, v)] -> [(k, v)]
normalize v -> v -> v
combine ((k
k1,v -> v -> v
combine v
v1 v
v2)(k, v) -> [(k, v)] -> [(k, v)]
forall a. a -> [a] -> [a]
:[(k, v)]
more)
normalize v -> v -> v
combine ((k, v)
p:[(k, v)]
pairs) = (k, v)
p (k, v) -> [(k, v)] -> [(k, v)]
forall a. a -> [a] -> [a]
: (v -> v -> v) -> [(k, v)] -> [(k, v)]
forall k v. Ord k => (v -> v -> v) -> [(k, v)] -> [(k, v)]
normalize v -> v -> v
combine [(k, v)]
pairs


-- ================ Basic Single ===============
-- The Single type encode 0 or 1 pairs. Iteration is trivial. Succeeds only once.

data Single k v where
  Single :: k -> v -> Single k v
  Fail :: Single k v
  SetSingle :: k -> Single k ()

deriving instance (Eq k,Eq v) => Eq (Single k v)

-- Since we can only store one key, we have to choose who wins
-- We use the combine function to decide. (\ old new -> old) keeps
-- the orginal value. (\ old new -> new) overwrites the stored value.
-- Something else like (\ old new -> old+new) overwrites with a combination

instance Basic Single where
  addkv :: (k, v) -> Single k v -> (v -> v -> v) -> Single k v
addkv (k
k,v
v) Single k v
set v -> v -> v
comb =
     case Single k v
set of
       (Single k
a v
b) -> k -> v -> Single k v
forall k v. k -> v -> Single k v
Single k
a (v -> v -> v
comb v
b v
v)
       (SetSingle k
a) -> k -> Single k ()
forall k. k -> Single k ()
SetSingle k
a
       Single k v
Fail ->  k -> v -> Single k v
forall k v. k -> v -> Single k v
Single k
k v
v

  removekey :: k -> Single k v -> Single k v
removekey k
key (Single k
a v
b) = if k
keyk -> k -> Bool
forall a. Eq a => a -> a -> Bool
==k
a then Single k v
forall k v. Single k v
Fail else (k -> v -> Single k v
forall k v. k -> v -> Single k v
Single k
a v
b)
  removekey k
key (SetSingle k
a) = if k
keyk -> k -> Bool
forall a. Eq a => a -> a -> Bool
==k
a then Single k v
forall k v. Single k v
Fail else (k -> Single k ()
forall k. k -> Single k ()
SetSingle k
a)
  removekey k
_key Single k v
Fail = Single k v
forall k v. Single k v
Fail
  domain :: Single k v -> Set k
domain (Single k
a v
_b) = k -> Set k
forall a. a -> Set a
Set.singleton k
a
  domain (SetSingle k
a) = k -> Set k
forall a. a -> Set a
Set.singleton k
a
  domain Single k v
Fail = Set k
forall a. Set a
Set.empty
  range :: Single k v -> Set v
range (Single k
_a v
b) = v -> Set v
forall a. a -> Set a
Set.singleton v
b
  range (SetSingle k
_a) = () -> Set ()
forall a. a -> Set a
Set.singleton ()
  range Single k v
Fail = Set v
forall a. Set a
Set.empty
  emptyc :: Single k v
emptyc = Single k v
forall k v. Single k v
Fail

-- ============== Basic Map =========================

instance Basic Map.Map where
  addkv :: (k, v) -> Map k v -> (v -> v -> v) -> Map k v
addkv (k
k,v
v) Map k v
m v -> v -> v
comb = (v -> v -> v) -> k -> v -> Map k v -> Map k v
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith ((v -> v -> v) -> v -> v -> v
forall v. (v -> v -> v) -> v -> v -> v
mapflip v -> v -> v
comb) k
k v
v Map k v
m
  removekey :: k -> Map k v -> Map k v
removekey k
k Map k v
m = k -> Map k v -> Map k v
forall k v. Ord k => k -> Map k v -> Map k v
Map.delete k
k Map k v
m
  domain :: Map k v -> Set k
domain Map k v
x = Map k v -> Set k
forall k a. Map k a -> Set k
Map.keysSet Map k v
x
  range :: Map k v -> Set v
range Map k v
xs = (k -> v -> Set v -> Set v) -> Set v -> Map k v -> Set v
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey (\ k
_k v
v  Set v
ans -> v -> Set v -> Set v
forall a. Ord a => a -> Set a -> Set a
Set.insert v
v Set v
ans) Set v
forall a. Set a
Set.empty Map k v
xs
  emptyc :: Map k v
emptyc = Map k v
forall k a. Map k a
Map.empty

-- Data.Map uses(\ new old -> ...) while our convention is (\ old new -> ...)
-- We also use this in the Basic instance for BiMap, which uses Data.Map
mapflip :: (v -> v -> v) -> (v -> v -> v)
mapflip :: (v -> v -> v) -> v -> v -> v
mapflip v -> v -> v
f = (\v
old v
new -> v -> v -> v
f v
new v
old)

-- =================== Basic BiMap =====================
-- For Bijections we define (BiMap v k v).  Reasons we can't use (Data.Bimap k v)
-- 1) We need to enforce that the second argument `v` is in the Ord class, when making it an Iter instance.
-- 2) The constructor for Data.BiMap is not exported, and it implements a Bijection
-- 3) Missing operation 'restrictkeys' and 'withoutkeys' make performant versions of operations  ◁ ⋪ ▷ ⋫ hard.
-- 4) Missing operation 'union', make performant versions of ∪ and ⨃ hard.
-- 5) So we roll our own which is really a (Data.Map k v) with an index that maps v to Set{k}


data BiMap v a b where MkBiMap:: (v ~ b) => !(Map.Map a b) -> !(Map.Map b (Set.Set a)) -> BiMap v a b
                                --  ^   the 1st and 3rd parameter must be the same:             ^   ^

-- ============== begin necessary Cardano.Binary instances ===============
instance (Ord a, Ord b, ToCBOR a, ToCBOR b) => ToCBOR (BiMap b a b) where
  -- The `toCBOR` instance encodes only the forward map. We wrap this in a
  -- length-one list because a _previous_ encoding wrote out both maps, and we
  -- can easily use the list length token to distinguish between them.
  toCBOR :: BiMap b a b -> Encoding
toCBOR (MkBiMap Map a b
l Map b (Set a)
_) = Word -> Encoding
encodeListLen Word
1 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Map a b -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Map a b
l

instance
  forall a b.
  (Ord a, Ord b, FromCBOR a, FromCBOR b) =>
  FromCBOR (BiMap b a b)
  where
  fromCBOR :: Decoder s (BiMap b a b)
fromCBOR =
    Decoder s Int
forall s. Decoder s Int
decodeListLen Decoder s Int
-> (Int -> Decoder s (BiMap b a b)) -> Decoder s (BiMap b a b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Int
1 -> Decoder s (BiMap b a b)
forall a b s.
(FromCBOR a, FromCBOR b, Ord a, Ord b) =>
Decoder s (BiMap b a b)
decodeMapAsBimap
      -- Previous encoding of 'BiMap' encoded both the forward and reverse
      -- directions. In this case we skip the reverse encoding. Note that,
      -- further, the reverse encoding was from 'b' to 'a', not the current 'b'
      -- to 'Set a', and hence the dropper reflects that.
      Int
2 -> do
        !BiMap b a b
x <- Decoder s (BiMap b a b)
forall a b s.
(FromCBOR a, FromCBOR b, Ord a, Ord b) =>
Decoder s (BiMap b a b)
decodeMapAsBimap
        Dropper s -> Dropper s -> Dropper s
forall s. Dropper s -> Dropper s -> Dropper s
dropMap (Decoder s b -> Dropper s
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Decoder s b -> Dropper s) -> Decoder s b -> Dropper s
forall a b. (a -> b) -> a -> b
$ forall s. FromCBOR b => Decoder s b
forall a s. FromCBOR a => Decoder s a
fromCBOR @b) (Decoder s a -> Dropper s
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Decoder s a -> Dropper s) -> Decoder s a -> Dropper s
forall a b. (a -> b) -> a -> b
$ forall s. FromCBOR a => Decoder s a
forall a s. FromCBOR a => Decoder s a
fromCBOR @a)
        BiMap b a b -> Decoder s (BiMap b a b)
forall (m :: * -> *) a. Monad m => a -> m a
return BiMap b a b
x
      Int
k -> Word -> Decoder s (BiMap b a b)
forall s a. Word -> Decoder s a
invalidKey (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
k)

-- | Decode a serialised CBOR Map as a Bimap
decodeMapAsBimap ::
  (FromCBOR a, FromCBOR b, Ord a, Ord b) =>
  Decoder s (BiMap b a b)
decodeMapAsBimap :: Decoder s (BiMap b a b)
decodeMapAsBimap = ([(a, b)] -> BiMap b a b) -> Decoder s (BiMap b a b)
forall k v m s.
(Ord k, FromCBOR k, FromCBOR v) =>
([(k, v)] -> m) -> Decoder s m
decodeMapSkel [(a, b)] -> BiMap b a b
forall k v. (Ord k, Ord v) => [(k, v)] -> BiMap v k v
biMapFromAscDistinctList

instance (NoThunks a,NoThunks b) => NoThunks(BiMap v a b) where
  showTypeOf :: Proxy (BiMap v a b) -> [Char]
showTypeOf Proxy (BiMap v a b)
_ = [Char]
"BiMap"
  wNoThunks :: Context -> BiMap v a b -> IO (Maybe ThunkInfo)
wNoThunks Context
ctxt (MkBiMap Map a b
l Map b (Set a)
r) = Context -> (Map a b, Map b (Set a)) -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
wNoThunks Context
ctxt (Map a b
l,Map b (Set a)
r)

instance NFData(BiMap v a b) where
   rnf :: BiMap v a b -> ()
rnf (MkBiMap Map a b
l Map b (Set a)
r) = Map a b -> () -> ()
seq Map a b
l (Map b (Set a) -> () -> ()
seq Map b (Set a)
r ())

-- ============== end Necessary Cardano.Binary instances ===================

instance (Eq k,Eq v) => Eq (BiMap u k v) where
  (MkBiMap Map k v
l Map v (Set k)
_) == :: BiMap u k v -> BiMap u k v -> Bool
== (MkBiMap Map k v
x Map v (Set k)
_) = Map k v
lMap k v -> Map k v -> Bool
forall a. Eq a => a -> a -> Bool
==Map k v
x

instance (Show k, Show v) => Show (BiMap u k v) where
  show :: BiMap u k v -> [Char]
show (MkBiMap Map k v
l Map v (Set k)
_r) = Map k v -> [Char]
forall a. Show a => a -> [Char]
show Map k v
l

addBack :: (Ord v,Ord k) => v -> k -> Map.Map v (Set.Set k) -> Map.Map v (Set.Set k)
addBack :: v -> k -> Map v (Set k) -> Map v (Set k)
addBack v
newv k
k Map v (Set k)
m = (Set k -> Set k -> Set k)
-> v -> Set k -> Map v (Set k) -> Map v (Set k)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Set k -> Set k -> Set k
forall a. Ord a => Set a -> Set a -> Set a
Set.union v
newv (k -> Set k
forall a. a -> Set a
Set.singleton k
k) Map v (Set k)
m

retract :: (Ord v,Ord k) => v -> k -> Map.Map v (Set.Set k) -> Map.Map v (Set.Set k)
retract :: v -> k -> Map v (Set k) -> Map v (Set k)
retract v
oldv k
k Map v (Set k)
m = (Set k -> Set k) -> v -> Map v (Set k) -> Map v (Set k)
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (k -> Set k -> Set k
forall a. Ord a => a -> Set a -> Set a
Set.delete k
k) v
oldv Map v (Set k)
m

insertBackwards:: (Ord k,Ord v) => v -> v -> k -> Map.Map v (Set.Set k) -> Map.Map v (Set.Set k)
insertBackwards :: v -> v -> k -> Map v (Set k) -> Map v (Set k)
insertBackwards v
oldv v
newv k
k Map v (Set k)
m = v -> k -> Map v (Set k) -> Map v (Set k)
forall v k.
(Ord v, Ord k) =>
v -> k -> Map v (Set k) -> Map v (Set k)
addBack v
newv k
k (v -> k -> Map v (Set k) -> Map v (Set k)
forall v k.
(Ord v, Ord k) =>
v -> k -> Map v (Set k) -> Map v (Set k)
retract v
oldv k
k Map v (Set k)
m)

instance Ord v => Basic (BiMap v) where
  addkv :: (k, v) -> BiMap v k v -> (v -> v -> v) -> BiMap v k v
addkv (k
k,v
v) (MkBiMap Map k v
f Map v (Set k)
b) v -> v -> v
comb = Map k v -> Map v (Set k) -> BiMap v k v
forall v b a. (v ~ b) => Map a b -> Map b (Set a) -> BiMap v a b
MkBiMap ((v -> v -> v) -> k -> v -> Map k v -> Map k v
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith ((v -> v -> v) -> v -> v -> v
forall v. (v -> v -> v) -> v -> v -> v
mapflip v -> v -> v
comb) k
k v
v Map k v
f) (v -> v -> k -> Map v (Set k) -> Map v (Set k)
forall k v.
(Ord k, Ord v) =>
v -> v -> k -> Map v (Set k) -> Map v (Set k)
insertBackwards v
oldv v
newv k
k Map v (Set k)
b)
     where (v
oldv,v
newv) = case k -> Map k v -> Maybe v
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k Map k v
f of { Maybe v
Nothing -> (v
v,v
v); Just v
v2 -> (v
v2,v -> v -> v
comb v
v2 v
v)}
  removekey :: k -> BiMap v k v -> BiMap v k v
removekey k
k (m :: BiMap v k v
m@(MkBiMap Map k v
m1 Map v (Set k)
m2)) =  -- equality constraint (a ~ v) from (BiMap a k v) into scope.
     case k -> Map k v -> Maybe v
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k Map k v
m1 of
        Just v
v -> Map k v -> Map v (Set k) -> BiMap v k v
forall v b a. (v ~ b) => Map a b -> Map b (Set a) -> BiMap v a b
MkBiMap (k -> Map k v -> Map k v
forall k v. Ord k => k -> Map k v -> Map k v
Map.delete k
k Map k v
m1) (v -> k -> Map v (Set k) -> Map v (Set k)
forall v k.
(Ord v, Ord k) =>
v -> k -> Map v (Set k) -> Map v (Set k)
retract v
v k
k Map v (Set k)
m2)
        Maybe v
Nothing -> BiMap v k v
m
  domain :: BiMap v k v -> Set k
domain (MkBiMap Map k v
left Map v (Set k)
_right) = Map k v -> Set k
forall k a. Map k a -> Set k
Map.keysSet Map k v
left
  range :: BiMap v k v -> Set v
range (MkBiMap Map k v
_left Map v (Set k)
right) = Map v (Set k) -> Set v
forall k a. Map k a -> Set k
Map.keysSet Map v (Set k)
right
  emptyc :: BiMap v k v
emptyc = [Char] -> BiMap v k v
forall a. HasCallStack => [Char] -> a
error ([Char]
"emptyc cannot be defined for BiMap, use the variable: biMapEmpty :: BiMap v k v")

biMapEmpty :: BiMap v k v
biMapEmpty :: BiMap v k v
biMapEmpty = Map k v -> Map v (Set k) -> BiMap v k v
forall v b a. (v ~ b) => Map a b -> Map b (Set a) -> BiMap v a b
MkBiMap Map k v
forall k a. Map k a
Map.empty Map v (Set k)
forall k a. Map k a
Map.empty

-- Make a BiMap from a list of pairs.
-- The combine function comb=(\ earlier later -> later) will let elements
-- later in the list override ones earlier in the list, and comb =
-- (\ earlier later -> earlier) will keep the vaue that appears first in the list

biMapFromList:: (Ord k,Ord v) => (v -> v -> v) -> [(k,v)] -> BiMap v k v
biMapFromList :: (v -> v -> v) -> [(k, v)] -> BiMap v k v
biMapFromList v -> v -> v
comb [(k, v)]
xs = ((k, v) -> BiMap v k v -> BiMap v k v)
-> BiMap v k v -> [(k, v)] -> BiMap v k v
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (k, v) -> BiMap v k v -> BiMap v k v
addEntry BiMap v k v
forall v k. BiMap v k v
biMapEmpty [(k, v)]
xs
  where addEntry :: (k, v) -> BiMap v k v -> BiMap v k v
addEntry (k
k,v
v) (MkBiMap Map k v
forward Map v (Set k)
backward) =
          case k -> Map k v -> Maybe v
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k Map k v
forward of
            Maybe v
Nothing -> Map k v -> Map v (Set k) -> BiMap v k v
forall v b a. (v ~ b) => Map a b -> Map b (Set a) -> BiMap v a b
MkBiMap ((k, v) -> Map k v -> (v -> v -> v) -> Map 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) Map k v
forward v -> v -> v
comb) (v -> k -> Map v (Set k) -> Map v (Set k)
forall v k.
(Ord v, Ord k) =>
v -> k -> Map v (Set k) -> Map v (Set k)
addBack v
v k
k Map v (Set k)
backward)
            Just v
oldv -> Map k v -> Map v (Set k) -> BiMap v k v
forall v b a. (v ~ b) => Map a b -> Map b (Set a) -> BiMap v a b
MkBiMap ((k, v) -> Map k v -> (v -> v -> v) -> Map 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) Map k v
forward v -> v -> v
comb) (v -> v -> k -> Map v (Set k) -> Map v (Set k)
forall k v.
(Ord k, Ord v) =>
v -> v -> k -> Map v (Set k) -> Map v (Set k)
insertBackwards v
oldv v
newv k
k Map v (Set k)
backward)
               where newv :: v
newv = v -> v -> v
comb v
oldv v
v

biMapFromAscDistinctList ::
  (Ord k, Ord v) => [(k, v)] -> BiMap v k v
biMapFromAscDistinctList :: [(k, v)] -> BiMap v k v
biMapFromAscDistinctList [(k, v)]
xs = Map k v -> Map v (Set k) -> BiMap v k v
forall v b a. (v ~ b) => Map a b -> Map b (Set a) -> BiMap v a b
MkBiMap Map k v
bmForward Map v (Set k)
bmBackward
  where
    bmForward :: Map k v
bmForward = [(k, v)] -> Map k v
forall k a. [(k, a)] -> Map k a
Map.fromDistinctAscList [(k, v)]
xs
    bmBackward :: Map v (Set k)
bmBackward = ((k, v) -> Map v (Set k) -> Map v (Set k))
-> Map v (Set k) -> [(k, v)] -> Map v (Set k)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((k -> v -> Map v (Set k) -> Map v (Set k))
-> (k, v) -> Map v (Set k) -> Map v (Set k)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((k -> v -> Map v (Set k) -> Map v (Set k))
 -> (k, v) -> Map v (Set k) -> Map v (Set k))
-> (k -> v -> Map v (Set k) -> Map v (Set k))
-> (k, v)
-> Map v (Set k)
-> Map v (Set k)
forall a b. (a -> b) -> a -> b
$ (v -> k -> Map v (Set k) -> Map v (Set k))
-> k -> v -> Map v (Set k) -> Map v (Set k)
forall a b c. (a -> b -> c) -> b -> a -> c
flip v -> k -> Map v (Set k) -> Map v (Set k)
forall v k.
(Ord v, Ord k) =>
v -> k -> Map v (Set k) -> Map v (Set k)
addBack) Map v (Set k)
forall k a. Map k a
Map.empty [(k, v)]
xs

-- This synonym makes (BiMap v k v) appear as an ordinary Binary type contructor: (Bimap k v)
type Bimap k v = BiMap v k v

-- This operation is very fast (Log n) on BiMap, but extremely slow on other collections.
removeval:: (Ord k, Ord v) => v -> BiMap v k v -> BiMap v k v
removeval :: v -> BiMap v k v -> BiMap v k v
removeval v
v (m :: BiMap v k v
m@(MkBiMap Map k v
m1 Map v (Set k)
m2)) =
     case v -> Map v (Set k) -> Maybe (Set k)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup v
v Map v (Set k)
m2 of
        Just Set k
kset -> Map k v -> Map v (Set k) -> BiMap v k v
forall v b a. (v ~ b) => Map a b -> Map b (Set a) -> BiMap v a b
MkBiMap ((k -> Map k v -> Map k v) -> Map k v -> Set k -> Map k v
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\k
k Map k v
set -> k -> Map k v -> Map k v
forall k v. Ord k => k -> Map k v -> Map k v
Map.delete k
k Map k v
set) Map k v
m1 Set k
kset) (v -> Map v (Set k) -> Map v (Set k)
forall k v. Ord k => k -> Map k v -> Map k v
Map.delete v
v Map v (Set k)
m2)
        Maybe (Set k)
Nothing -> BiMap v k v
m

-- ================= Basic Set =====================

data Sett k v where Sett :: (Set.Set k) -> Sett k ()

instance Basic Sett where
  addpair :: k -> v -> Sett k v -> Sett k v
addpair k
key v
_unit (Sett Set k
m) = Set k -> Sett k ()
forall k. Set k -> Sett k ()
Sett(k -> Set k -> Set k
forall a. Ord a => a -> Set a -> Set a
Set.insert k
key Set k
m)
  addkv :: (k, v) -> Sett k v -> (v -> v -> v) -> Sett k v
addkv (k
k,v
_unit) (Sett Set k
m) v -> v -> v
_comb = Set k -> Sett k ()
forall k. Set k -> Sett k ()
Sett(k -> Set k -> Set k
forall a. Ord a => a -> Set a -> Set a
Set.insert k
k Set k
m)  -- We can ignore comb since there is only one function at type: () -> () -> ()
  removekey :: k -> Sett k v -> Sett k v
removekey k
k (Sett Set k
m) = Set k -> Sett k ()
forall k. Set k -> Sett k ()
Sett(k -> Set k -> Set k
forall a. Ord a => a -> Set a -> Set a
Set.delete k
k Set k
m)
  domain :: Sett k v -> Set k
domain (Sett Set k
xs) = Set k
xs
  range :: Sett k v -> Set v
range (Sett Set k
_xs) = () -> Set ()
forall a. a -> Set a
Set.singleton ()
  emptyc :: Sett k v
emptyc = [Char] -> Sett k v
forall a. HasCallStack => [Char] -> a
error ([Char]
"Sett Set.empty has type (Sett k ()) and it needs type (Sett k v)")

instance Show key => Show (Sett key ()) where
   show :: Sett key () -> [Char]
show (Sett Set key
ss) = Set key -> [Char]
forall a. Show a => a -> [Char]
show Set key
ss

deriving instance Eq k => Eq (Sett k ())

-- ============================================================================
-- Every iterable type type forms an isomorphism with some Base type. For most
-- Base types the isomorphism is the identity in both directions, but for some,
-- like List and Sett, the embeddings are not the trivial identities because the
-- concrete types are not binary type constructors. The Embed class also allows
-- us to add 'newtypes' which encode some Base type to the system.
-- ============================================================================

class Embed concrete base | concrete -> base where
  toBase :: concrete -> base
  fromBase :: base -> concrete

instance Ord k => Embed [(k,v)] (List k v) where
   toBase :: [(k, v)] -> List k v
toBase [(k, v)]
xs = [(k, v)] -> List k v
forall k v. Ord k => [(k, v)] -> List k v
UnSafeList(((k, v) -> (k, v) -> Ordering) -> [(k, v)] -> [(k, v)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\ (k, v)
x (k, v)
y -> k -> k -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ((k, v) -> k
forall a b. (a, b) -> a
fst (k, v)
x) ((k, v) -> k
forall a b. (a, b) -> a
fst (k, v)
y)) [(k, v)]
xs)
   fromBase :: List k v -> [(k, v)]
fromBase (UnSafeList [(k, v)]
xs) = [(k, v)]
xs

instance Embed (Set.Set k) (Sett k ()) where
   toBase :: Set k -> Sett k ()
toBase Set k
xs = Set k -> Sett k ()
forall k. Set k -> Sett k ()
Sett Set k
xs
   fromBase :: Sett k () -> Set k
fromBase (Sett Set k
xs) = Set k
xs

instance Embed (Map.Map k v) (Map.Map k v) where
   toBase :: Map k v -> Map k v
toBase Map k v
xs = Map k v
xs
   fromBase :: Map k v -> Map k v
fromBase Map k v
xs = Map k v
xs

instance Embed (BiMap v k v) (BiMap v k v) where
   toBase :: BiMap v k v -> BiMap v k v
toBase BiMap v k v
xs = BiMap v k v
xs
   fromBase :: BiMap v k v -> BiMap v k v
fromBase BiMap v k v
xs = BiMap v k v
xs

instance Embed (Single k v) (Single k v) where
   toBase :: Single k v -> Single k v
toBase Single k v
xs = Single k v
xs
   fromBase :: Single k v -> Single k v
fromBase Single k v
xs = Single k v
xs

-- Necessary when asking Boolean queries like: (⊆),(∈),(∉)
instance Embed Bool Bool where
   toBase :: Bool -> Bool
toBase Bool
xs = Bool
xs
   fromBase :: Bool -> Bool
fromBase Bool
xs = Bool
xs

-- ================= The Iter class =================================================
-- The Set algebra include types that encode finite maps of some type. They
-- have a finite domain, and for each domain element they pair a single range
-- element. We are interested in those finite maps that can iterate their
-- pairs in ascending domain order. The operations are: `nxt` and `lub` .
-- lub can skip over many items in sub-linear time, it can make things really fast.
-- Many finite maps can support a support lub operation in sub-linear time. Some examples:
-- Balanced binary trees, Arrays (using binary search), Tries, etc. There are basic and compound
-- Iter instances. Compound types include components with types that have Iter instances.
-- ===================================================================================

class Iter f where
  nxt:: f a b -> Collect (a,b,f a b)
  lub :: Ord k => k -> f k b -> Collect (k,b,f k b)

  -- The next few methods can all be defined via nxt and lub, but for base types there often exist
  -- much more efficent means, so the default definitions should be overwritten for such basic types.
  -- For compound types with Guards, these are often the only way to define them.

  hasNxt :: f a b -> Maybe(a,b,f a b)
  hasNxt f a b
f = Collect (a, b, f a b) -> Maybe (a, b, f a b)
forall t. Collect t -> Maybe t
hasElem (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
f)
  hasLub :: Ord k => k -> f k b -> Maybe(k,b,f k b)
  hasLub k
a f k b
f = Collect (k, b, f k b) -> Maybe (k, b, f k b)
forall t. Collect t -> Maybe t
hasElem (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
a f k b
f)
  haskey:: Ord key => key -> f key b -> Bool
  haskey key
k f key b
x = case key -> f key b -> Maybe (key, b, f key b)
forall (f :: * -> * -> *) k b.
(Iter f, Ord k) =>
k -> f k b -> Maybe (k, b, f k b)
hasLub key
k f key b
x of { Maybe (key, b, f key b)
Nothing -> Bool
False; Just (key
key,b
_,f key b
_) -> key
kkey -> key -> Bool
forall a. Eq a => a -> a -> Bool
==key
key}
  isnull:: f k v -> Bool
  isnull f k v
f = Collect (k, v, f k v) -> Bool
forall t. Collect t -> Bool
isempty(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
f)
  lookup:: Ord key => key -> f key rng -> Maybe rng
  lookup key
k f key rng
x = case key -> f key rng -> Maybe (key, rng, f key rng)
forall (f :: * -> * -> *) k b.
(Iter f, Ord k) =>
k -> f k b -> Maybe (k, b, f k b)
hasLub key
k f key rng
x of { Maybe (key, rng, f key rng)
Nothing -> Maybe rng
forall a. Maybe a
Nothing; Just (key
key,rng
v,f key rng
_) -> if key
kkey -> key -> Bool
forall a. Eq a => a -> a -> Bool
==key
key then rng -> Maybe rng
forall a. a -> Maybe a
Just rng
v else Maybe rng
forall a. Maybe a
Nothing}
  element :: (Ord k) => k -> f k v -> Collect ()
  element k
k f k v
f = Bool -> Collect ()
when (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)

-- ============== Iter List ==============

data List k v where UnSafeList :: Ord k => [(k,v)]  -> List k v
unList :: List k v -> [(k, v)]
unList :: List k v -> [(k, v)]
unList (UnSafeList [(k, v)]
xs) = [(k, v)]
xs
deriving instance (Eq k,Eq v) => Eq (List k v)

instance Iter List where                      -- List is the only basic instance with non-linear nxt and lub. It also depends on
   nxt :: List a b -> Collect (a, b, List a b)
nxt (UnSafeList []) = Collect (a, b, List a b)
forall t. Collect t
none                 -- key-value pairs being stored in ascending order. For small Lists (10 or so elements) this is OK.
   nxt (UnSafeList ((a
k,b
v):[(a, b)]
xs)) = (a, b, List a b) -> Collect (a, b, List a b)
forall t. t -> Collect t
one(a
k,b
v,[(a, b)] -> List a b
forall k v. Ord k => [(k, v)] -> List k v
UnSafeList [(a, b)]
xs)
   lub :: k -> List k b -> Collect (k, b, List k b)
lub k
k (UnSafeList [(k, b)]
xs) = case ((k, b) -> Bool) -> [(k, b)] -> [(k, b)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (\ (k
key,b
_v) -> k
key k -> k -> Bool
forall a. Ord a => a -> a -> Bool
< k
k) [(k, b)]
xs of
                       [] -> Collect (k, b, List k b)
forall t. Collect t
none
                       ((k
key,b
v):[(k, b)]
ys) -> (k, b, List k b) -> Collect (k, b, List k b)
forall t. t -> Collect t
one (k
key,b
v,[(k, b)] -> List k b
forall k v. Ord k => [(k, v)] -> List k v
UnSafeList [(k, b)]
ys)
   isnull :: List k v -> Bool
isnull (UnSafeList [(k, v)]
xs) = [(k, v)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(k, v)]
xs
   lookup :: key -> List key rng -> Maybe rng
lookup key
k (UnSafeList [(key, rng)]
xs) = key -> [(key, rng)] -> Maybe rng
forall a b. Eq a => a -> [(a, b)] -> Maybe b
List.lookup key
k [(key, rng)]
xs
   hasNxt :: List a b -> Maybe (a, b, List a b)
hasNxt (UnSafeList []) = Maybe (a, b, List a b)
forall a. Maybe a
Nothing
   hasNxt (UnSafeList (((a
k,b
v):[(a, b)]
ps))) = (a, b, List a b) -> Maybe (a, b, List a b)
forall a. a -> Maybe a
Just(a
k,b
v,[(a, b)] -> List a b
forall k v. Ord k => [(k, v)] -> List k v
UnSafeList [(a, b)]
ps)

instance (Show k,Show v) => Show (List k v) where
   show :: List k v -> [Char]
show (UnSafeList [(k, v)]
xs) = [(k, v)] -> [Char]
forall a. Show a => a -> [Char]
show [(k, v)]
xs

-- =============== Iter Single ==================

instance Iter Single where
  nxt :: Single a b -> Collect (a, b, Single a b)
nxt (Single a
k b
v) = (forall ans. ans -> ((a, b, Single a b) -> ans -> ans) -> ans)
-> Collect (a, b, Single a b)
forall tuple.
(forall ans. ans -> (tuple -> ans -> ans) -> ans) -> Collect tuple
Collect(\ ans
ans (a, b, Single a b) -> ans -> ans
f -> (a, b, Single a b) -> ans -> ans
f (a
k,b
v,Single a b
forall k v. Single k v
Fail) ans
ans)
  nxt (SetSingle a
k) = (forall ans. ans -> ((a, b, Single a b) -> ans -> ans) -> ans)
-> Collect (a, b, Single a b)
forall tuple.
(forall ans. ans -> (tuple -> ans -> ans) -> ans) -> Collect tuple
Collect(\ ans
ans (a, b, Single a b) -> ans -> ans
f ->  (a, b, Single a b) -> ans -> ans
f (a
k,(),Single a ()
forall k v. Single k v
Fail) ans
ans)
  nxt Single a b
Fail = (forall ans. ans -> ((a, b, Single a b) -> ans -> ans) -> ans)
-> Collect (a, b, Single a b)
forall tuple.
(forall ans. ans -> (tuple -> ans -> ans) -> ans) -> Collect tuple
Collect(\ ans
ans (a, b, Single a b) -> ans -> ans
_f -> ans
ans)
  lub :: k -> Single k b -> Collect (k, b, Single k b)
lub k
key (Single k
k b
v) = (forall ans. ans -> ((k, b, Single k b) -> ans -> ans) -> ans)
-> Collect (k, b, Single k b)
forall tuple.
(forall ans. ans -> (tuple -> ans -> ans) -> ans) -> Collect tuple
Collect(\ ans
ans (k, b, Single k b) -> ans -> ans
f -> if k
kk -> k -> Bool
forall a. Ord a => a -> a -> Bool
<=k
key then (k, b, Single k b) -> ans -> ans
f (k
k,b
v,Single k b
forall k v. Single k v
Fail) ans
ans else ans
ans)
  lub k
key (SetSingle k
k) = (forall ans. ans -> ((k, b, Single k b) -> ans -> ans) -> ans)
-> Collect (k, b, Single k b)
forall tuple.
(forall ans. ans -> (tuple -> ans -> ans) -> ans) -> Collect tuple
Collect(\ ans
ans (k, b, Single k b) -> ans -> ans
f -> if k
kk -> k -> Bool
forall a. Ord a => a -> a -> Bool
<=k
key then (k, b, Single k b) -> ans -> ans
f(k
k,(),Single k ()
forall k v. Single k v
Fail) ans
ans else ans
ans)
  lub k
_key Single k b
Fail = (forall ans. ans -> ((k, b, Single k b) -> ans -> ans) -> ans)
-> Collect (k, b, Single k b)
forall tuple.
(forall ans. ans -> (tuple -> ans -> ans) -> ans) -> Collect tuple
Collect(\ ans
ans (k, b, Single k b) -> ans -> ans
_f -> ans
ans)
  haskey :: key -> Single key b -> Bool
haskey key
k (SetSingle key
a) = key
kkey -> key -> Bool
forall a. Eq a => a -> a -> Bool
==key
a
  haskey key
k (Single key
a b
_b) = key
kkey -> key -> Bool
forall a. Eq a => a -> a -> Bool
==key
a
  haskey key
_k Single key b
Fail = Bool
False
  isnull :: Single k v -> Bool
isnull Single k v
Fail = Bool
True
  isnull Single k v
_ = Bool
False
  lookup :: key -> Single key rng -> Maybe rng
lookup key
k (SetSingle key
a) = if key
kkey -> key -> Bool
forall a. Eq a => a -> a -> Bool
==key
a then () -> Maybe ()
forall a. a -> Maybe a
Just() else Maybe rng
forall a. Maybe a
Nothing
  lookup key
k (Single key
a rng
b) = if key
kkey -> key -> Bool
forall a. Eq a => a -> a -> Bool
==key
a then rng -> Maybe rng
forall a. a -> Maybe a
Just rng
b else Maybe rng
forall a. Maybe a
Nothing
  lookup key
_k Single key rng
Fail = Maybe rng
forall a. Maybe a
Nothing

instance (Show k,Show v) => Show (Single k v) where
  show :: Single k v -> [Char]
show (Single k
k v
v) = [Char]
"(Single "[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++k -> [Char]
forall a. Show a => a -> [Char]
show k
k [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" "[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++v -> [Char]
forall a. Show a => a -> [Char]
show v
v[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
")"
  show (SetSingle k
k) = [Char]
"(SetSingle "[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++k -> [Char]
forall a. Show a => a -> [Char]
show k
k[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
")"
  show Single k v
Fail = [Char]
"Fail"

-- ============= Iter Sett ===============

instance Iter Sett where
  nxt :: Sett a b -> Collect (a, b, Sett a b)
nxt (Sett Set a
m) = (forall ans. ans -> ((a, b, Sett a b) -> ans -> ans) -> ans)
-> Collect (a, b, Sett a b)
forall tuple.
(forall ans. ans -> (tuple -> ans -> ans) -> ans) -> Collect tuple
Collect (\ ans
ans (a, b, Sett a b) -> ans -> ans
f -> if Set a -> Bool
forall a. Set a -> Bool
Set.null Set a
m then ans
ans else let (a
k,Set a
nextm) = Set a -> (a, Set a)
forall a. Set a -> (a, Set a)
Set.deleteFindMin Set a
m in (a, b, Sett a b) -> ans -> ans
f (a
k,(),Set a -> Sett a ()
forall k. Set k -> Sett k ()
Sett Set a
nextm) ans
ans)
  lub :: k -> Sett k b -> Collect (k, b, Sett k b)
lub k
key (Sett Set k
m) =
      (forall ans. ans -> ((k, b, Sett k b) -> ans -> ans) -> ans)
-> Collect (k, b, Sett k b)
forall tuple.
(forall ans. ans -> (tuple -> ans -> ans) -> ans) -> Collect tuple
Collect (\ ans
ans (k, b, Sett k b) -> ans -> ans
f -> if Set k -> Bool
forall a. Set a -> Bool
Set.null Set k
m
                             then ans
ans
                             else case k -> Set k -> (Set k, Bool, Set k)
forall a. Ord a => a -> Set a -> (Set a, Bool, Set a)
Set.splitMember k
key Set k
m of   -- NOTE in Log time, we skip over all those tuples in _left
                                     (Set k
_left,Bool
True,Set k
right) -> (k, b, Sett k b) -> ans -> ans
f (k
key,(),Set k -> Sett k ()
forall k. Set k -> Sett k ()
Sett Set k
right) ans
ans
                                     (Set k
_left,Bool
False,Set k
right) -> if Set k -> Bool
forall a. Set a -> Bool
Set.null Set k
right
                                                        then ans
ans
                                                        else let (k
k,Set k
nextm) = Set k -> (k, Set k)
forall a. Set a -> (a, Set a)
Set.deleteFindMin Set k
right in (k, b, Sett k b) -> ans -> ans
f (k
k,(),Set k -> Sett k ()
forall k. Set k -> Sett k ()
Sett  Set k
nextm) ans
ans)
  haskey :: key -> Sett key b -> Bool
haskey key
key (Sett Set key
m) = key -> Set key -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member key
key Set key
m
  isnull :: Sett k v -> Bool
isnull (Sett Set k
x) = Set k -> Bool
forall a. Set a -> Bool
Set.null Set k
x
  lookup :: key -> Sett key rng -> Maybe rng
lookup key
k (Sett Set key
m) = if key -> Set key -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member key
k Set key
m then () -> Maybe ()
forall a. a -> Maybe a
Just() else Maybe rng
forall a. Maybe a
Nothing


-- ================== Iter Map ===============

instance Iter Map.Map where
  nxt :: Map a b -> Collect (a, b, Map a b)
nxt Map a b
m = (forall ans. ans -> ((a, b, Map a b) -> ans -> ans) -> ans)
-> Collect (a, b, Map a b)
forall tuple.
(forall ans. ans -> (tuple -> ans -> ans) -> ans) -> Collect tuple
Collect (\ ans
ans (a, b, Map a b) -> ans -> ans
f ->
     case Map a b -> Maybe ((a, b), Map a b)
forall k a. Map k a -> Maybe ((k, a), Map k a)
Map.minViewWithKey Map a b
m of
        Maybe ((a, b), Map a b)
Nothing -> ans
ans
        Just((a
k,b
v),Map a b
nextm) -> (a, b, Map a b) -> ans -> ans
f (a
k,b
v,Map a b
nextm) ans
ans)
  lub :: k -> Map k b -> Collect (k, b, Map k b)
lub k
key Map k b
m = (forall ans. ans -> ((k, b, Map k b) -> ans -> ans) -> ans)
-> Collect (k, b, Map k b)
forall tuple.
(forall ans. ans -> (tuple -> ans -> ans) -> ans) -> Collect tuple
Collect (\ ans
ans (k, b, Map k b) -> ans -> ans
f ->
     case k -> Map k b -> (Map k b, Maybe b, Map k b)
forall k a. Ord k => k -> Map k a -> (Map k a, Maybe a, Map k a)
Map.splitLookup k
key Map k b
m of                  -- NOTE in Log time, we skip over all those tuples in _left
       (Map k b
_left,Just b
v,Map k b
right) -> (k, b, Map k b) -> ans -> ans
f (k
key,b
v,Map k b
right) ans
ans
       (Map k b
_left,Maybe b
Nothing,Map k b
Tip) -> ans
ans
       (Map k b
_left,Maybe b
Nothing,Map k b
right) -> (k, b, Map k b) -> ans -> ans
f (k
k,b
v,Map k b
m3) ans
ans
           where ((k
k,b
v),Map k b
m3) = Map k b -> ((k, b), Map k b)
forall k a. Map k a -> ((k, a), Map k a)
Map.deleteFindMin Map k b
right)
  haskey :: key -> Map key b -> Bool
haskey key
x Map key b
m = case key -> Map key b -> Maybe b
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup key
x Map key b
m of Just b
_ -> Bool
True; Maybe b
Nothing -> Bool
False
  isnull :: Map k v -> Bool
isnull = Map k v -> Bool
forall k v. Map k v -> Bool
Map.null
  lookup :: key -> Map key rng -> Maybe rng
lookup = key -> Map key rng -> Maybe rng
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup


-- ===========================================================
-- Some times we need to write our own version of functions
-- over  Map.Map that do not appear in the library
-- For example
-- 1) version of Map.withoutKeys where both parts are Map.Map
-- 2) Comparing that two maps have exactly the same set of keys
-- 3) The intersection of two maps guarded by a predicate.
--    ((dom stkcred) ◁ deleg) ▷ (dom stpool))   ==>
--    intersectDomP (\ k v -> Map.member v stpool) stkcred deleg
-- ============================================================

noKeys :: Ord k => Map k a -> Map k b -> Map k a
noKeys :: Map k a -> Map k b -> Map k a
noKeys Map k a
Tip Map k b
_ = Map k a
forall k a. Map k a
Tip
noKeys Map k a
m Map k b
Tip = Map k a
m
noKeys Map k a
m (Bin Int
_ k
k b
_ Map k b
ls Map k b
rs) = case k -> Map k a -> (Map k a, Map k a)
forall k a. Ord k => k -> Map k a -> (Map k a, Map k a)
Map.split k
k Map k a
m of
  (Map k a
lm, Map k a
rm) -> Map k a -> Map k a -> Map k a
forall k a. Map k a -> Map k a -> Map k a
link2 Map k a
lm' Map k a
rm'     -- We know `k` is not in either `lm` or `rm`
     where !lm' :: Map k a
lm' = Map k a -> Map k b -> Map k a
forall k a b. Ord k => Map k a -> Map k b -> Map k a
noKeys Map k a
lm Map k b
ls
           !rm' :: Map k a
rm' = Map k a -> Map k b -> Map k a
forall k a b. Ord k => Map k a -> Map k b -> Map k a
noKeys Map k a
rm Map k b
rs
{-# INLINABLE noKeys #-}


-- This version benchmarks better than the following three versions, by almost a factor of 4, at Trees with 100 to 100,000 pairs
-- keysEqual2 x y = Map.foldrWithKey' (\ k v ans -> k:ans) [] x == Map.foldrWithKey' (\ k v ans -> k:ans) [] y
-- keysEqual3 x y = Map.keysSet x == Map.keysSet y
-- keysEqual4 x y = Map.keys x == Map.keys y
-- This is a type specific version of sameDomain

keysEqual:: Ord k => Map k v1 -> Map k v2 -> Bool
keysEqual :: Map k v1 -> Map k v2 -> Bool
keysEqual Map k v1
Tip Map k v2
Tip = Bool
True
keysEqual Map k v1
Tip (Bin Int
_ k
_ v2
_ Map k v2
_ Map k v2
_) = Bool
False
keysEqual (Bin Int
_ k
_ v1
_ Map k v1
_ Map k v1
_) Map k v2
Tip = Bool
False
keysEqual Map k v1
m (Bin Int
_ k
k v2
_ Map k v2
ls Map k v2
rs) =
   case k -> Map k v1 -> (Map k v1, Bool, Map k v1)
forall k a. Ord k => k -> Map k a -> (Map k a, Bool, Map k a)
splitMember k
k Map k v1
m of
      (Map k v1
lm,Bool
True,Map k v1
rm) -> Map k v2 -> Map k v1 -> Bool
forall k v1 v2. Ord k => Map k v1 -> Map k v2 -> Bool
keysEqual Map k v2
ls Map k v1
lm Bool -> Bool -> Bool
&& Map k v2 -> Map k v1 -> Bool
forall k v1 v2. Ord k => Map k v1 -> Map k v2 -> Bool
keysEqual Map k v2
rs Map k v1
rm
      (Map k v1, Bool, Map k v1)
_ -> Bool
False

-- 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

-- | A variant of 'splitLookup' that indicates only whether the
-- key was present, rather than producing its value. This is used to
-- implement 'keysEqual' to avoid allocating unnecessary 'Just'
-- constructors.
splitMember :: Ord k => k -> Map k a -> (Map k a,Bool,Map k a)
splitMember :: k -> Map k a -> (Map k a, Bool, Map k a)
splitMember k
k0 Map k a
m = case k -> Map k a -> StrictTriple (Map k a) Bool (Map k a)
forall k a.
Ord k =>
k -> Map k a -> StrictTriple (Map k a) Bool (Map k a)
go k
k0 Map k a
m of
     StrictTriple Map k a
l Bool
mv Map k a
r -> (Map k a
l, Bool
mv, Map k a
r)
  where
    go :: Ord k => k -> Map k a -> StrictTriple (Map k a) Bool (Map k a)
    go :: k -> Map k a -> StrictTriple (Map k a) Bool (Map k a)
go !k
k Map k a
t =
      case Map k a
t of
        Map k a
Tip            -> Map k a -> Bool -> Map k a -> StrictTriple (Map k a) Bool (Map k a)
forall a b c. a -> b -> c -> StrictTriple a b c
StrictTriple Map k a
forall k a. Map k a
Tip Bool
False Map k a
forall k a. Map k a
Tip
        Bin Int
_ k
kx a
x Map k a
l Map k a
r -> case k -> k -> Ordering
forall a. Ord a => a -> a -> Ordering
compare k
k k
kx of
          Ordering
LT -> let StrictTriple Map k a
lt Bool
z Map k a
gt = k -> Map k a -> StrictTriple (Map k a) Bool (Map k a)
forall k a.
Ord k =>
k -> Map k a -> StrictTriple (Map k a) Bool (Map k a)
go k
k Map k a
l
                    !gt' :: Map k a
gt' = k -> a -> Map k a -> Map k a -> Map k a
forall k a. k -> a -> Map k a -> Map k a -> Map k a
link k
kx a
x Map k a
gt Map k a
r
                in Map k a -> Bool -> Map k a -> StrictTriple (Map k a) Bool (Map k a)
forall a b c. a -> b -> c -> StrictTriple a b c
StrictTriple Map k a
lt Bool
z Map k a
gt'
          Ordering
GT -> let StrictTriple Map k a
lt Bool
z Map k a
gt = k -> Map k a -> StrictTriple (Map k a) Bool (Map k a)
forall k a.
Ord k =>
k -> Map k a -> StrictTriple (Map k a) Bool (Map k a)
go k
k Map k a
r
                    !lt' :: Map k a
lt' = k -> a -> Map k a -> Map k a -> Map k a
forall k a. k -> a -> Map k a -> Map k a -> Map k a
link k
kx a
x Map k a
l Map k a
lt
                in Map k a -> Bool -> Map k a -> StrictTriple (Map k a) Bool (Map k a)
forall a b c. a -> b -> c -> StrictTriple a b c
StrictTriple Map k a
lt' Bool
z Map k a
gt
          Ordering
EQ -> Map k a -> Bool -> Map k a -> StrictTriple (Map k a) Bool (Map k a)
forall a b c. a -> b -> c -> StrictTriple a b c
StrictTriple Map k a
l Bool
True Map k a
r

{-# INLINABLE splitMember #-}

data StrictTriple a b c = StrictTriple !a !b !c

-- | intersetDomP p m1 m2 == Keep the key and value from m2, iff (the key is in the dom of m1) && ((p key value) is true)
intersectDomP:: Ord k => (k -> v2 -> Bool) -> Map k v1 -> Map k v2 -> Map k v2
intersectDomP :: (k -> v2 -> Bool) -> Map k v1 -> Map k v2 -> Map k v2
intersectDomP k -> v2 -> Bool
_ Map k v1
Tip Map k v2
_ = Map k v2
forall k a. Map k a
Tip
intersectDomP k -> v2 -> Bool
_  Map k v1
_ Map k v2
Tip = Map k v2
forall k a. Map k a
Tip
intersectDomP k -> v2 -> Bool
p Map k v1
t1 (Bin Int
_ k
k v2
v Map k v2
l2 Map k v2
r2) =
   if Bool
mb Bool -> Bool -> Bool
&& (k -> v2 -> Bool
p k
k v2
v)
      then k -> v2 -> Map k v2 -> Map k v2 -> Map k v2
forall k a. k -> a -> Map k a -> Map k a -> Map k a
link k
k v2
v Map k v2
l1l2 Map k v2
r1r2
      else Map k v2 -> Map k v2 -> Map k v2
forall k a. Map k a -> Map k a -> Map k a
link2 Map k v2
l1l2 Map k v2
r1r2
  where
    !(Map k v1
l1, Bool
mb, Map k v1
r1) = k -> Map k v1 -> (Map k v1, Bool, Map k v1)
forall k a. Ord k => k -> Map k a -> (Map k a, Bool, Map k a)
splitMember k
k Map k v1
t1
    !l1l2 :: Map k v2
l1l2 = (k -> v2 -> Bool) -> Map k v1 -> Map k v2 -> Map k v2
forall k v2 v1.
Ord k =>
(k -> v2 -> Bool) -> Map k v1 -> Map k v2 -> Map k v2
intersectDomP k -> v2 -> Bool
p Map k v1
l1 Map k v2
l2
    !r1r2 :: Map k v2
r1r2 = (k -> v2 -> Bool) -> Map k v1 -> Map k v2 -> Map k v2
forall k v2 v1.
Ord k =>
(k -> v2 -> Bool) -> Map k v1 -> Map k v2 -> Map k v2
intersectDomP k -> v2 -> Bool
p Map k v1
r1 Map k v2
r2
{-# INLINABLE intersectDomP #-}




-- |- Similar to intersectDomP, except the Map returned has the same key as the first input map, rather than the second input map.
intersectDomPLeft:: Ord k => (k -> v2 -> Bool) -> Map k v1 -> Map k v2 -> Map k v1
intersectDomPLeft :: (k -> v2 -> Bool) -> Map k v1 -> Map k v2 -> Map k v1
intersectDomPLeft k -> v2 -> Bool
_ Map k v1
Tip Map k v2
_ = Map k v1
forall k a. Map k a
Tip
intersectDomPLeft k -> v2 -> Bool
_  Map k v1
_ Map k v2
Tip = Map k v1
forall k a. Map k a
Tip
intersectDomPLeft k -> v2 -> Bool
p (Bin Int
_ k
k v1
v1 Map k v1
l1 Map k v1
r1) Map k v2
t2 =
   case Maybe v2
mb of
      Just v2
v2 | k -> v2 -> Bool
p k
k v2
v2 -> k -> v1 -> Map k v1 -> Map k v1 -> Map k v1
forall k a. k -> a -> Map k a -> Map k a -> Map k a
link k
k v1
v1 Map k v1
l1l2 Map k v1
r1r2
      Maybe v2
_other -> Map k v1 -> Map k v1 -> Map k v1
forall k a. Map k a -> Map k a -> Map k a
link2 Map k v1
l1l2 Map k v1
r1r2
  where
    !(Map k v2
l2, Maybe v2
mb, Map k v2
r2) = k -> Map k v2 -> (Map k v2, Maybe v2, Map k v2)
forall k a. Ord k => k -> Map k a -> (Map k a, Maybe a, Map k a)
Map.splitLookup k
k Map k v2
t2
    !l1l2 :: Map k v1
l1l2 = (k -> v2 -> Bool) -> Map k v1 -> Map k v2 -> Map k v1
forall k v2 v1.
Ord k =>
(k -> v2 -> Bool) -> Map k v1 -> Map k v2 -> Map k v1
intersectDomPLeft k -> v2 -> Bool
p Map k v1
l1 Map k v2
l2
    !r1r2 :: Map k v1
r1r2 = (k -> v2 -> Bool) -> Map k v1 -> Map k v2 -> Map k v1
forall k v2 v1.
Ord k =>
(k -> v2 -> Bool) -> Map k v1 -> Map k v2 -> Map k v1
intersectDomPLeft k -> v2 -> Bool
p Map k v1
r1 Map k v2
r2
{-# INLINABLE intersectDomPLeft #-}

-- |- fold over the intersection of a Map and a Set
intersectMapSetFold:: Ord k => (k -> v -> ans -> ans) -> Map k v -> Set k -> ans -> ans
intersectMapSetFold :: (k -> v -> ans -> ans) -> Map k v -> Set k -> ans -> ans
intersectMapSetFold k -> v -> ans -> ans
_accum Map k v
Tip Set k
_ !ans
ans = ans
ans
intersectMapSetFold k -> v -> ans -> ans
_accum Map k v
_ Set k
set !ans
ans | Set k -> Bool
forall a. Set a -> Bool
Set.null Set k
set = ans
ans
intersectMapSetFold k -> v -> ans -> ans
accum (Bin Int
_ k
k v
v Map k v
l1 Map k v
l2) Set k
set !ans
ans =
    (k -> v -> ans -> ans) -> Map k v -> Set k -> ans -> ans
forall k v ans.
Ord k =>
(k -> v -> ans -> ans) -> Map k v -> Set k -> ans -> ans
intersectMapSetFold k -> v -> ans -> ans
accum Map k v
l1 Set k
s1 (k -> v -> ans -> ans
addKV k
k v
v ((k -> v -> ans -> ans) -> Map k v -> Set k -> ans -> ans
forall k v ans.
Ord k =>
(k -> v -> ans -> ans) -> Map k v -> Set k -> ans -> ans
intersectMapSetFold k -> v -> ans -> ans
accum Map k v
l2 Set k
s2 ans
ans))
  where (Set k
s1,Bool
found,Set k
s2) = k -> Set k -> (Set k, Bool, Set k)
forall a. Ord a => a -> Set a -> (Set a, Bool, Set a)
Set.splitMember k
k Set k
set
        addKV :: k -> v -> ans -> ans
addKV k
k1 v
v1 !ans
ans1 = if Bool
found then k -> v -> ans -> ans
accum k
k1 v
v1 ans
ans1 else ans
ans1
{-# INLINABLE intersectMapSetFold #-}

-- | Fold with 'accum' all those pairs in the map, not appearing in the set.
disjointMapSetFold:: Ord k => (k -> v -> ans -> ans) -> Map k v -> Set k -> ans -> ans
disjointMapSetFold :: (k -> v -> ans -> ans) -> Map k v -> Set k -> ans -> ans
disjointMapSetFold k -> v -> ans -> ans
_accum Map k v
Tip Set k
_ !ans
ans = ans
ans
disjointMapSetFold k -> v -> ans -> ans
accum Map k v
m Set k
set !ans
ans | Set k -> Bool
forall a. Set a -> Bool
Set.null Set k
set = (k -> v -> ans -> ans) -> ans -> Map k v -> ans
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey' k -> v -> ans -> ans
accum ans
ans Map k v
m
disjointMapSetFold k -> v -> ans -> ans
accum (Bin Int
_ k
k v
v Map k v
l1 Map k v
l2) Set k
set !ans
ans =
    (k -> v -> ans -> ans) -> Map k v -> Set k -> ans -> ans
forall k v ans.
Ord k =>
(k -> v -> ans -> ans) -> Map k v -> Set k -> ans -> ans
disjointMapSetFold k -> v -> ans -> ans
accum Map k v
l1 Set k
s1 (k -> v -> ans -> ans
addKV k
k v
v ((k -> v -> ans -> ans) -> Map k v -> Set k -> ans -> ans
forall k v ans.
Ord k =>
(k -> v -> ans -> ans) -> Map k v -> Set k -> ans -> ans
disjointMapSetFold k -> v -> ans -> ans
accum Map k v
l2 Set k
s2 ans
ans))
  where (Set k
s1,Bool
found,Set k
s2) = k -> Set k -> (Set k, Bool, Set k)
forall a. Ord a => a -> Set a -> (Set a, Bool, Set a)
Set.splitMember k
k Set k
set
        addKV :: k -> v -> ans -> ans
addKV k
k1 v
v1 !ans
ans1 = if Bool -> Bool
not Bool
found then k -> v -> ans -> ans
accum k
k1 v
v1 ans
ans1 else ans
ans1

-- ============== Iter BiMap ====================

instance Ord v => Iter (BiMap v) where
  nxt :: BiMap v a b -> Collect (a, b, BiMap v a b)
nxt (MkBiMap Map a b
left Map b (Set a)
right) = (forall ans. ans -> ((a, b, BiMap v a b) -> ans -> ans) -> ans)
-> Collect (a, b, BiMap v a b)
forall tuple.
(forall ans. ans -> (tuple -> ans -> ans) -> ans) -> Collect tuple
Collect (\ ans
ans (a, b, BiMap v a b) -> ans -> ans
f ->
     case Map a b -> Maybe ((a, b), Map a b)
forall k a. Map k a -> Maybe ((k, a), Map k a)
Map.minViewWithKey Map a b
left of
        Maybe ((a, b), Map a b)
Nothing -> ans
ans
        Just((a
k,b
v),Map a b
nextm) -> (a, b, BiMap v a b) -> ans -> ans
f (a
k,b
v,Map a b -> Map b (Set a) -> BiMap v a b
forall v b a. (v ~ b) => Map a b -> Map b (Set a) -> BiMap v a b
MkBiMap Map a b
nextm Map b (Set a)
right) ans
ans)
  lub :: k -> BiMap v k b -> Collect (k, b, BiMap v k b)
lub k
key (MkBiMap Map k b
forward Map b (Set k)
backward) = (forall ans. ans -> ((k, b, BiMap v k b) -> ans -> ans) -> ans)
-> Collect (k, b, BiMap v k b)
forall tuple.
(forall ans. ans -> (tuple -> ans -> ans) -> ans) -> Collect tuple
Collect (\ ans
ans (k, b, BiMap v k b) -> ans -> ans
f ->
     case k -> Map k b -> (Map k b, Maybe b, Map k b)
forall k a. Ord k => k -> Map k a -> (Map k a, Maybe a, Map k a)
Map.splitLookup k
key Map k b
forward of           -- NOTE in Log time, we skip over all those tuples in _left
       (Map k b
_left,Just b
v,Map k b
right) -> (k, b, BiMap v k b) -> ans -> ans
f (k
key,b
v,Map k b -> Map b (Set k) -> BiMap v k b
forall v b a. (v ~ b) => Map a b -> Map b (Set a) -> BiMap v a b
MkBiMap Map k b
right Map b (Set k)
backward) ans
ans
       (Map k b
_left,Maybe b
Nothing,Map k b
Tip) -> ans
ans
       (Map k b
_left,Maybe b
Nothing,Map k b
right) -> (k, b, BiMap v k b) -> ans -> ans
f (k
k,b
v,Map k b -> Map b (Set k) -> BiMap v k b
forall v b a. (v ~ b) => Map a b -> Map b (Set a) -> BiMap v a b
MkBiMap Map k b
m3 Map b (Set k)
backward) ans
ans
           where ((k
k,b
v),Map k b
m3) = Map k b -> ((k, b), Map k b)
forall k a. Map k a -> ((k, a), Map k a)
Map.deleteFindMin Map k b
right )
  isnull :: BiMap v k v -> Bool
isnull (MkBiMap Map k v
f Map v (Set k)
_g) = Map k v -> Bool
forall (f :: * -> * -> *) k v. Iter f => f k v -> Bool
isnull Map k v
f
  lookup :: key -> BiMap v key rng -> Maybe rng
lookup key
x (MkBiMap Map key rng
left Map rng (Set key)
_right) = key -> Map key rng -> Maybe rng
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup key
x Map key rng
left
  haskey :: key -> BiMap v key b -> Bool
haskey key
k (MkBiMap Map key b
left Map b (Set key)
_right) = key -> Map key b -> Bool
forall (f :: * -> * -> *) key b.
(Iter f, Ord key) =>
key -> f key b -> Bool
haskey key
k Map key b
left


-- ===============================================================================================
-- BaseRep witnesses Basic types. I.e. those types that are instances of both Basic and Iter.
-- It is used in constructors 'Base' and 'BaseD' and functions 'materialize' and 'fromList'
-- ===============================================================================================

data BaseRep f k v where
   MapR::    Basic Map.Map => BaseRep Map.Map k v
   SetR::    Basic Sett    => BaseRep Sett k ()
   ListR::   Basic List    => BaseRep List k v
   SingleR:: Basic Single  => BaseRep Single k v
   BiMapR::  (Basic (BiMap v),Ord v) => BaseRep (BiMap v) k v


-- ==========================================================================
-- 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)}


-- ================================================================================================
-- | The self typed GADT: Exp, that encodes the shape of Set expressions. A deep embedding.
-- Exp is a typed Symbolic representation of queries we may ask. It allows us to introspect a query
-- The strategy is to
-- 1) Define Exp so all queries can be represented.
-- 2) Define smart constructors that "parse" the surface syntax, and build a typed Exp
-- 3) Write an evaluate function:  eval:: Exp t -> t
-- 4) "eval" can introspect the code and apply efficient domain and type specific translations
-- 5) Use the (Iter f) class to evaluate some Exp that can benefit from its efficient nature.
-- ===============================================================================================

data Exp t where
   Base:: (Ord k,Basic f) => BaseRep f k v -> f k v -> Exp (f k v)  -- Note the use of BaseRep to witness what Base type.
   Dom:: Ord k => Exp (f k v) -> Exp (Sett k ())
   Rng:: (Ord k,Ord v) => Exp (f k v) -> Exp (Sett v ())
   DRestrict:: (Ord k,Iter g) => Exp (g k ()) -> Exp (f k v) -> Exp (f k v)
   DExclude::  (Ord k,Iter g) => Exp (g k ()) -> Exp (f k v) -> Exp (f k v)
   RRestrict:: (Ord k,Iter g,Ord v) => Exp (f k v) -> Exp (g v ()) -> Exp (f k v)
   RExclude:: (Ord k,Iter g,Ord v) => Exp (f k v) -> Exp (g v ()) -> Exp (f k v)
   Elem :: (Ord k,Iter g,Show k) => k -> Exp(g k ()) -> Exp Bool
   NotElem ::(Ord k,Iter g, Show k) => k -> Exp(g k ()) -> Exp Bool
   Intersect :: (Ord k, Iter f, Iter g) => Exp(f k v) -> Exp(g k u) -> Exp(Sett k ())
   Subset ::  (Ord k, Iter f, Iter g) => Exp(f k v) -> Exp(g k u) -> Exp Bool
   SetDiff ::  (Ord k, Iter f, Iter g) => Exp(f k v) -> Exp(g k u) -> Exp(f k v)
   UnionOverrideLeft:: (Show k, Show v,Ord k) => Exp (f k v) -> Exp (g k v) -> Exp(f k v)
        -- The (Show k, Show v) supports logging errors if there are duplicate keys.
   UnionPlus:: (Ord k,Monoid n) => Exp (f k n) -> Exp (f k n) -> Exp(f k n)
   UnionOverrideRight:: Ord k => Exp (f k v) -> Exp (g k v) -> Exp(f k v)
   Singleton:: (Ord k) => k -> v -> Exp(Single k v)
   SetSingleton:: (Ord k) => k -> Exp(Single k ())
   KeyEqual:: (Ord k,Iter f,Iter g) => Exp (f k v) -> Exp(g k u) -> Exp Bool

-- deriving instance NFData t => NFData(Exp t)

-- =======================================================================================================
-- When we build an Exp, we want to make sure all Sets with one element become (SetSingleton x)
-- so we use these 'smart' constructors.


dRestrict :: (Ord k,Iter g) => Exp (g k ()) -> Exp (f k v) -> Exp (f k v)
dRestrict :: Exp (g k ()) -> Exp (f k v) -> Exp (f k v)
dRestrict (Base BaseRep f k v
SetR (Sett x)) Exp (f k v)
y | Set k -> Int
forall a. Set a -> Int
Set.size Set k
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = Exp (Single k ()) -> Exp (f k v) -> Exp (f k v)
forall k (g :: * -> * -> *) (f :: * -> * -> *) v.
(Ord k, Iter g) =>
Exp (g k ()) -> Exp (f k v) -> Exp (f k v)
DRestrict (k -> Exp (Single k ())
forall v. Ord v => v -> Exp (Single v ())
SetSingleton(Int -> Set k -> k
forall a. Int -> Set a -> a
Set.elemAt Int
0 Set k
x)) Exp (f k v)
Exp (f k v)
y
dRestrict Exp (g k ())
x Exp (f k v)
y = Exp (g k ()) -> Exp (f k v) -> Exp (f k v)
forall k (g :: * -> * -> *) (f :: * -> * -> *) v.
(Ord k, Iter g) =>
Exp (g k ()) -> Exp (f k v) -> Exp (f k v)
DRestrict Exp (g k ())
x Exp (f k v)
y

rRestrict :: (Ord k,Iter g,Ord v) =>  Exp (f k v) -> Exp (g v ()) -> Exp (f k v)
rRestrict :: Exp (f k v) -> Exp (g v ()) -> Exp (f k v)
rRestrict Exp (f k v)
y (Base BaseRep f k v
SetR (Sett x)) | Set k -> Int
forall a. Set a -> Int
Set.size Set k
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = Exp (f k v) -> Exp (Single v ()) -> Exp (f k v)
forall k (g :: * -> * -> *) v (f :: * -> * -> *).
(Ord k, Iter g, Ord v) =>
Exp (f k v) -> Exp (g v ()) -> Exp (f k v)
RRestrict Exp (f k v)
y (k -> Exp (Single k ())
forall v. Ord v => v -> Exp (Single v ())
SetSingleton(Int -> Set k -> k
forall a. Int -> Set a -> a
Set.elemAt Int
0 Set k
x))
rRestrict Exp (f k v)
y Exp (g v ())
x = Exp (f k v) -> Exp (g v ()) -> Exp (f k v)
forall k (g :: * -> * -> *) v (f :: * -> * -> *).
(Ord k, Iter g, Ord v) =>
Exp (f k v) -> Exp (g v ()) -> Exp (f k v)
RRestrict Exp (f k v)
y Exp (g v ())
x

dExclude :: (Ord k,Iter g) => Exp (g k ()) -> Exp (f k v) -> Exp (f k v)
dExclude :: Exp (g k ()) -> Exp (f k v) -> Exp (f k v)
dExclude (Base BaseRep f k v
SetR (Sett x)) Exp (f k v)
y | Set k -> Int
forall a. Set a -> Int
Set.size Set k
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = Exp (Single k ()) -> Exp (f k v) -> Exp (f k v)
forall k (g :: * -> * -> *) (f :: * -> * -> *) v.
(Ord k, Iter g) =>
Exp (g k ()) -> Exp (f k v) -> Exp (f k v)
DExclude (k -> Exp (Single k ())
forall v. Ord v => v -> Exp (Single v ())
SetSingleton(Int -> Set k -> k
forall a. Int -> Set a -> a
Set.elemAt Int
0 Set k
x)) Exp (f k v)
Exp (f k v)
y
dExclude Exp (g k ())
x Exp (f k v)
y = Exp (g k ()) -> Exp (f k v) -> Exp (f k v)
forall k (g :: * -> * -> *) (f :: * -> * -> *) v.
(Ord k, Iter g) =>
Exp (g k ()) -> Exp (f k v) -> Exp (f k v)
DExclude Exp (g k ())
x Exp (f k v)
y

rExclude ::(Ord k,Iter g,Ord v) => Exp (f k v) -> Exp (g v ()) -> Exp (f k v)
rExclude :: Exp (f k v) -> Exp (g v ()) -> Exp (f k v)
rExclude Exp (f k v)
y (Base BaseRep f k v
SetR (Sett x)) | Set k -> Int
forall a. Set a -> Int
Set.size Set k
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = Exp (f k v) -> Exp (Single v ()) -> Exp (f k v)
forall k (g :: * -> * -> *) v (f :: * -> * -> *).
(Ord k, Iter g, Ord v) =>
Exp (f k v) -> Exp (g v ()) -> Exp (f k v)
RExclude Exp (f k v)
y (k -> Exp (Single k ())
forall v. Ord v => v -> Exp (Single v ())
SetSingleton(Int -> Set k -> k
forall a. Int -> Set a -> a
Set.elemAt Int
0 Set k
x))
rExclude Exp (f k v)
y Exp (g v ())
x = Exp (f k v) -> Exp (g v ()) -> Exp (f k v)
forall k (g :: * -> * -> *) v (f :: * -> * -> *).
(Ord k, Iter g, Ord v) =>
Exp (f k v) -> Exp (g v ()) -> Exp (f k v)
RExclude Exp (f k v)
y Exp (g v ())
x

-- =================================================================
-- | Basic types are those that can be embedded into Exp.
-- The HasExp class, encodes how to lift a Basic type into an Exp.
-- The function 'toExp' will build a typed Exp for that Basic type.
-- This will be really usefull in the smart constructors.
-- ==================================================================

class HasExp s t | s -> t where
  toExp :: s -> Exp t

-- | The simplest Base type is one that is already an Exp

instance HasExp (Exp t) t where
  toExp :: Exp t -> Exp t
toExp Exp t
x = Exp t
x

instance (Ord k) => HasExp (Map k v) (Map k v) where
  toExp :: Map k v -> Exp (Map k v)
toExp Map k v
x = BaseRep Map k v -> Map k v -> Exp (Map k v)
forall k (f :: * -> * -> *) v.
(Ord k, Basic f) =>
BaseRep f k v -> f k v -> Exp (f k v)
Base BaseRep Map k v
forall k v. Basic Map => BaseRep Map k v
MapR Map k v
x

instance (Ord k) => HasExp (Set.Set k) (Sett k ()) where
  toExp :: Set k -> Exp (Sett k ())
toExp Set k
x = BaseRep Sett k () -> Sett k () -> Exp (Sett k ())
forall k (f :: * -> * -> *) v.
(Ord k, Basic f) =>
BaseRep f k v -> f k v -> Exp (f k v)
Base BaseRep Sett k ()
forall k. Basic Sett => BaseRep Sett k ()
SetR (Set k -> Sett k ()
forall k. Set k -> Sett k ()
Sett Set k
x)


instance  (Ord k) => HasExp [(k,v)] (List k v) where
  toExp :: [(k, v)] -> Exp (List k v)
toExp [(k, v)]
l = BaseRep List k v -> List k v -> Exp (List k v)
forall k (f :: * -> * -> *) v.
(Ord k, Basic f) =>
BaseRep f k v -> f k v -> Exp (f k v)
Base BaseRep List k v
forall k v. Basic List => BaseRep List k v
ListR ([(k, v)] -> List k v
forall k v. Ord k => [(k, v)] -> List k v
UnSafeList (((k, v) -> (k, v) -> Ordering) -> [(k, v)] -> [(k, v)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\ (k, v)
x (k, v)
y -> k -> k -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ((k, v) -> k
forall a b. (a, b) -> a
fst (k, v)
x) ((k, v) -> k
forall a b. (a, b) -> a
fst (k, v)
y)) [(k, v)]
l))

instance (Ord k) => HasExp (Single k v) (Single k v) where
  toExp :: Single k v -> Exp (Single k v)
toExp Single k v
x = BaseRep Single k v -> Single k v -> Exp (Single k v)
forall k (f :: * -> * -> *) v.
(Ord k, Basic f) =>
BaseRep f k v -> f k v -> Exp (f k v)
Base BaseRep Single k v
forall k v. Basic Single => BaseRep Single k v
SingleR Single k v
x

instance (Ord k,Ord v) => HasExp (Bimap k v) (Bimap k v) where
  toExp :: Bimap k v -> Exp (Bimap k v)
toExp Bimap k v
x = BaseRep (BiMap v) k v -> Bimap k v -> Exp (Bimap k v)
forall k (f :: * -> * -> *) v.
(Ord k, Basic f) =>
BaseRep f k v -> f k v -> Exp (f k v)
Base BaseRep (BiMap v) k v
forall v k. (Basic (BiMap v), Ord v) => BaseRep (BiMap v) k v
BiMapR Bimap k v
x

-- ==========================================================================================
-- Smart constructors build typed Exp with real values at the leaves (the Base constuctor)

-- (⊆),
-- (∩),


dom :: (Ord k,HasExp s (f k v)) => s -> Exp (Sett k ())
dom :: s -> Exp (Sett k ())
dom s
x = Exp (f k v) -> Exp (Sett k ())
forall k (f :: * -> * -> *) v.
Ord k =>
Exp (f k v) -> Exp (Sett k ())
Dom (s -> Exp (f k v)
forall s t. HasExp s t => s -> Exp t
toExp s
x)

rng:: (Ord k,Ord v) => HasExp s (f k v) => s -> Exp (Sett v ())
rng :: s -> Exp (Sett v ())
rng s
x = Exp (f k v) -> Exp (Sett v ())
forall k v (f :: * -> * -> *).
(Ord k, Ord v) =>
Exp (f k v) -> Exp (Sett v ())
Rng(s -> Exp (f k v)
forall s t. HasExp s t => s -> Exp t
toExp s
x)

(◁),(<|),drestrict ::  (Ord k,HasExp s1 (Sett k ()), HasExp s2 (f k v)) => s1 -> s2 -> Exp (f k v)
◁ :: s1 -> s2 -> Exp (f k v)
(◁) s1
x s2
y = Exp (Sett k ()) -> Exp (f k v) -> Exp (f k v)
forall k (g :: * -> * -> *) (f :: * -> * -> *) v.
(Ord k, Iter g) =>
Exp (g k ()) -> Exp (f k v) -> Exp (f k v)
dRestrict (s1 -> Exp (Sett k ())
forall s t. HasExp s t => s -> Exp t
toExp s1
x) (s2 -> Exp (f k v)
forall s t. HasExp s t => s -> Exp t
toExp s2
y)
drestrict :: s1 -> s2 -> Exp (f k v)
drestrict = s1 -> s2 -> Exp (f k v)
forall k s1 s2 (f :: * -> * -> *) v.
(Ord k, HasExp s1 (Sett k ()), HasExp s2 (f k v)) =>
s1 -> s2 -> Exp (f k v)
(◁)
<| :: s1 -> s2 -> Exp (f k v)
(<|) = s1 -> s2 -> Exp (f k v)
forall k s1 s2 (f :: * -> * -> *) v.
(Ord k, HasExp s1 (Sett k ()), HasExp s2 (f k v)) =>
s1 -> s2 -> Exp (f k v)
drestrict

(⋪),dexclude :: (Ord k,Iter g, HasExp s1 (g k ()), HasExp s2 (f k v)) => s1 -> s2 -> Exp (f k v)
⋪ :: s1 -> s2 -> Exp (f k v)
(⋪) s1
x s2
y = Exp (g k ()) -> Exp (f k v) -> Exp (f k v)
forall k (g :: * -> * -> *) (f :: * -> * -> *) v.
(Ord k, Iter g) =>
Exp (g k ()) -> Exp (f k v) -> Exp (f k v)
dExclude (s1 -> Exp (g k ())
forall s t. HasExp s t => s -> Exp t
toExp s1
x) (s2 -> Exp (f k v)
forall s t. HasExp s t => s -> Exp t
toExp s2
y)
dexclude :: s1 -> s2 -> Exp (f k v)
dexclude = s1 -> s2 -> Exp (f k v)
forall k (g :: * -> * -> *) s1 s2 (f :: * -> * -> *) v.
(Ord k, Iter g, HasExp s1 (g k ()), HasExp s2 (f k v)) =>
s1 -> s2 -> Exp (f k v)
(⋪)

(▷),(|>),rrestrict :: (Ord k,Iter g, Ord v, HasExp s1 (f k v), HasExp s2 (g v ())) => s1 -> s2 -> Exp (f k v)
▷ :: s1 -> s2 -> Exp (f k v)
(▷) s1
x s2
y = Exp (f k v) -> Exp (g v ()) -> Exp (f k v)
forall k (g :: * -> * -> *) v (f :: * -> * -> *).
(Ord k, Iter g, Ord v) =>
Exp (f k v) -> Exp (g v ()) -> Exp (f k v)
rRestrict (s1 -> Exp (f k v)
forall s t. HasExp s t => s -> Exp t
toExp s1
x) (s2 -> Exp (g v ())
forall s t. HasExp s t => s -> Exp t
toExp s2
y)
rrestrict :: s1 -> s2 -> Exp (f k v)
rrestrict = s1 -> s2 -> Exp (f k v)
forall k (g :: * -> * -> *) v s1 (f :: * -> * -> *) s2.
(Ord k, Iter g, Ord v, HasExp s1 (f k v), HasExp s2 (g v ())) =>
s1 -> s2 -> Exp (f k v)
(▷)
|> :: s1 -> s2 -> Exp (f k v)
(|>) = s1 -> s2 -> Exp (f k v)
forall k (g :: * -> * -> *) v s1 (f :: * -> * -> *) s2.
(Ord k, Iter g, Ord v, HasExp s1 (f k v), HasExp s2 (g v ())) =>
s1 -> s2 -> Exp (f k v)
(▷)

(⋫),rexclude :: (Ord k,Iter g, Ord v, HasExp s1 (f k v), HasExp s2 (g v ())) => s1 -> s2 -> Exp (f k v)
⋫ :: s1 -> s2 -> Exp (f k v)
(⋫) s1
x s2
y = Exp (f k v) -> Exp (g v ()) -> Exp (f k v)
forall k (g :: * -> * -> *) v (f :: * -> * -> *).
(Ord k, Iter g, Ord v) =>
Exp (f k v) -> Exp (g v ()) -> Exp (f k v)
rExclude (s1 -> Exp (f k v)
forall s t. HasExp s t => s -> Exp t
toExp s1
x) (s2 -> Exp (g v ())
forall s t. HasExp s t => s -> Exp t
toExp s2
y)
rexclude :: s1 -> s2 -> Exp (f k v)
rexclude = s1 -> s2 -> Exp (f k v)
forall k (g :: * -> * -> *) v s1 (f :: * -> * -> *) s2.
(Ord k, Iter g, Ord v, HasExp s1 (f k v), HasExp s2 (g v ())) =>
s1 -> s2 -> Exp (f k v)
(⋫)
(∈) :: (Show k, Ord k,Iter g,HasExp s (g k ())) => k -> s -> Exp Bool
∈ :: k -> s -> Exp Bool
(∈) k
x s
y = k -> Exp (g k ()) -> Exp Bool
forall k (g :: * -> * -> *).
(Ord k, Iter g, Show k) =>
k -> Exp (g k ()) -> Exp Bool
Elem k
x (s -> Exp (g k ())
forall s t. HasExp s t => s -> Exp t
toExp s
y)

(∉),notelem :: (Show k, Ord k,Iter g, HasExp s (g k ())) => k -> s -> Exp Bool
∉ :: k -> s -> Exp Bool
(∉) k
x s
y = k -> Exp (g k ()) -> Exp Bool
forall k (g :: * -> * -> *).
(Ord k, Iter g, Show k) =>
k -> Exp (g k ()) -> Exp Bool
NotElem k
x (s -> Exp (g k ())
forall s t. HasExp s t => s -> Exp t
toExp s
y)
notelem :: k -> s -> Exp Bool
notelem = k -> s -> Exp Bool
forall k (g :: * -> * -> *) s.
(Show k, Ord k, Iter g, HasExp s (g k ())) =>
k -> s -> Exp Bool
(∉)

(∪),unionleft :: (Show k,Show v,Ord k,HasExp s1 (f k v), HasExp s2 (g k v)) => s1 -> s2 -> Exp (f k v)
∪ :: s1 -> s2 -> Exp (f k v)
(∪) s1
x s2
y = Exp (f k v) -> Exp (g k v) -> Exp (f k v)
forall k v (k :: * -> * -> *) (n :: * -> * -> *).
(Show k, Show v, Ord k) =>
Exp (k k v) -> Exp (n k v) -> Exp (k k v)
UnionOverrideLeft (s1 -> Exp (f k v)
forall s t. HasExp s t => s -> Exp t
toExp s1
x) (s2 -> Exp (g k v)
forall s t. HasExp s t => s -> Exp t
toExp s2
y)
unionleft :: s1 -> s2 -> Exp (f k v)
unionleft = s1 -> s2 -> Exp (f k v)
forall k v s1 (f :: * -> * -> *) s2 (g :: * -> * -> *).
(Show k, Show v, Ord k, HasExp s1 (f k v), HasExp s2 (g k v)) =>
s1 -> s2 -> Exp (f k v)
(∪)

(⨃),unionright :: (Ord k,HasExp s1 (f k v), HasExp s2 (g k v)) => s1 -> s2 -> Exp (f k v)
⨃ :: s1 -> s2 -> Exp (f k v)
(⨃) s1
x s2
y = Exp (f k v) -> Exp (g k v) -> Exp (f k v)
forall k (f :: * -> * -> *) k (v :: * -> * -> *).
Ord k =>
Exp (f k k) -> Exp (v k k) -> Exp (f k k)
UnionOverrideRight (s1 -> Exp (f k v)
forall s t. HasExp s t => s -> Exp t
toExp s1
x) (s2 -> Exp (g k v)
forall s t. HasExp s t => s -> Exp t
toExp s2
y)
unionright :: s1 -> s2 -> Exp (f k v)
unionright = s1 -> s2 -> Exp (f k v)
forall k s1 (f :: * -> * -> *) v s2 (g :: * -> * -> *).
(Ord k, HasExp s1 (f k v), HasExp s2 (g k v)) =>
s1 -> s2 -> Exp (f k v)
(⨃)

(∪+),unionplus :: (Ord k,Monoid n, HasExp s1 (f k n), HasExp s2 (f k n)) => s1 -> s2 -> Exp (f k n)
∪+ :: s1 -> s2 -> Exp (f k n)
(∪+) s1
x s2
y = Exp (f k n) -> Exp (f k n) -> Exp (f k n)
forall k n (f :: * -> * -> *).
(Ord k, Monoid n) =>
Exp (f k n) -> Exp (f k n) -> Exp (f k n)
UnionPlus (s1 -> Exp (f k n)
forall s t. HasExp s t => s -> Exp t
toExp s1
x) (s2 -> Exp (f k n)
forall s t. HasExp s t => s -> Exp t
toExp s2
y)
unionplus :: s1 -> s2 -> Exp (f k n)
unionplus = s1 -> s2 -> Exp (f k n)
forall k n s1 (f :: * -> * -> *) s2.
(Ord k, Monoid n, HasExp s1 (f k n), HasExp s2 (f k n)) =>
s1 -> s2 -> Exp (f k n)
(∪+)

singleton :: (Ord k) => k -> v -> Exp (Single k v)
singleton :: k -> v -> Exp (Single k v)
singleton k
k v
v = k -> v -> Exp (Single k v)
forall k v. Ord k => k -> v -> Exp (Single k v)
Singleton k
k v
v

setSingleton :: (Ord k) => k -> Exp (Single k ())
setSingleton :: k -> Exp (Single k ())
setSingleton k
k = k -> Exp (Single k ())
forall v. Ord v => v -> Exp (Single v ())
SetSingleton k
k

(∩),intersect :: (Ord k, Iter f, Iter g, HasExp s1 (f k v), HasExp s2 (g k u)) => s1 -> s2 -> Exp (Sett k ())
∩ :: s1 -> s2 -> Exp (Sett k ())
(∩) s1
x s2
y = Exp (f k v) -> Exp (g k u) -> Exp (Sett k ())
forall k (f :: * -> * -> *) (g :: * -> * -> *) v u.
(Ord k, Iter f, Iter g) =>
Exp (f k v) -> Exp (g k u) -> Exp (Sett k ())
Intersect (s1 -> Exp (f k v)
forall s t. HasExp s t => s -> Exp t
toExp s1
x) (s2 -> Exp (g k u)
forall s t. HasExp s t => s -> Exp t
toExp s2
y)
intersect :: s1 -> s2 -> Exp (Sett k ())
intersect = s1 -> s2 -> Exp (Sett k ())
forall k (f :: * -> * -> *) (g :: * -> * -> *) s1 v s2 u.
(Ord k, Iter f, Iter g, HasExp s1 (f k v), HasExp s2 (g k u)) =>
s1 -> s2 -> Exp (Sett k ())
(∩)

(⊆),subset :: (Ord k, Iter f, Iter g, HasExp s1 (f k v), HasExp s2 (g k u)) => s1 -> s2 -> Exp Bool
⊆ :: s1 -> s2 -> Exp Bool
(⊆) s1
x s2
y = Exp (f k v) -> Exp (g k u) -> Exp Bool
forall k (f :: * -> * -> *) (g :: * -> * -> *) v u.
(Ord k, Iter f, Iter g) =>
Exp (f k v) -> Exp (g k u) -> Exp Bool
Subset (s1 -> Exp (f k v)
forall s t. HasExp s t => s -> Exp t
toExp s1
x) (s2 -> Exp (g k u)
forall s t. HasExp s t => s -> Exp t
toExp s2
y)
subset :: s1 -> s2 -> Exp Bool
subset = s1 -> s2 -> Exp Bool
forall k (f :: * -> * -> *) (g :: * -> * -> *) s1 v s2 u.
(Ord k, Iter f, Iter g, HasExp s1 (f k v), HasExp s2 (g k u)) =>
s1 -> s2 -> Exp Bool
(⊆)

(➖),setdiff  ::  (Ord k, Iter f, Iter g, HasExp s1 (f k v), HasExp s2 (g k u)) => s1 -> s2 -> Exp(f k v)
➖ :: s1 -> s2 -> Exp (f k v)
(➖) s1
x s2
y = Exp (f k v) -> Exp (g k u) -> Exp (f k v)
forall k (f :: * -> * -> *) (g :: * -> * -> *) v u.
(Ord k, Iter f, Iter g) =>
Exp (f k v) -> Exp (g k u) -> Exp (f k v)
SetDiff (s1 -> Exp (f k v)
forall s t. HasExp s t => s -> Exp t
toExp s1
x) (s2 -> Exp (g k u)
forall s t. HasExp s t => s -> Exp t
toExp s2
y)
setdiff :: s1 -> s2 -> Exp (f k v)
setdiff = s1 -> s2 -> Exp (f k v)
forall k (f :: * -> * -> *) (g :: * -> * -> *) s1 v s2 u.
(Ord k, Iter f, Iter g, HasExp s1 (f k v), HasExp s2 (g k u)) =>
s1 -> s2 -> Exp (f k v)
(➖)

(≍),keyeq :: (Ord k, Iter f, Iter g, HasExp s1 (f k v), HasExp s2 (g k u)) => s1 -> s2 -> Exp Bool
≍ :: s1 -> s2 -> Exp Bool
(≍) s1
x s2
y = Exp (f k v) -> Exp (g k u) -> Exp Bool
forall k (f :: * -> * -> *) (g :: * -> * -> *) v u.
(Ord k, Iter f, Iter g) =>
Exp (f k v) -> Exp (g k u) -> Exp Bool
KeyEqual (s1 -> Exp (f k v)
forall s t. HasExp s t => s -> Exp t
toExp s1
x) (s2 -> Exp (g k u)
forall s t. HasExp s t => s -> Exp t
toExp s2
y)
keyeq :: s1 -> s2 -> Exp Bool
keyeq = s1 -> s2 -> Exp Bool
forall k (f :: * -> * -> *) (g :: * -> * -> *) s1 v s2 u.
(Ord k, Iter f, Iter g, HasExp s1 (f k v), HasExp s2 (g k u)) =>
s1 -> s2 -> Exp Bool
(≍)

--

-- =================================================================================================
-- | Symbolc functions (Fun) are data, that can be pattern matched over. They
-- 1) Represent a wide class of binary functions that are used in translating the SetAlgebra
-- 2) Turned into a String so they can be printed
-- 3) Turned into the function they represent.
-- 4) Composed into bigger functions
-- 5) Symbolically symplified
-- Here  we implement Symbolic Binary functions with upto 4 variables, which is enough for this use
-- =================================================================================================

data Pat env t where
  P1:: Pat (d,c,b,a) d
  P2:: Pat (d,c,b,a) c
  P3:: Pat (d,c,b,a) b
  P4:: Pat (d,c,b,a) a
  PPair:: Pat (d,c,b,a) a -> Pat (d,c,b,a) b ->  Pat (d,c,b,a) (a,b)

data Expr env t where
  X1:: Expr (d,c,b,a) d
  X2:: Expr (d,c,b,a) c
  X3:: Expr (d,c,b,a) b
  X4:: Expr (d,c,b,a) a
  HasKey:: (Iter f,Ord k) =>  Expr e k -> (f k v) -> Expr e Bool
  Neg :: Expr e Bool -> Expr e Bool
  Ap:: Lam(a -> b -> c) -> Expr e a -> Expr e b -> Expr e c
  EPair:: Expr e a -> Expr e b -> Expr e (a,b)
  FST:: Expr e (a,b) -> Expr e a
  SND:: Expr e (a,b) -> Expr e b
  Lit :: Show t => t -> Expr env t

-- Carefull no pattern P1, P2, P3, P4 should appear MORE THAN ONCE in a Lam.

data Lam t where
  Lam::  Pat (d,c,b,a) t -> Pat (d,c,b,a) s -> Expr (d,c,b,a) v -> Lam (t -> s -> v)
  Add :: Num n => Lam (n -> n -> n)
  Cat :: Monoid m => Lam (m -> m -> m)
  Eql :: Eq t => Lam(t -> t -> Bool)
  Both:: Lam (Bool -> Bool -> Bool)
  Lift:: (a -> b -> c) -> Lam (a -> b -> c)  -- For use n the tests only!

-- ============= Printing in 𝜷-Normal Form =========================

type StringEnv = (String,String,String,String)

bindE :: Pat (a,b,c,d) t -> Expr (w,x,y,z) t -> StringEnv -> StringEnv
bindE :: Pat (a, b, c, d) t -> Expr (w, x, y, z) t -> StringEnv -> StringEnv
bindE Pat (a, b, c, d) t
P1 Expr (w, x, y, z) t
v (e :: StringEnv
e@([Char]
_,[Char]
c,[Char]
b,[Char]
a)) = (StringEnv -> Expr (w, x, y, z) t -> [Char]
forall a b c d t. StringEnv -> Expr (a, b, c, d) t -> [Char]
showE StringEnv
e Expr (w, x, y, z) t
v,[Char]
c,[Char]
b,[Char]
a)
bindE Pat (a, b, c, d) t
P2 Expr (w, x, y, z) t
v (e :: StringEnv
e@([Char]
d,[Char]
_,[Char]
b,[Char]
a)) = ([Char]
d,StringEnv -> Expr (w, x, y, z) t -> [Char]
forall a b c d t. StringEnv -> Expr (a, b, c, d) t -> [Char]
showE StringEnv
e Expr (w, x, y, z) t
v,[Char]
b,[Char]
a)
bindE Pat (a, b, c, d) t
P3 Expr (w, x, y, z) t
v (e :: StringEnv
e@([Char]
d,[Char]
c,[Char]
_,[Char]
a)) = ([Char]
d,[Char]
c,StringEnv -> Expr (w, x, y, z) t -> [Char]
forall a b c d t. StringEnv -> Expr (a, b, c, d) t -> [Char]
showE StringEnv
e Expr (w, x, y, z) t
v,[Char]
a)
bindE Pat (a, b, c, d) t
P4 Expr (w, x, y, z) t
v (e :: StringEnv
e@([Char]
d,[Char]
c,[Char]
b,[Char]
_)) = ([Char]
d,[Char]
c,[Char]
b,StringEnv -> Expr (w, x, y, z) t -> [Char]
forall a b c d t. StringEnv -> Expr (a, b, c, d) t -> [Char]
showE StringEnv
e Expr (w, x, y, z) t
v)
bindE (PPair Pat (d, c, b, a) a
p1 Pat (d, c, b, a) b
p2) (EPair Expr (w, x, y, z) a
e1 Expr (w, x, y, z) b
e2) StringEnv
env = Pat (d, c, b, a) a -> Expr (w, x, y, z) a -> StringEnv -> StringEnv
forall a b c d t w x y z.
Pat (a, b, c, d) t -> Expr (w, x, y, z) t -> StringEnv -> StringEnv
bindE Pat (d, c, b, a) a
p1 Expr (w, x, y, z) a
Expr (w, x, y, z) a
e1 (Pat (d, c, b, a) b -> Expr (w, x, y, z) b -> StringEnv -> StringEnv
forall a b c d t w x y z.
Pat (a, b, c, d) t -> Expr (w, x, y, z) t -> StringEnv -> StringEnv
bindE Pat (d, c, b, a) b
p2 Expr (w, x, y, z) b
Expr (w, x, y, z) b
e2 StringEnv
env)
bindE (PPair Pat (d, c, b, a) a
p1 Pat (d, c, b, a) b
p2) Expr (w, x, y, z) t
e StringEnv
env = Pat (d, c, b, a) b -> Expr (w, x, y, z) b -> StringEnv -> StringEnv
forall a b c d t w x y z.
Pat (a, b, c, d) t -> Expr (w, x, y, z) t -> StringEnv -> StringEnv
bindE Pat (d, c, b, a) b
p2 (Expr (w, x, y, z) (d, b) -> Expr (w, x, y, z) b
forall e a b. Expr e (a, b) -> Expr e b
SND Expr (w, x, y, z) t
Expr (w, x, y, z) (d, b)
e) (Pat (d, c, b, a) a -> Expr (w, x, y, z) a -> StringEnv -> StringEnv
forall a b c d t w x y z.
Pat (a, b, c, d) t -> Expr (w, x, y, z) t -> StringEnv -> StringEnv
bindE Pat (d, c, b, a) a
p1 (Expr (w, x, y, z) (a, c) -> Expr (w, x, y, z) a
forall e a b. Expr e (a, b) -> Expr e a
FST Expr (w, x, y, z) t
Expr (w, x, y, z) (a, c)
e) StringEnv
env)

showE :: StringEnv -> (Expr (a,b,c,d) t) -> String
showE :: StringEnv -> Expr (a, b, c, d) t -> [Char]
showE ([Char]
x,[Char]
_,[Char]
_,[Char]
_) Expr (a, b, c, d) t
X1 = [Char]
x
showE ([Char]
_,[Char]
y,[Char]
_,[Char]
_) Expr (a, b, c, d) t
X2 = [Char]
y
showE ([Char]
_,[Char]
_,[Char]
z,[Char]
_) Expr (a, b, c, d) t
X3 = [Char]
z
showE ([Char]
_,[Char]
_,[Char]
_,[Char]
w) Expr (a, b, c, d) t
X4 = [Char]
w
showE StringEnv
e (EPair Expr (a, b, c, d) a
a Expr (a, b, c, d) b
b) = [Char]
"("[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++StringEnv -> Expr (a, b, c, d) a -> [Char]
forall a b c d t. StringEnv -> Expr (a, b, c, d) t -> [Char]
showE StringEnv
e Expr (a, b, c, d) a
a[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
","[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++StringEnv -> Expr (a, b, c, d) b -> [Char]
forall a b c d t. StringEnv -> Expr (a, b, c, d) t -> [Char]
showE StringEnv
e Expr (a, b, c, d) b
b[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
")"
showE StringEnv
e (Ap (Lam Pat (d, c, b, a) t
p1 Pat (d, c, b, a) s
p2 Expr (d, c, b, a) v
expr) Expr (a, b, c, d) a
x Expr (a, b, c, d) b
y) = StringEnv -> Expr (d, c, b, a) v -> [Char]
forall a b c d t. StringEnv -> Expr (a, b, c, d) t -> [Char]
showE (Pat (d, c, b, a) s -> Expr (a, b, c, d) s -> StringEnv -> StringEnv
forall a b c d t w x y z.
Pat (a, b, c, d) t -> Expr (w, x, y, z) t -> StringEnv -> StringEnv
bindE Pat (d, c, b, a) s
p2 Expr (a, b, c, d) b
Expr (a, b, c, d) s
y (Pat (d, c, b, a) t -> Expr (a, b, c, d) t -> StringEnv -> StringEnv
forall a b c d t w x y z.
Pat (a, b, c, d) t -> Expr (w, x, y, z) t -> StringEnv -> StringEnv
bindE Pat (d, c, b, a) t
p1 Expr (a, b, c, d) a
Expr (a, b, c, d) t
x StringEnv
e)) Expr (d, c, b, a) v
expr
showE StringEnv
e (FST Expr (a, b, c, d) (t, b)
f) = [Char]
"(fst " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ StringEnv -> Expr (a, b, c, d) (t, b) -> [Char]
forall a b c d t. StringEnv -> Expr (a, b, c, d) t -> [Char]
showE StringEnv
e Expr (a, b, c, d) (t, b)
f [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
")"
showE StringEnv
e (SND Expr (a, b, c, d) (a, t)
f) = [Char]
"(snd " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ StringEnv -> Expr (a, b, c, d) (a, t) -> [Char]
forall a b c d t. StringEnv -> Expr (a, b, c, d) t -> [Char]
showE StringEnv
e Expr (a, b, c, d) (a, t)
f [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
")"
showE StringEnv
e (Ap Lam (a -> b -> t)
oper Expr (a, b, c, d) a
a Expr (a, b, c, d) b
b) = [Char]
"("[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++StringEnv -> Expr (a, b, c, d) a -> [Char]
forall a b c d t. StringEnv -> Expr (a, b, c, d) t -> [Char]
showE StringEnv
e Expr (a, b, c, d) a
a[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++StringEnv -> Lam (a -> b -> t) -> [Char]
forall t. StringEnv -> Lam t -> [Char]
showL StringEnv
e Lam (a -> b -> t)
oper[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++StringEnv -> Expr (a, b, c, d) b -> [Char]
forall a b c d t. StringEnv -> Expr (a, b, c, d) t -> [Char]
showE StringEnv
e Expr (a, b, c, d) b
b[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
")"
showE StringEnv
e (HasKey Expr (a, b, c, d) k
k f k v
_datum) = [Char]
"(haskey "[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++StringEnv -> Expr (a, b, c, d) k -> [Char]
forall a b c d t. StringEnv -> Expr (a, b, c, d) t -> [Char]
showE StringEnv
e Expr (a, b, c, d) k
k[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
" ?)"
showE StringEnv
e (Neg Expr (a, b, c, d) Bool
x) = [Char]
"(not "[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++StringEnv -> Expr (a, b, c, d) Bool -> [Char]
forall a b c d t. StringEnv -> Expr (a, b, c, d) t -> [Char]
showE StringEnv
e Expr (a, b, c, d) Bool
x[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
")"
showE StringEnv
_ (Lit t
n) = t -> [Char]
forall a. Show a => a -> [Char]
show t
n

showL :: StringEnv -> Lam t -> String
showL :: StringEnv -> Lam t -> [Char]
showL StringEnv
e (Lam Pat (d, c, b, a) t
p1 Pat (d, c, b, a) s
p2 Expr (d, c, b, a) v
expr) = [Char]
"\\ "[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++StringEnv -> Pat (d, c, b, a) t -> [Char]
forall any t. StringEnv -> Pat any t -> [Char]
showP StringEnv
e Pat (d, c, b, a) t
p1[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
" "[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++StringEnv -> Pat (d, c, b, a) s -> [Char]
forall any t. StringEnv -> Pat any t -> [Char]
showP StringEnv
e Pat (d, c, b, a) s
p2[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
" -> "[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++StringEnv -> Expr (d, c, b, a) v -> [Char]
forall a b c d t. StringEnv -> Expr (a, b, c, d) t -> [Char]
showE StringEnv
e Expr (d, c, b, a) v
expr
showL StringEnv
_e Lam t
Add = [Char]
" + "
showL StringEnv
_e Lam t
Cat = [Char]
" <> "
showL StringEnv
_e Lam t
Eql = [Char]
" == "
showL StringEnv
_e Lam t
Both = [Char]
" && "
showL StringEnv
_e (Lift a -> b -> c
_f) = [Char]
"<lifted function>"

showP :: StringEnv -> (Pat any t) -> String
showP :: StringEnv -> Pat any t -> [Char]
showP ([Char]
x,[Char]
_,[Char]
_,[Char]
_) Pat any t
P1 = [Char]
x
showP ([Char]
_,[Char]
y,[Char]
_,[Char]
_) Pat any t
P2 = [Char]
y
showP ([Char]
_,[Char]
_,[Char]
z,[Char]
_) Pat any t
P3 = [Char]
z
showP ([Char]
_,[Char]
_,[Char]
_,[Char]
w) Pat any t
P4 = [Char]
w
showP StringEnv
env (PPair Pat (d, c, b, a) a
p1 Pat (d, c, b, a) b
p2) = [Char]
"("[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++StringEnv -> Pat (d, c, b, a) a -> [Char]
forall any t. StringEnv -> Pat any t -> [Char]
showP StringEnv
env Pat (d, c, b, a) a
p1[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
","[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++StringEnv -> Pat (d, c, b, a) b -> [Char]
forall any t. StringEnv -> Pat any t -> [Char]
showP StringEnv
env Pat (d, c, b, a) b
p2[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
")"

instance Show (Expr (a,b,c,d) t) where
   show :: Expr (a, b, c, d) t -> [Char]
show Expr (a, b, c, d) t
x = StringEnv -> Expr (a, b, c, d) t -> [Char]
forall a b c d t. StringEnv -> Expr (a, b, c, d) t -> [Char]
showE ([Char]
"X1",[Char]
"X2",[Char]
"X3",[Char]
"X4") Expr (a, b, c, d) t
x
instance Show (Lam t) where
   show :: Lam t -> [Char]
show Lam t
x = StringEnv -> Lam t -> [Char]
forall t. StringEnv -> Lam t -> [Char]
showL ([Char]
"X1",[Char]
"X2",[Char]
"X3",[Char]
"X4") Lam t
x

-- ===============================================================================================================
-- An symbolic function Fun has two parts, a Lam that can be analyzed, and real function that can be applied
-- ===============================================================================================================

data Fun t = Fun (Lam t) t

-- | We can observe a Fun by showing the Lam part.

instance Show (Fun t) where
  show :: Fun t -> [Char]
show (Fun Lam t
lam t
_fun) = Lam t -> [Char]
forall a. Show a => a -> [Char]
show Lam t
lam

-- ======================================================================================
-- Operations we use to manipulate Fun. Some simple ones, and some ways to compose them.
-- The great thing is the types completely decide what the operations do.
-- ======================================================================================


-- Used in projectStep, chainStep, andPStep, orStep and guardStep
apply :: Fun t -> t
apply :: Fun t -> t
apply (Fun Lam t
_e t
f) = t
f

-- Used in compile (UnionOverrideLeft case)
first :: Fun (v -> s -> v)
first :: Fun (v -> s -> v)
first = Lam (v -> s -> v) -> (v -> s -> v) -> Fun (v -> s -> v)
forall t. Lam t -> t -> Fun t
Fun (Pat (v, s, Any, Any) v
-> Pat (v, s, Any, Any) s
-> Expr (v, s, Any, Any) v
-> Lam (v -> s -> v)
forall d c b a m a b.
Pat (d, c, b, a) m
-> Pat (d, c, b, a) a -> Expr (d, c, b, a) b -> Lam (m -> a -> b)
Lam Pat (v, s, Any, Any) v
forall d c b a. Pat (d, c, b, a) d
P1 Pat (v, s, Any, Any) s
forall d c b a. Pat (d, c, b, a) c
P2 Expr (v, s, Any, Any) v
forall d c b a. Expr (d, c, b, a) d
X1) (\ v
x s
_y -> v
x)

-- Used in compile (UnionOverrideRight case)
second:: Fun (v -> s -> s)
second :: Fun (v -> s -> s)
second = Lam (v -> s -> s) -> (v -> s -> s) -> Fun (v -> s -> s)
forall t. Lam t -> t -> Fun t
Fun (Pat (v, s, Any, Any) v
-> Pat (v, s, Any, Any) s
-> Expr (v, s, Any, Any) s
-> Lam (v -> s -> s)
forall d c b a m a b.
Pat (d, c, b, a) m
-> Pat (d, c, b, a) a -> Expr (d, c, b, a) b -> Lam (m -> a -> b)
Lam Pat (v, s, Any, Any) v
forall d c b a. Pat (d, c, b, a) d
P1 Pat (v, s, Any, Any) s
forall d c b a. Pat (d, c, b, a) c
P2 Expr (v, s, Any, Any) s
forall d c b a. Expr (d, c, b, a) c
X2) (\ v
_x s
y -> s
y)

-- Used in compile (UnionPlus case)
plus:: Monoid t => Fun (t -> t -> t)
plus :: Fun (t -> t -> t)
plus = (Lam (t -> t -> t) -> (t -> t -> t) -> Fun (t -> t -> t)
forall t. Lam t -> t -> Fun t
Fun Lam (t -> t -> t)
forall m. Monoid m => Lam (m -> m -> m)
Cat t -> t -> t
forall a. Semigroup a => a -> a -> a
(<>))

eql :: Eq t => Fun (t -> t -> Bool)
eql :: Fun (t -> t -> Bool)
eql = (Lam (t -> t -> Bool) -> (t -> t -> Bool) -> Fun (t -> t -> Bool)
forall t. Lam t -> t -> Fun t
Fun Lam (t -> t -> Bool)
forall t. Eq t => Lam (t -> t -> Bool)
Eql t -> t -> Bool
forall a. Eq a => a -> a -> Bool
(==))

constant:: Show c => c -> Fun(a -> b -> c)
constant :: c -> Fun (a -> b -> c)
constant c
c = Lam (a -> b -> c) -> (a -> b -> c) -> Fun (a -> b -> c)
forall t. Lam t -> t -> Fun t
Fun (Pat (a, b, Any, Any) a
-> Pat (a, b, Any, Any) b
-> Expr (a, b, Any, Any) c
-> Lam (a -> b -> c)
forall d c b a m a b.
Pat (d, c, b, a) m
-> Pat (d, c, b, a) a -> Expr (d, c, b, a) b -> Lam (m -> a -> b)
Lam Pat (a, b, Any, Any) a
forall d c b a. Pat (d, c, b, a) d
P1 Pat (a, b, Any, Any) b
forall d c b a. Pat (d, c, b, a) c
P2 (c -> Expr (a, b, Any, Any) c
forall t env. Show t => t -> Expr env t
Lit c
c)) (\ a
_x b
_y -> c
c)

-- Used in compile (RExclude RRestrict cases)
rngElem:: (Ord rng,Iter f) => f rng v -> Fun(dom -> rng -> Bool)
rngElem :: f rng v -> Fun (dom -> rng -> Bool)
rngElem f rng v
realset = Lam (dom -> rng -> Bool)
-> (dom -> rng -> Bool) -> Fun (dom -> rng -> Bool)
forall t. Lam t -> t -> Fun t
Fun  (Pat (dom, rng, Any, Any) dom
-> Pat (dom, rng, Any, Any) rng
-> Expr (dom, rng, Any, Any) Bool
-> Lam (dom -> rng -> Bool)
forall d c b a m a b.
Pat (d, c, b, a) m
-> Pat (d, c, b, a) a -> Expr (d, c, b, a) b -> Lam (m -> a -> b)
Lam Pat (dom, rng, Any, Any) dom
forall d c b a. Pat (d, c, b, a) d
P1 Pat (dom, rng, Any, Any) rng
forall d c b a. Pat (d, c, b, a) c
P2 (Expr (dom, rng, Any, Any) rng
-> f rng v -> Expr (dom, rng, Any, Any) Bool
forall (f :: * -> * -> *) k e a.
(Iter f, Ord k) =>
Expr e k -> f k a -> Expr e Bool
HasKey Expr (dom, rng, Any, Any) rng
forall d c b a. Expr (d, c, b, a) c
X2 f rng v
realset)) (\ dom
_x rng
y -> rng -> f rng v -> Bool
forall (f :: * -> * -> *) key b.
(Iter f, Ord key) =>
key -> f key b -> Bool
haskey rng
y f rng v
realset)  -- x is ignored and realset is supplied

domElem:: (Ord dom,Iter f) => f dom v -> Fun(dom -> rng -> Bool)
domElem :: f dom v -> Fun (dom -> rng -> Bool)
domElem f dom v
realset = Lam (dom -> rng -> Bool)
-> (dom -> rng -> Bool) -> Fun (dom -> rng -> Bool)
forall t. Lam t -> t -> Fun t
Fun  (Pat (dom, rng, Any, Any) dom
-> Pat (dom, rng, Any, Any) rng
-> Expr (dom, rng, Any, Any) Bool
-> Lam (dom -> rng -> Bool)
forall d c b a m a b.
Pat (d, c, b, a) m
-> Pat (d, c, b, a) a -> Expr (d, c, b, a) b -> Lam (m -> a -> b)
Lam Pat (dom, rng, Any, Any) dom
forall d c b a. Pat (d, c, b, a) d
P1 Pat (dom, rng, Any, Any) rng
forall d c b a. Pat (d, c, b, a) c
P2 (Expr (dom, rng, Any, Any) dom
-> f dom v -> Expr (dom, rng, Any, Any) Bool
forall (f :: * -> * -> *) k e a.
(Iter f, Ord k) =>
Expr e k -> f k a -> Expr e Bool
HasKey Expr (dom, rng, Any, Any) dom
forall d c b a. Expr (d, c, b, a) d
X1 f dom v
realset)) (\ dom
x rng
_y -> dom -> f dom v -> Bool
forall (f :: * -> * -> *) key b.
(Iter f, Ord key) =>
key -> f key b -> Bool
haskey dom
x f dom v
realset)  -- y is ignored and realset is supplied

rngFst:: Fun(x -> (a,b) -> a)
rngFst :: Fun (x -> (a, b) -> a)
rngFst = Lam (x -> (a, b) -> a)
-> (x -> (a, b) -> a) -> Fun (x -> (a, b) -> a)
forall t. Lam t -> t -> Fun t
Fun (Pat (x, a, b, a) x
-> Pat (x, a, b, a) (a, b)
-> Expr (x, a, b, a) a
-> Lam (x -> (a, b) -> a)
forall d c b a m a b.
Pat (d, c, b, a) m
-> Pat (d, c, b, a) a -> Expr (d, c, b, a) b -> Lam (m -> a -> b)
Lam Pat (x, a, b, a) x
forall d c b a. Pat (d, c, b, a) d
P1 (Pat (x, a, b, a) a -> Pat (x, a, b, a) b -> Pat (x, a, b, a) (a, b)
forall d c b a.
Pat (d, c, b, a) a -> Pat (d, c, b, a) b -> Pat (d, c, b, a) (a, b)
PPair Pat (x, a, b, a) a
forall d c b a. Pat (d, c, b, a) c
P2 Pat (x, a, b, a) b
forall d c b a. Pat (d, c, b, a) b
P3) Expr (x, a, b, a) a
forall d c b a. Expr (d, c, b, a) c
X2) (\ x
_x (a
a,b
_b) -> a
a)

rngSnd:: Fun(x -> (a,b) -> b)
rngSnd :: Fun (x -> (a, b) -> b)
rngSnd = Lam (x -> (a, b) -> b)
-> (x -> (a, b) -> b) -> Fun (x -> (a, b) -> b)
forall t. Lam t -> t -> Fun t
Fun (Pat (x, a, b, a) x
-> Pat (x, a, b, a) (a, b)
-> Expr (x, a, b, a) b
-> Lam (x -> (a, b) -> b)
forall d c b a m a b.
Pat (d, c, b, a) m
-> Pat (d, c, b, a) a -> Expr (d, c, b, a) b -> Lam (m -> a -> b)
Lam Pat (x, a, b, a) x
forall d c b a. Pat (d, c, b, a) d
P1 (Pat (x, a, b, a) a -> Pat (x, a, b, a) b -> Pat (x, a, b, a) (a, b)
forall d c b a.
Pat (d, c, b, a) a -> Pat (d, c, b, a) b -> Pat (d, c, b, a) (a, b)
PPair Pat (x, a, b, a) a
forall d c b a. Pat (d, c, b, a) c
P2 Pat (x, a, b, a) b
forall d c b a. Pat (d, c, b, a) b
P3) Expr (x, a, b, a) b
forall d c b a. Expr (d, c, b, a) b
X3) (\ x
_x (a, b)
y -> (a, b) -> b
forall a b. (a, b) -> b
snd (a, b)
y)

compose1 :: Fun (t1 -> t2 -> t3) -> Fun (t1 -> t4 -> t2) -> Fun (t1 -> t4 -> t3)
compose1 :: Fun (t1 -> t2 -> t3)
-> Fun (t1 -> t4 -> t2) -> Fun (t1 -> t4 -> t3)
compose1 (Fun Lam (t1 -> t2 -> t3)
e1 t1 -> t2 -> t3
f1) (Fun Lam (t1 -> t4 -> t2)
e2 t1 -> t4 -> t2
f2) = Lam (t1 -> t4 -> t3) -> (t1 -> t4 -> t3) -> Fun (t1 -> t4 -> t3)
forall t. Lam t -> t -> Fun t
Fun (Pat (t1, t4, Any, Any) t1
-> Pat (t1, t4, Any, Any) t4
-> Expr (t1, t4, Any, Any) t3
-> Lam (t1 -> t4 -> t3)
forall d c b a m a b.
Pat (d, c, b, a) m
-> Pat (d, c, b, a) a -> Expr (d, c, b, a) b -> Lam (m -> a -> b)
Lam Pat (t1, t4, Any, Any) t1
forall d c b a. Pat (d, c, b, a) d
P1 Pat (t1, t4, Any, Any) t4
forall d c b a. Pat (d, c, b, a) c
P2 (Lam (t1 -> t2 -> t3)
-> Expr (t1, t4, Any, Any) t1
-> Expr (t1, t4, Any, Any) t2
-> Expr (t1, t4, Any, Any) t3
forall a b c e.
Lam (a -> b -> c) -> Expr e a -> Expr e b -> Expr e c
Ap Lam (t1 -> t2 -> t3)
e1 Expr (t1, t4, Any, Any) t1
forall d c b a. Expr (d, c, b, a) d
X1 (Lam (t1 -> t4 -> t2)
-> Expr (t1, t4, Any, Any) t1
-> Expr (t1, t4, Any, Any) t4
-> Expr (t1, t4, Any, Any) t2
forall a b c e.
Lam (a -> b -> c) -> Expr e a -> Expr e b -> Expr e c
Ap Lam (t1 -> t4 -> t2)
e2 Expr (t1, t4, Any, Any) t1
forall d c b a. Expr (d, c, b, a) d
X1 Expr (t1, t4, Any, Any) t4
forall d c b a. Expr (d, c, b, a) c
X2))) (\ t1
a t4
b -> t1 -> t2 -> t3
f1 t1
a (t1 -> t4 -> t2
f2 t1
a t4
b))

compSndL:: Fun(k -> (a,b) -> c) -> Fun(k -> d -> a) -> Fun(k -> (d,b) -> c)
compSndL :: Fun (k -> (a, b) -> c)
-> Fun (k -> d -> a) -> Fun (k -> (d, b) -> c)
compSndL (Fun Lam (k -> (a, b) -> c)
m k -> (a, b) -> c
mf) (Fun Lam (k -> d -> a)
g k -> d -> a
mg) = Lam (k -> (d, b) -> c)
-> (k -> (d, b) -> c) -> Fun (k -> (d, b) -> c)
forall t. Lam t -> t -> Fun t
Fun (Pat (k, d, b, d) k
-> Pat (k, d, b, d) (d, b)
-> Expr (k, d, b, d) c
-> Lam (k -> (d, b) -> c)
forall d c b a m a b.
Pat (d, c, b, a) m
-> Pat (d, c, b, a) a -> Expr (d, c, b, a) b -> Lam (m -> a -> b)
Lam Pat (k, d, b, d) k
forall d c b a. Pat (d, c, b, a) d
P1 (Pat (k, d, b, d) d -> Pat (k, d, b, d) b -> Pat (k, d, b, d) (d, b)
forall d c b a.
Pat (d, c, b, a) a -> Pat (d, c, b, a) b -> Pat (d, c, b, a) (a, b)
PPair Pat (k, d, b, d) d
forall d c b a. Pat (d, c, b, a) c
P2 Pat (k, d, b, d) b
forall d c b a. Pat (d, c, b, a) b
P3) (Lam (k -> (a, b) -> c)
-> Expr (k, d, b, d) k
-> Expr (k, d, b, d) (a, b)
-> Expr (k, d, b, d) c
forall a b c e.
Lam (a -> b -> c) -> Expr e a -> Expr e b -> Expr e c
Ap Lam (k -> (a, b) -> c)
m Expr (k, d, b, d) k
forall d c b a. Expr (d, c, b, a) d
X1 (Expr (k, d, b, d) a
-> Expr (k, d, b, d) b -> Expr (k, d, b, d) (a, b)
forall e a b. Expr e a -> Expr e b -> Expr e (a, b)
EPair (Lam (k -> d -> a)
-> Expr (k, d, b, d) k
-> Expr (k, d, b, d) d
-> Expr (k, d, b, d) a
forall a b c e.
Lam (a -> b -> c) -> Expr e a -> Expr e b -> Expr e c
Ap Lam (k -> d -> a)
g Expr (k, d, b, d) k
forall d c b a. Expr (d, c, b, a) d
X1 Expr (k, d, b, d) d
forall d c b a. Expr (d, c, b, a) c
X2) Expr (k, d, b, d) b
forall d c b a. Expr (d, c, b, a) b
X3))) (\ k
x (d
a,b
b) -> k -> (a, b) -> c
mf k
x (k -> d -> a
mg k
x d
a,b
b))

compSndR:: Fun(k -> (a,b) -> c) -> Fun(k -> d -> b) -> Fun(k -> (a,d) -> c)
compSndR :: Fun (k -> (a, b) -> c)
-> Fun (k -> d -> b) -> Fun (k -> (a, d) -> c)
compSndR (Fun Lam (k -> (a, b) -> c)
m k -> (a, b) -> c
mf) (Fun Lam (k -> d -> b)
g k -> d -> b
mg) = (Lam (k -> (a, d) -> c)
-> (k -> (a, d) -> c) -> Fun (k -> (a, d) -> c)
forall t. Lam t -> t -> Fun t
Fun (Pat (k, a, d, a) k
-> Pat (k, a, d, a) (a, d)
-> Expr (k, a, d, a) c
-> Lam (k -> (a, d) -> c)
forall d c b a m a b.
Pat (d, c, b, a) m
-> Pat (d, c, b, a) a -> Expr (d, c, b, a) b -> Lam (m -> a -> b)
Lam Pat (k, a, d, a) k
forall d c b a. Pat (d, c, b, a) d
P1 (Pat (k, a, d, a) a -> Pat (k, a, d, a) d -> Pat (k, a, d, a) (a, d)
forall d c b a.
Pat (d, c, b, a) a -> Pat (d, c, b, a) b -> Pat (d, c, b, a) (a, b)
PPair Pat (k, a, d, a) a
forall d c b a. Pat (d, c, b, a) c
P2 Pat (k, a, d, a) d
forall d c b a. Pat (d, c, b, a) b
P3) (Lam (k -> (a, b) -> c)
-> Expr (k, a, d, a) k
-> Expr (k, a, d, a) (a, b)
-> Expr (k, a, d, a) c
forall a b c e.
Lam (a -> b -> c) -> Expr e a -> Expr e b -> Expr e c
Ap Lam (k -> (a, b) -> c)
m Expr (k, a, d, a) k
forall d c b a. Expr (d, c, b, a) d
X1 (Expr (k, a, d, a) a
-> Expr (k, a, d, a) b -> Expr (k, a, d, a) (a, b)
forall e a b. Expr e a -> Expr e b -> Expr e (a, b)
EPair Expr (k, a, d, a) a
forall d c b a. Expr (d, c, b, a) c
X2 (Lam (k -> d -> b)
-> Expr (k, a, d, a) k
-> Expr (k, a, d, a) d
-> Expr (k, a, d, a) b
forall a b c e.
Lam (a -> b -> c) -> Expr e a -> Expr e b -> Expr e c
Ap Lam (k -> d -> b)
g Expr (k, a, d, a) k
forall d c b a. Expr (d, c, b, a) d
X1 Expr (k, a, d, a) d
forall d c b a. Expr (d, c, b, a) b
X3)))) (\ k
x (a
a,d
b) -> k -> (a, b) -> c
mf k
x (a
a,k -> d -> b
mg k
x d
b)))

compCurryR :: Fun(k -> (a,b) -> d) -> Fun(a -> c -> b) -> Fun(k -> (a,c) -> d)
compCurryR :: Fun (k -> (a, b) -> d)
-> Fun (a -> c -> b) -> Fun (k -> (a, c) -> d)
compCurryR (Fun Lam (k -> (a, b) -> d)
ef k -> (a, b) -> d
f) (Fun Lam (a -> c -> b)
eg a -> c -> b
g) = Lam (k -> (a, c) -> d)
-> (k -> (a, c) -> d) -> Fun (k -> (a, c) -> d)
forall t. Lam t -> t -> Fun t
Fun (Pat (k, a, c, a) k
-> Pat (k, a, c, a) (a, c)
-> Expr (k, a, c, a) d
-> Lam (k -> (a, c) -> d)
forall d c b a m a b.
Pat (d, c, b, a) m
-> Pat (d, c, b, a) a -> Expr (d, c, b, a) b -> Lam (m -> a -> b)
Lam Pat (k, a, c, a) k
forall d c b a. Pat (d, c, b, a) d
P1 (Pat (k, a, c, a) a -> Pat (k, a, c, a) c -> Pat (k, a, c, a) (a, c)
forall d c b a.
Pat (d, c, b, a) a -> Pat (d, c, b, a) b -> Pat (d, c, b, a) (a, b)
PPair Pat (k, a, c, a) a
forall d c b a. Pat (d, c, b, a) c
P2 Pat (k, a, c, a) c
forall d c b a. Pat (d, c, b, a) b
P3) (Lam (k -> (a, b) -> d)
-> Expr (k, a, c, a) k
-> Expr (k, a, c, a) (a, b)
-> Expr (k, a, c, a) d
forall a b c e.
Lam (a -> b -> c) -> Expr e a -> Expr e b -> Expr e c
Ap Lam (k -> (a, b) -> d)
ef Expr (k, a, c, a) k
forall d c b a. Expr (d, c, b, a) d
X1 (Expr (k, a, c, a) a
-> Expr (k, a, c, a) b -> Expr (k, a, c, a) (a, b)
forall e a b. Expr e a -> Expr e b -> Expr e (a, b)
EPair Expr (k, a, c, a) a
forall d c b a. Expr (d, c, b, a) c
X2 (Lam (a -> c -> b)
-> Expr (k, a, c, a) a
-> Expr (k, a, c, a) c
-> Expr (k, a, c, a) b
forall a b c e.
Lam (a -> b -> c) -> Expr e a -> Expr e b -> Expr e c
Ap Lam (a -> c -> b)
eg Expr (k, a, c, a) a
forall d c b a. Expr (d, c, b, a) c
X2 Expr (k, a, c, a) c
forall d c b a. Expr (d, c, b, a) b
X3)))) (\ k
x (a
a,c
b) -> k -> (a, b) -> d
f k
x(a
a,a -> c -> b
g a
a c
b))

nEgate:: Fun(k -> v -> Bool) -> Fun(k -> v -> Bool)
nEgate :: Fun (k -> v -> Bool) -> Fun (k -> v -> Bool)
nEgate (Fun Lam (k -> v -> Bool)
ef k -> v -> Bool
f) = Lam (k -> v -> Bool) -> (k -> v -> Bool) -> Fun (k -> v -> Bool)
forall t. Lam t -> t -> Fun t
Fun (Pat (k, v, Any, Any) k
-> Pat (k, v, Any, Any) v
-> Expr (k, v, Any, Any) Bool
-> Lam (k -> v -> Bool)
forall d c b a m a b.
Pat (d, c, b, a) m
-> Pat (d, c, b, a) a -> Expr (d, c, b, a) b -> Lam (m -> a -> b)
Lam Pat (k, v, Any, Any) k
forall d c b a. Pat (d, c, b, a) d
P1 Pat (k, v, Any, Any) v
forall d c b a. Pat (d, c, b, a) c
P2 (Expr (k, v, Any, Any) Bool -> Expr (k, v, Any, Any) Bool
forall e. Expr e Bool -> Expr e Bool
Neg (Lam (k -> v -> Bool)
-> Expr (k, v, Any, Any) k
-> Expr (k, v, Any, Any) v
-> Expr (k, v, Any, Any) Bool
forall a b c e.
Lam (a -> b -> c) -> Expr e a -> Expr e b -> Expr e c
Ap Lam (k -> v -> Bool)
ef Expr (k, v, Any, Any) k
forall d c b a. Expr (d, c, b, a) d
X1 Expr (k, v, Any, Any) v
forall d c b a. Expr (d, c, b, a) c
X2))) (\ k
x v
y -> Bool -> Bool
not(k -> v -> Bool
f k
x v
y))

always:: Fun(a -> b -> Bool)
always :: Fun (a -> b -> Bool)
always = Bool -> Fun (a -> b -> Bool)
forall c a b. Show c => c -> Fun (a -> b -> c)
constant Bool
True

both:: Fun(a -> b -> Bool) -> Fun(a -> b -> Bool) -> Fun(a -> b -> Bool)
both :: Fun (a -> b -> Bool)
-> Fun (a -> b -> Bool) -> Fun (a -> b -> Bool)
both (Fun Lam (a -> b -> Bool)
ef a -> b -> Bool
e) (Fun Lam (a -> b -> Bool)
ff a -> b -> Bool
f) = Lam (a -> b -> Bool) -> (a -> b -> Bool) -> Fun (a -> b -> Bool)
forall t. Lam t -> t -> Fun t
Fun (Pat (a, b, Any, Any) a
-> Pat (a, b, Any, Any) b
-> Expr (a, b, Any, Any) Bool
-> Lam (a -> b -> Bool)
forall d c b a m a b.
Pat (d, c, b, a) m
-> Pat (d, c, b, a) a -> Expr (d, c, b, a) b -> Lam (m -> a -> b)
Lam Pat (a, b, Any, Any) a
forall d c b a. Pat (d, c, b, a) d
P1 Pat (a, b, Any, Any) b
forall d c b a. Pat (d, c, b, a) c
P2 (Lam (Bool -> Bool -> Bool)
-> Expr (a, b, Any, Any) Bool
-> Expr (a, b, Any, Any) Bool
-> Expr (a, b, Any, Any) Bool
forall a b c e.
Lam (a -> b -> c) -> Expr e a -> Expr e b -> Expr e c
Ap Lam (Bool -> Bool -> Bool)
Both (Lam (a -> b -> Bool)
-> Expr (a, b, Any, Any) a
-> Expr (a, b, Any, Any) b
-> Expr (a, b, Any, Any) Bool
forall a b c e.
Lam (a -> b -> c) -> Expr e a -> Expr e b -> Expr e c
Ap Lam (a -> b -> Bool)
ef Expr (a, b, Any, Any) a
forall d c b a. Expr (d, c, b, a) d
X1 Expr (a, b, Any, Any) b
forall d c b a. Expr (d, c, b, a) c
X2) (Lam (a -> b -> Bool)
-> Expr (a, b, Any, Any) a
-> Expr (a, b, Any, Any) b
-> Expr (a, b, Any, Any) Bool
forall a b c e.
Lam (a -> b -> c) -> Expr e a -> Expr e b -> Expr e c
Ap Lam (a -> b -> Bool)
ff Expr (a, b, Any, Any) a
forall d c b a. Expr (d, c, b, a) d
X1 Expr (a, b, Any, Any) b
forall d c b a. Expr (d, c, b, a) c
X2)))  (\ a
a b
b -> (a -> b -> Bool
e a
a b
b) Bool -> Bool -> Bool
&& (a -> b -> Bool
f a
a b
b))

lift :: (a -> b -> c) -> Fun (a -> b -> c)  -- This is used in the tests, not good to use it elsewhere.
lift :: (a -> b -> c) -> Fun (a -> b -> c)
lift a -> b -> c
f = Lam (a -> b -> c) -> (a -> b -> c) -> Fun (a -> b -> c)
forall t. Lam t -> t -> Fun t
Fun ((a -> b -> c) -> Lam (a -> b -> c)
forall a b c. (a -> b -> c) -> Lam (a -> b -> c)
Lift a -> b -> c
f) a -> b -> c
f



-- ============================================================================================
-- | Given a BaseRep we can 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 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 v. Ord k => k -> v -> Map k v -> Map k v
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)

-- ================================================================================
-- On the flip side, a witness can be used to specifiy how to build a 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

-- =========================================================================================
-- 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

-- =================================================================================
-- Query is a single datatype that incorporates a language that describes how to build
-- compound iterators, from other iterators.
-- =================================================================================

data Query k v where
   BaseD :: (Iter f,Ord k) => BaseRep f k v -> f k v -> Query k v
   ProjectD :: Ord k => Query k v -> Fun (k -> v -> u) -> Query k u
   AndD :: Ord k => Query k v -> Query k w -> Query k (v,w)
   ChainD:: (Ord k,Ord v) => Query k v -> Query v w -> Fun(k -> (v,w) -> u) -> Query k u
   AndPD::  Ord k => Query k v -> Query k u -> Fun(k -> (v,u) -> w) -> Query k w
   OrD:: Ord k => Query k v -> Query k v -> Fun(v -> v -> v) -> Query k v
   GuardD:: Ord k => Query k v -> Fun (k -> v -> Bool) -> Query k v
   DiffD :: Ord k => Query k v -> Query k u -> Query k v

-- ======================================================================================
-- smart constructors for Query. These apply semantic preserving rewrites when applicable
-- ======================================================================================

smart :: Bool
smart :: Bool
smart = Bool
True  -- for debugging purposes, this can be set to False, in which case no rewrites occurr.

projD ::  Ord k => Query k v -> Fun (k -> v -> u) -> Query k u
projD :: Query k v -> Fun (k -> v -> u) -> Query k u
projD Query k v
x Fun (k -> v -> u)
y = case (Query k v
x,Fun (k -> v -> u)
y) of
   (ProjectD Query k v
f Fun (k -> v -> v)
p, Fun (k -> v -> u)
q) | Bool
smart -> Query k v -> Fun (k -> v -> u) -> Query k u
forall k v u. Ord k => Query k v -> Fun (k -> v -> u) -> Query k u
projD Query k v
f (Fun (k -> v -> u) -> Fun (k -> v -> v) -> Fun (k -> v -> u)
forall t1 t2 t3 t4.
Fun (t1 -> t2 -> t3)
-> Fun (t1 -> t4 -> t2) -> Fun (t1 -> t4 -> t3)
compose1 Fun (k -> v -> u)
q Fun (k -> v -> v)
p)
   (AndD Query k v
f Query k w
g,Fun (k -> v -> u)
q) | Bool
smart -> Query k v -> Query k w -> Fun (k -> (v, w) -> u) -> Query k u
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
f Query k w
g (Fun (k -> v -> u) -> Fun (k -> v -> v) -> Fun (k -> v -> u)
forall t1 t2 t3 t4.
Fun (t1 -> t2 -> t3)
-> Fun (t1 -> t4 -> t2) -> Fun (t1 -> t4 -> t3)
compose1 Fun (k -> v -> u)
q Fun (k -> v -> v)
forall v s. Fun (v -> s -> s)
second)
   (AndPD Query k v
f Query k u
g Fun (k -> (v, u) -> v)
p, Fun (k -> v -> u)
q) | Bool
smart -> Query k v -> Query k u -> Fun (k -> (v, u) -> u) -> Query k u
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
f Query k u
g (Fun (k -> v -> u)
-> Fun (k -> (v, u) -> v) -> Fun (k -> (v, u) -> u)
forall t1 t2 t3 t4.
Fun (t1 -> t2 -> t3)
-> Fun (t1 -> t4 -> t2) -> Fun (t1 -> t4 -> t3)
compose1 Fun (k -> v -> u)
q Fun (k -> (v, u) -> v)
p)
   (Query k v
f, Fun (k -> v -> u)
p) -> Query k v -> Fun (k -> v -> u) -> Query k u
forall k v u. Ord k => Query k v -> Fun (k -> v -> u) -> Query k u
ProjectD Query k v
f Fun (k -> v -> u)
p

andD :: Ord k => Query k v1 -> Query k v2 -> Query k (v1, v2)
andD :: Query k v1 -> Query k v2 -> Query k (v1, v2)
andD (ProjectD Query k v
f Fun (k -> v -> v1)
p) Query k v2
g | Bool
smart = Query k v
-> Query k v2 -> Fun (k -> (v, v2) -> (v1, v2)) -> Query k (v1, v2)
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
f Query k v2
g (Fun (k -> (v1, v2) -> (v1, v2))
-> Fun (k -> v -> v1) -> Fun (k -> (v, v2) -> (v1, v2))
forall k a b c d.
Fun (k -> (a, b) -> c)
-> Fun (k -> d -> a) -> Fun (k -> (d, b) -> c)
compSndL Fun (k -> (v1, v2) -> (v1, v2))
forall v s. Fun (v -> s -> s)
second Fun (k -> v -> v1)
p)
andD Query k v1
f (ProjectD Query k v
g Fun (k -> v -> v2)
p) | Bool
smart = Query k v1
-> Query k v -> Fun (k -> (v1, v) -> (v1, v2)) -> Query k (v1, v2)
forall k v1 u v.
Ord k =>
Query k v1 -> Query k u -> Fun (k -> (v1, u) -> v) -> Query k v
AndPD Query k v1
f Query k v
g (Fun (k -> (v1, v2) -> (v1, v2))
-> Fun (k -> v -> v2) -> Fun (k -> (v1, v) -> (v1, v2))
forall k a b c d.
Fun (k -> (a, b) -> c)
-> Fun (k -> d -> b) -> Fun (k -> (a, d) -> c)
compSndR Fun (k -> (v1, v2) -> (v1, v2))
forall v s. Fun (v -> s -> s)
second Fun (k -> v -> v2)
p)
andD Query k v1
f Query k v2
g = Query k v1 -> Query k v2 -> Query k (v1, v2)
forall k v w. Ord k => Query k v -> Query k w -> Query k (v, w)
AndD Query k v1
f Query k v2
g

andPD :: Ord k => Query k v1 -> Query k u -> Fun (k -> (v1, u) -> v) -> Query k v
andPD :: Query k v1 -> Query k u -> Fun (k -> (v1, u) -> v) -> Query k v
andPD (ProjectD Query k v
f Fun (k -> v -> v1)
p) Query k u
g Fun (k -> (v1, u) -> v)
q | Bool
smart = Query k v -> Query k u -> Fun (k -> (v, u) -> v) -> Query k v
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
f Query k u
g (Fun (k -> (v1, u) -> v)
-> Fun (k -> v -> v1) -> Fun (k -> (v, u) -> v)
forall k a b c d.
Fun (k -> (a, b) -> c)
-> Fun (k -> d -> a) -> Fun (k -> (d, b) -> c)
compSndL Fun (k -> (v1, u) -> v)
q Fun (k -> v -> v1)
p)
andPD Query k v1
f Query k u
g Fun (k -> (v1, u) -> v)
p = Query k v1 -> Query k u -> Fun (k -> (v1, u) -> v) -> Query k v
forall k v1 u v.
Ord k =>
Query k v1 -> Query k u -> Fun (k -> (v1, u) -> v) -> Query k v
AndPD Query k v1
f Query k u
g Fun (k -> (v1, u) -> v)
p

chainD :: (Ord k,Ord v) => Query k v -> Query v w -> Fun (k -> (v, w) -> u) -> Query k u
chainD :: Query k v -> Query v w -> Fun (k -> (v, w) -> u) -> Query k u
chainD Query k v
f (ProjectD Query v v
g Fun (v -> v -> w)
p) Fun (k -> (v, w) -> u)
q | Bool
smart = Query k v -> Query v v -> Fun (k -> (v, v) -> u) -> Query k u
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
f Query v v
g (Fun (k -> (v, w) -> u)
-> Fun (v -> v -> w) -> Fun (k -> (v, v) -> u)
forall k a b d c.
Fun (k -> (a, b) -> d)
-> Fun (a -> c -> b) -> Fun (k -> (a, c) -> d)
compCurryR Fun (k -> (v, w) -> u)
q Fun (v -> v -> w)
p)
chainD Query k v
f Query v w
g Fun (k -> (v, w) -> u)
p = Query k v -> Query v w -> Fun (k -> (v, w) -> u) -> Query k u
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
f Query v w
g Fun (k -> (v, w) -> u)
p

guardD :: Ord k => Query k v -> Fun (k -> v -> Bool) -> Query k v
guardD :: Query k v -> Fun (k -> v -> Bool) -> Query k v
guardD (GuardD Query k v
q1 Fun (k -> v -> Bool)
test1) Fun (k -> v -> Bool)
test2 | Bool
smart = 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
q1 (Fun (k -> v -> Bool)
-> Fun (k -> v -> Bool) -> Fun (k -> v -> Bool)
forall a b.
Fun (a -> b -> Bool)
-> Fun (a -> b -> Bool) -> Fun (a -> b -> Bool)
both Fun (k -> v -> Bool)
test1 Fun (k -> v -> Bool)
test2)
guardD Query k v
qry Fun (k -> v -> Bool)
test = 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
qry Fun (k -> v -> Bool)
test



-- ================================================================================
-- | 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).
-- ================================================================================

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)

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 (Query k v -> Sett v ()
forall v k. Ord v => Query k v -> Sett v ()
rngStep ((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))),BaseRep f k v
forall k. Basic Sett => BaseRep Sett k ()
SetR)  -- We really ought to memoize this. It might be computed many times.
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 v w. Ord k => Query k v -> Query k w -> Query k (v, w)
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 (f 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 f k n) -> Query k n
forall a b. (a, b) -> a
fst(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)
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

-- ===========================================================================
-- run materializes compiled code, only if it is not already data
-- ===========================================================================

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

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] -> ShowS
forall a. [a] -> [a] -> [a]
++Exp (f k v) -> [Char]
forall a. Show a => a -> [Char]
show Exp (f k v)
e[Char] -> ShowS
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)

-- 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)

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 compund 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

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] -> ShowS
forall a. [a] -> [a] -> [a]
++Exp Bool -> [Char]
forall a. Show a => a -> [Char]
show Exp Bool
e[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
" falls through to slow mode.")
       else Exp Bool -> Bool
runBool Exp Bool
e

-- Only for use inthe SetAlgebra internal tests
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


-- ==============================================================================================
-- 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
uk -> 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
uk -> 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 (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

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 (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

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

-- 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
v2k -> 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 (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

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 (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

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
compute (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

-- (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
xk -> 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 key b. Ord key => key -> Map key b -> 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 (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

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
kk -> k -> Bool
forall a. Eq a => a -> a -> Bool
==k
k
key
compute (Elem k
k (Rng (Singleton k
_ v
key))) = k
kk -> k -> Bool
forall a. Eq a => a -> a -> Bool
==k
v
key
compute (Elem k
k (SetSingleton k
key)) = k
kk -> 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 (e :: Exp t
e@(Elem k
_ Exp (g k ())
_)) = Exp Bool -> Bool
runBoolExp Exp t
Exp Bool
e

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
kk -> 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
kk -> 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
kk -> 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 (e :: Exp t
e@(NotElem k
_ Exp (g k ())
_)) = Exp Bool -> Bool
runBoolExp Exp t
Exp Bool
e

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 key b. Ord key => key -> Map key b -> 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 key b. Ord key => key -> Map key b -> 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 key b. Ord key => key -> Map key b -> 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 key b. Ord key => key -> Map key b -> Bool
Map.member k
k f k v
Map k v
y Bool -> Bool -> Bool
&& Bool
ans
compute (e :: Exp t
e@(Subset Exp (f k v)
_ Exp (g k u)
_)) = Exp Bool -> Bool
runBoolExp Exp t
Exp Bool
e

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 (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

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 key b. Ord key => key -> Map key b -> 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 key b. Ord key => key -> Map key b -> 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 (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

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 v. Ord k => k -> Map k v -> Map k v
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 (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

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 (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

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 (e :: Exp t
e@(UnionPlus Exp (f k n)
_ Exp (f 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

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
nSet 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 (e :: Exp t
e@(KeyEqual Exp (f k v)
_ Exp (g k u)
_ )) = Exp Bool -> Bool
runBoolExp Exp t
Exp Bool
e

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)

-- ==============================================================================================
-- To make compound iterators, i.e. instance (Iter Query), we need "step" functions for each kind
-- ==============================================================================================

-- ==== Project ====
projStep
  :: Ord k =>
     (t -> Collect (k, v, Query k v))
     -> Fun (k -> v -> u) -> t -> Collect (k, u, Query k u)
projStep :: (t -> Collect (k, v, Query k v))
-> Fun (k -> v -> u) -> t -> Collect (k, u, Query k u)
projStep t -> Collect (k, v, Query k v)
next Fun (k -> v -> u)
p t
f = do { (k
k,v
v,Query k v
f') <- t -> Collect (k, v, Query k v)
next t
f; (k, u, Query k u) -> Collect (k, u, Query k u)
forall t. t -> Collect t
one (k
k,Fun (k -> v -> u) -> k -> v -> u
forall t. Fun t -> t
apply Fun (k -> v -> u)
p k
k v
v,Query k v -> Fun (k -> v -> u) -> Query k u
forall k v u. Ord k => Query k v -> Fun (k -> v -> u) -> Query k u
ProjectD Query k v
f' Fun (k -> v -> u)
p) }

-- ===== And = ====
andStep
  :: Ord a =>
     (a, b1, Query a b1)
     -> (a, b2, Query a b2) -> Collect (a, (b1, b2), Query a (b1, b2))
andStep :: (a, b1, Query a b1)
-> (a, b2, Query a b2) -> Collect (a, (b1, b2), Query a (b1, b2))
andStep (ftrip :: (a, b1, Query a b1)
ftrip@(a
k1,b1
v1,Query a b1
f1)) (gtrip :: (a, b2, Query a b2)
gtrip@(a
k2,b2
v2,Query a b2
g2)) =
   case a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
k1 a
k2 of
      Ordering
EQ -> (a, (b1, b2), Query a (b1, b2))
-> Collect (a, (b1, b2), Query a (b1, b2))
forall t. t -> Collect t
one (a
k1,(b1
v1,b2
v2), Query a b1 -> Query a b2 -> Query a (b1, b2)
forall k v w. Ord k => Query k v -> Query k w -> Query k (v, w)
AndD Query a b1
f1 Query a b2
g2)
      Ordering
LT -> do { (a, b1, Query a b1)
ftrip' <- a -> Query a b1 -> Collect (a, b1, Query a b1)
forall a b. Ord a => a -> Query a b -> Collect (a, b, Query a b)
lubQuery a
k2 Query a b1
f1; (a, b1, Query a b1)
-> (a, b2, Query a b2) -> Collect (a, (b1, b2), Query a (b1, b2))
forall a b1 b2.
Ord a =>
(a, b1, Query a b1)
-> (a, b2, Query a b2) -> Collect (a, (b1, b2), Query a (b1, b2))
andStep (a, b1, Query a b1)
ftrip' (a, b2, Query a b2)
gtrip  }
      Ordering
GT -> do { (a, b2, Query a b2)
gtrip' <- a -> Query a b2 -> Collect (a, b2, Query a b2)
forall a b. Ord a => a -> Query a b -> Collect (a, b, Query a b)
lubQuery a
k1 Query a b2
g2; (a, b1, Query a b1)
-> (a, b2, Query a b2) -> Collect (a, (b1, b2), Query a (b1, b2))
forall a b1 b2.
Ord a =>
(a, b1, Query a b1)
-> (a, b2, Query a b2) -> Collect (a, (b1, b2), Query a (b1, b2))
andStep (a, b1, Query a b1)
ftrip (a, b2, Query a b2)
gtrip' }

-- ==== Chain ====
chainStep
  :: (Ord b, Ord a) =>
     (a, b, Query a b)
     -> Query b w -> Fun (a -> (b, w) -> u) -> Collect (a, u, Query a u)
chainStep :: (a, b, Query a b)
-> Query b w -> Fun (a -> (b, w) -> u) -> Collect (a, u, Query a u)
chainStep (a
d,b
r1,Query a b
f1) Query b w
g Fun (a -> (b, w) -> u)
comb =
   case b -> Query b w -> Maybe w
forall (f :: * -> * -> *) key rng.
(Iter f, Ord key) =>
key -> f key rng -> Maybe rng
lookup b
r1 Query b w
g of   -- recall that the values 'r1' from f, are not iterated in ascending order, only the keys 'd' are ascending
     Just w
w -> (a, u, Query a u) -> Collect (a, u, Query a u)
forall t. t -> Collect t
one(a
d,Fun (a -> (b, w) -> u) -> a -> (b, w) -> u
forall t. Fun t -> t
apply Fun (a -> (b, w) -> u)
comb a
d (b
r1,w
w),Query a b -> Query b w -> Fun (a -> (b, w) -> u) -> Query a u
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 a b
f1 Query b w
g Fun (a -> (b, w) -> u)
comb)
     Maybe w
Nothing -> do { (a, b, Query a b)
trip <- Query a b -> Collect (a, b, Query a b)
forall a b. Query a b -> Collect (a, b, Query a b)
nxtQuery Query a b
f1; (a, b, Query a b)
-> Query b w -> Fun (a -> (b, w) -> u) -> Collect (a, u, Query a u)
forall b a w u.
(Ord b, Ord a) =>
(a, b, Query a b)
-> Query b w -> Fun (a -> (b, w) -> u) -> Collect (a, u, Query a u)
chainStep (a, b, Query a b)
trip Query b w
g Fun (a -> (b, w) -> u)
comb}


-- ==== And with Projection ====
andPstep
  :: Ord a =>
     (a, b1, Query a b1)
     -> (a, b2, Query a b2)
     -> Fun (a -> (b1, b2) -> w)
     -> Collect (a, w, Query a w)
andPstep :: (a, b1, Query a b1)
-> (a, b2, Query a b2)
-> Fun (a -> (b1, b2) -> w)
-> Collect (a, w, Query a w)
andPstep (ftrip :: (a, b1, Query a b1)
ftrip@(a
k1,b1
v1,Query a b1
f1)) (gtrip :: (a, b2, Query a b2)
gtrip@(a
k2,b2
v2,Query a b2
g2)) Fun (a -> (b1, b2) -> w)
p =
   case a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
k1 a
k2 of
      Ordering
EQ -> (a, w, Query a w) -> Collect (a, w, Query a w)
forall t. t -> Collect t
one (a
k1,(Fun (a -> (b1, b2) -> w) -> a -> (b1, b2) -> w
forall t. Fun t -> t
apply Fun (a -> (b1, b2) -> w)
p a
k1 (b1
v1,b2
v2)), Query a b1 -> Query a b2 -> Fun (a -> (b1, b2) -> w) -> Query a w
forall k v1 u v.
Ord k =>
Query k v1 -> Query k u -> Fun (k -> (v1, u) -> v) -> Query k v
AndPD Query a b1
f1 Query a b2
g2 Fun (a -> (b1, b2) -> w)
p)
      Ordering
LT -> do { (a, b1, Query a b1)
ftrip' <- a -> Query a b1 -> Collect (a, b1, Query a b1)
forall a b. Ord a => a -> Query a b -> Collect (a, b, Query a b)
lubQuery a
k2 Query a b1
f1; (a, b1, Query a b1)
-> (a, b2, Query a b2)
-> Fun (a -> (b1, b2) -> w)
-> Collect (a, w, Query a w)
forall a b1 b2 w.
Ord a =>
(a, b1, Query a b1)
-> (a, b2, Query a b2)
-> Fun (a -> (b1, b2) -> w)
-> Collect (a, w, Query a w)
andPstep (a, b1, Query a b1)
ftrip' (a, b2, Query a b2)
gtrip Fun (a -> (b1, b2) -> w)
p }
      Ordering
GT -> do { (a, b2, Query a b2)
gtrip' <- a -> Query a b2 -> Collect (a, b2, Query a b2)
forall a b. Ord a => a -> Query a b -> Collect (a, b, Query a b)
lubQuery a
k1 Query a b2
g2; (a, b1, Query a b1)
-> (a, b2, Query a b2)
-> Fun (a -> (b1, b2) -> w)
-> Collect (a, w, Query a w)
forall a b1 b2 w.
Ord a =>
(a, b1, Query a b1)
-> (a, b2, Query a b2)
-> Fun (a -> (b1, b2) -> w)
-> Collect (a, w, Query a w)
andPstep (a, b1, Query a b1)
ftrip (a, b2, Query a b2)
gtrip' Fun (a -> (b1, b2) -> w)
p }

-- ==== Or with combine ====
orStep
  :: (Ord k, Ord a) =>
     (Query k v -> Collect (a, v, Query k v))
     -> Query k v
     -> Query k v
     -> Fun (v -> v -> v)
     -> Collect (a, v, Query k v)
orStep :: (Query k v -> Collect (a, v, Query k v))
-> Query k v
-> Query k v
-> Fun (v -> v -> v)
-> Collect (a, v, Query k v)
orStep Query k v -> Collect (a, v, Query k v)
next Query k v
f Query k v
g Fun (v -> v -> v)
comb =
   case (Collect (a, v, Query k v) -> Maybe (a, v, Query k v)
forall t. Collect t -> Maybe t
hasElem (Query k v -> Collect (a, v, Query k v)
next Query k v
f), Collect (a, v, Query k v) -> Maybe (a, v, Query k v)
forall t. Collect t -> Maybe t
hasElem (Query k v -> Collect (a, v, Query k v)
next Query k v
g)) of   -- We have to be careful, because if only one has a nxt, there is still an answer
      (Maybe (a, v, Query k v)
Nothing,Maybe (a, v, Query k v)
Nothing) -> Collect (a, v, Query k v)
forall t. Collect t
none
      (Just(a
k1,v
v1,Query k v
f1),Maybe (a, v, Query k v)
Nothing) -> (a, v, Query k v) -> Collect (a, v, Query k v)
forall t. t -> Collect t
one (a
k1,v
v1,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
f1 Query k v
g Fun (v -> v -> v)
comb)
      (Maybe (a, v, Query k v)
Nothing,Just(a
k1,v
v1,Query k v
g1)) -> (a, v, Query k v) -> Collect (a, v, Query k v)
forall t. t -> Collect t
one (a
k1,v
v1,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
f Query k v
g1 Fun (v -> v -> v)
comb)
      (Just(a
k1,v
v1,Query k v
f1),Just(a
k2,v
v2,Query k v
g2)) ->
        case a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
k1 a
k2 of
           Ordering
EQ -> (a, v, Query k v) -> Collect (a, v, Query k v)
forall t. t -> Collect t
one (a
k1,Fun (v -> v -> v) -> v -> v -> v
forall t. Fun t -> t
apply Fun (v -> v -> v)
comb v
v1 v
v2,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
f1 Query k v
g2 Fun (v -> v -> v)
comb)
           Ordering
LT -> (a, v, Query k v) -> Collect (a, v, Query k v)
forall t. t -> Collect t
one (a
k1,v
v1,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
f1 Query k v
g Fun (v -> v -> v)
comb)
           Ordering
GT -> (a, v, Query k v) -> Collect (a, v, Query k v)
forall t. t -> Collect t
one (a
k2,v
v2,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
f Query k v
g2 Fun (v -> v -> v)
comb)

-- ===== Guard =====
guardStep
  :: Ord a =>
     (Query a b -> Collect (a, b, Query a b))
     -> Fun (a -> b -> Bool) -> Query a b -> Collect (a, b, Query a b)
guardStep :: (Query a b -> Collect (a, b, Query a b))
-> Fun (a -> b -> Bool) -> Query a b -> Collect (a, b, Query a b)
guardStep Query a b -> Collect (a, b, Query a b)
next Fun (a -> b -> Bool)
p Query a b
f = do { (a, b, Query a b)
triple <- Query a b -> Collect (a, b, Query a b)
next Query a b
f; (a, b, Query a b) -> Collect (a, b, Query a b)
loop (a, b, Query a b)
triple }
   where loop :: (a, b, Query a b) -> Collect (a, b, Query a b)
loop (a
k,b
v,Query a b
f') = if (Fun (a -> b -> Bool) -> a -> b -> Bool
forall t. Fun t -> t
apply Fun (a -> b -> Bool)
p a
k b
v) then (a, b, Query a b) -> Collect (a, b, Query a b)
forall t. t -> Collect t
one (a
k,b
v,Query a b -> Fun (a -> b -> Bool) -> Query a b
forall k v. Ord k => Query k v -> Fun (k -> v -> Bool) -> Query k v
GuardD Query a b
f' Fun (a -> b -> Bool)
p) else do { (a, b, Query a b)
triple <- Query a b -> Collect (a, b, Query a b)
forall a b. Query a b -> Collect (a, b, Query a b)
nxtQuery Query a b
f'; (a, b, Query a b) -> Collect (a, b, Query a b)
loop (a, b, Query a b)
triple}

-- ===== Difference by key =====
diffStep :: Ord k => (k, v, Query k v) -> Query k u -> Collect (k, v, Query k v)
diffStep :: (k, v, Query k v) -> Query k u -> Collect (k, v, Query k v)
diffStep (k
k1,v
u1,Query k v
f1) Query k u
g =
   case Collect (k, u, Query k u) -> Maybe (k, u, Query k u)
forall t. Collect t -> Maybe t
hasElem (k -> Query k u -> Collect (k, u, Query k u)
forall a b. Ord a => a -> Query a b -> Collect (a, b, Query a b)
lubQuery k
k1 Query k u
g) of
      Maybe (k, u, Query k u)
Nothing -> (k, v, Query k v) -> Collect (k, v, Query k v)
forall t. t -> Collect t
one (k
k1,v
u1,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
f1 Query k u
g)  -- g has nothing to subtract
      Just (k
k2,u
_u2,Query k u
g2) -> case k -> k -> Ordering
forall a. Ord a => a -> a -> Ordering
compare k
k1 k
k2 of
          Ordering
EQ -> do { (k, v, Query k v)
tup <- Query k v -> Collect (k, v, Query k v)
forall a b. Query a b -> Collect (a, b, Query a b)
nxtQuery Query k v
f1; (k, v, Query k v) -> Query k u -> Collect (k, v, Query k v)
forall k v u.
Ord k =>
(k, v, Query k v) -> Query k u -> Collect (k, v, Query k v)
diffStep (k, v, Query k v)
tup Query k u
g2 }
          Ordering
LT -> (k, v, Query k v) -> Collect (k, v, Query k v)
forall t. t -> Collect t
one (k
k1,v
u1,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
f1 Query k u
g)
          Ordering
GT -> (k, v, Query k v) -> Collect (k, v, Query k v)
forall t. t -> Collect t
one (k
k1,v
u1,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
f1 Query k u
g)   -- the hasLub guarantees k1 <= k2, so this case is dead code

-- ========== Rng ====================
rngStep :: Ord v => Query k v -> Sett v ()
rngStep :: Query k v -> Sett v ()
rngStep Query k v
dat = 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
dat)
  where 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) }

-- =========================== Now the Iter instance for Query ======================

nxtQuery :: Query a b -> Collect (a, b, Query a b)
nxtQuery :: Query a b -> Collect (a, b, Query a b)
nxtQuery (BaseD BaseRep f a b
rep f a b
x) = do {(a
k,b
v,f a b
x2) <- 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
x; (a, b, Query a b) -> Collect (a, b, Query a b)
forall t. t -> Collect t
one(a
k,b
v,BaseRep f a b -> f a b -> Query a b
forall (f :: * -> * -> *) k v.
(Iter f, Ord k) =>
BaseRep f k v -> f k v -> Query k v
BaseD BaseRep f a b
rep f a b
x2)}
nxtQuery (ProjectD Query a v
x Fun (a -> v -> b)
p) = (Query a v -> Collect (a, v, Query a v))
-> Fun (a -> v -> b) -> Query a v -> Collect (a, b, Query a b)
forall k t v u.
Ord k =>
(t -> Collect (k, v, Query k v))
-> Fun (k -> v -> u) -> t -> Collect (k, u, Query k u)
projStep Query a v -> Collect (a, v, Query a v)
forall a b. Query a b -> Collect (a, b, Query a b)
nxtQuery Fun (a -> v -> b)
p Query a v
x
nxtQuery (AndD Query a v
f Query a w
g) = do { (a, v, Query a v)
triple1 <- Query a v -> Collect (a, v, Query a v)
forall a b. Query a b -> Collect (a, b, Query a b)
nxtQuery Query a v
f; (a, w, Query a w)
triple2 <- Query a w -> Collect (a, w, Query a w)
forall a b. Query a b -> Collect (a, b, Query a b)
nxtQuery Query a w
g; (a, v, Query a v)
-> (a, w, Query a w) -> Collect (a, (v, w), Query a (v, w))
forall a b1 b2.
Ord a =>
(a, b1, Query a b1)
-> (a, b2, Query a b2) -> Collect (a, (b1, b2), Query a (b1, b2))
andStep (a, v, Query a v)
triple1 (a, w, Query a w)
triple2 }
nxtQuery (ChainD Query a v
f Query v w
g Fun (a -> (v, w) -> b)
p) = do { (a, v, Query a v)
trip <- Query a v -> Collect (a, v, Query a v)
forall a b. Query a b -> Collect (a, b, Query a b)
nxtQuery Query a v
f; (a, v, Query a v)
-> Query v w -> Fun (a -> (v, w) -> b) -> Collect (a, b, Query a b)
forall b a w u.
(Ord b, Ord a) =>
(a, b, Query a b)
-> Query b w -> Fun (a -> (b, w) -> u) -> Collect (a, u, Query a u)
chainStep (a, v, Query a v)
trip Query v w
g Fun (a -> (v, w) -> b)
p}
nxtQuery (AndPD Query a v
f Query a u
g Fun (a -> (v, u) -> b)
p) = do { (a, v, Query a v)
triple1 <- Query a v -> Collect (a, v, Query a v)
forall a b. Query a b -> Collect (a, b, Query a b)
nxtQuery Query a v
f; (a, u, Query a u)
triple2 <- Query a u -> Collect (a, u, Query a u)
forall a b. Query a b -> Collect (a, b, Query a b)
nxtQuery Query a u
g; (a, v, Query a v)
-> (a, u, Query a u)
-> Fun (a -> (v, u) -> b)
-> Collect (a, b, Query a b)
forall a b1 b2 w.
Ord a =>
(a, b1, Query a b1)
-> (a, b2, Query a b2)
-> Fun (a -> (b1, b2) -> w)
-> Collect (a, w, Query a w)
andPstep (a, v, Query a v)
triple1 (a, u, Query a u)
triple2 Fun (a -> (v, u) -> b)
p }
nxtQuery (OrD Query a b
f Query a b
g Fun (b -> b -> b)
comb) = (Query a b -> Collect (a, b, Query a b))
-> Query a b
-> Query a b
-> Fun (b -> b -> b)
-> Collect (a, b, Query a b)
forall k a v.
(Ord k, Ord a) =>
(Query k v -> Collect (a, v, Query k v))
-> Query k v
-> Query k v
-> Fun (v -> v -> v)
-> Collect (a, v, Query k v)
orStep Query a b -> Collect (a, b, Query a b)
forall a b. Query a b -> Collect (a, b, Query a b)
nxtQuery Query a b
f Query a b
g Fun (b -> b -> b)
comb
nxtQuery (GuardD Query a b
f Fun (a -> b -> Bool)
p) = (Query a b -> Collect (a, b, Query a b))
-> Fun (a -> b -> Bool) -> Query a b -> Collect (a, b, Query a b)
forall a b.
Ord a =>
(Query a b -> Collect (a, b, Query a b))
-> Fun (a -> b -> Bool) -> Query a b -> Collect (a, b, Query a b)
guardStep Query a b -> Collect (a, b, Query a b)
forall a b. Query a b -> Collect (a, b, Query a b)
nxtQuery Fun (a -> b -> Bool)
p Query a b
f
nxtQuery (DiffD Query a b
f Query a u
g) = do { (a, b, Query a b)
trip <- Query a b -> Collect (a, b, Query a b)
forall a b. Query a b -> Collect (a, b, Query a b)
nxtQuery Query a b
f; (a, b, Query a b) -> Query a u -> Collect (a, b, Query a b)
forall k v u.
Ord k =>
(k, v, Query k v) -> Query k u -> Collect (k, v, Query k v)
diffStep (a, b, Query a b)
trip Query a u
g }

lubQuery :: Ord a => a ->  Query a b -> Collect (a, b, Query a b)
lubQuery :: a -> Query a b -> Collect (a, b, Query a b)
lubQuery a
key (BaseD BaseRep f a b
rep f a b
x) = do {(a
k,b
v,f a b
x2) <- a -> f a b -> Collect (a, b, f a b)
forall (f :: * -> * -> *) k b.
(Iter f, Ord k) =>
k -> f k b -> Collect (k, b, f k b)
lub a
key f a b
x; (a, b, Query a b) -> Collect (a, b, Query a b)
forall t. t -> Collect t
one(a
k,b
v,BaseRep f a b -> f a b -> Query a b
forall (f :: * -> * -> *) k v.
(Iter f, Ord k) =>
BaseRep f k v -> f k v -> Query k v
BaseD BaseRep f a b
rep f a b
x2)}
lubQuery a
key (ProjectD Query a v
x Fun (a -> v -> b)
p) = (Query a v -> Collect (a, v, Query a v))
-> Fun (a -> v -> b) -> Query a v -> Collect (a, b, Query a b)
forall k t v u.
Ord k =>
(t -> Collect (k, v, Query k v))
-> Fun (k -> v -> u) -> t -> Collect (k, u, Query k u)
projStep (a -> Query a v -> Collect (a, v, Query a v)
forall a b. Ord a => a -> Query a b -> Collect (a, b, Query a b)
lubQuery a
key) Fun (a -> v -> b)
p Query a v
x
lubQuery a
key (AndD Query a v
f Query a w
g) = do { (a, v, Query a v)
triple1 <- a -> Query a v -> Collect (a, v, Query a v)
forall a b. Ord a => a -> Query a b -> Collect (a, b, Query a b)
lubQuery a
key Query a v
f; (a, w, Query a w)
triple2 <- a -> Query a w -> Collect (a, w, Query a w)
forall a b. Ord a => a -> Query a b -> Collect (a, b, Query a b)
lubQuery a
key Query a w
g; (a, v, Query a v)
-> (a, w, Query a w) -> Collect (a, (v, w), Query a (v, w))
forall a b1 b2.
Ord a =>
(a, b1, Query a b1)
-> (a, b2, Query a b2) -> Collect (a, (b1, b2), Query a (b1, b2))
andStep (a, v, Query a v)
triple1 (a, w, Query a w)
triple2 }
lubQuery a
key (ChainD Query a v
f Query v w
g Fun (a -> (v, w) -> b)
p) = do { (a, v, Query a v)
trip <- a -> Query a v -> Collect (a, v, Query a v)
forall a b. Ord a => a -> Query a b -> Collect (a, b, Query a b)
lubQuery a
key Query a v
f; (a, v, Query a v)
-> Query v w -> Fun (a -> (v, w) -> b) -> Collect (a, b, Query a b)
forall b a w u.
(Ord b, Ord a) =>
(a, b, Query a b)
-> Query b w -> Fun (a -> (b, w) -> u) -> Collect (a, u, Query a u)
chainStep (a, v, Query a v)
trip Query v w
g Fun (a -> (v, w) -> b)
p}
lubQuery  a
key (AndPD Query a v
f Query a u
g Fun (a -> (v, u) -> b)
p) = do { (a, v, Query a v)
triple1 <- a -> Query a v -> Collect (a, v, Query a v)
forall a b. Ord a => a -> Query a b -> Collect (a, b, Query a b)
lubQuery a
key Query a v
f; (a, u, Query a u)
triple2 <- a -> Query a u -> Collect (a, u, Query a u)
forall a b. Ord a => a -> Query a b -> Collect (a, b, Query a b)
lubQuery a
key Query a u
g; (a, v, Query a v)
-> (a, u, Query a u)
-> Fun (a -> (v, u) -> b)
-> Collect (a, b, Query a b)
forall a b1 b2 w.
Ord a =>
(a, b1, Query a b1)
-> (a, b2, Query a b2)
-> Fun (a -> (b1, b2) -> w)
-> Collect (a, w, Query a w)
andPstep (a, v, Query a v)
triple1 (a, u, Query a u)
triple2 Fun (a -> (v, u) -> b)
p}
lubQuery a
key (OrD Query a b
f Query a b
g Fun (b -> b -> b)
comb) = (Query a b -> Collect (a, b, Query a b))
-> Query a b
-> Query a b
-> Fun (b -> b -> b)
-> Collect (a, b, Query a b)
forall k a v.
(Ord k, Ord a) =>
(Query k v -> Collect (a, v, Query k v))
-> Query k v
-> Query k v
-> Fun (v -> v -> v)
-> Collect (a, v, Query k v)
orStep (a -> Query a b -> Collect (a, b, Query a b)
forall a b. Ord a => a -> Query a b -> Collect (a, b, Query a b)
lubQuery a
key) Query a b
f Query a b
g Fun (b -> b -> b)
comb
lubQuery a
key (GuardD Query a b
f Fun (a -> b -> Bool)
p) = (Query a b -> Collect (a, b, Query a b))
-> Fun (a -> b -> Bool) -> Query a b -> Collect (a, b, Query a b)
forall a b.
Ord a =>
(Query a b -> Collect (a, b, Query a b))
-> Fun (a -> b -> Bool) -> Query a b -> Collect (a, b, Query a b)
guardStep (a -> Query a b -> Collect (a, b, Query a b)
forall a b. Ord a => a -> Query a b -> Collect (a, b, Query a b)
lubQuery a
key) Fun (a -> b -> Bool)
p Query a b
f
lubQuery a
key (DiffD Query a b
f Query a u
g) = do { (a, b, Query a b)
trip <- a -> Query a b -> Collect (a, b, Query a b)
forall a b. Ord a => a -> Query a b -> Collect (a, b, Query a b)
lubQuery a
key Query a b
f; (a, b, Query a b) -> Query a u -> Collect (a, b, Query a b)
forall k v u.
Ord k =>
(k, v, Query k v) -> Query k u -> Collect (k, v, Query k v)
diffStep (a, b, Query a b)
trip Query a u
g}


instance Iter Query where
   nxt :: Query a b -> Collect (a, b, Query a b)
nxt = Query a b -> Collect (a, b, Query a b)
forall a b. Query a b -> Collect (a, b, Query a b)
nxtQuery
   lub :: k -> Query k b -> Collect (k, b, Query k b)
lub = k -> Query k b -> Collect (k, b, Query k b)
forall a b. Ord a => a -> Query a b -> Collect (a, b, Query a b)
lubQuery

-- =======================================================================================
-- Finally we make smart constructors for Query, so we can lift un-embedded Base types
-- into Queries, so programmers don't need to know about List and Sett.

projectQ :: (Ord k, HasQuery c k v) => c -> Fun (k -> v -> u) -> Query k u
projectQ :: c -> Fun (k -> v -> u) -> Query k u
projectQ c
q Fun (k -> v -> u)
fun = Query k v -> Fun (k -> v -> u) -> Query k u
forall k v u. Ord k => Query k v -> Fun (k -> v -> u) -> Query k u
ProjectD (c -> Query k v
forall concrete k v. HasQuery concrete k v => concrete -> Query k v
query c
q) Fun (k -> v -> u)
fun

andQ :: (Ord k, HasQuery concrete1 k v, HasQuery concrete2 k w) => concrete1 -> concrete2 -> Query k (v, w)
andQ :: concrete1 -> concrete2 -> Query k (v, w)
andQ concrete1
x concrete2
y = Query k v -> Query k w -> Query k (v, w)
forall k v w. Ord k => Query k v -> Query k w -> Query k (v, w)
AndD (concrete1 -> Query k v
forall concrete k v. HasQuery concrete k v => concrete -> Query k v
query concrete1
x) (concrete2 -> Query k w
forall concrete k v. HasQuery concrete k v => concrete -> Query k v
query concrete2
y)

orQ ::
  (Ord k, HasQuery concrete1 k v, HasQuery concrete2 k v) =>
  concrete1 -> concrete2 -> Fun (v -> v -> v) -> Query k v
orQ :: concrete1 -> concrete2 -> Fun (v -> v -> v) -> Query k v
orQ concrete1
x concrete2
y Fun (v -> v -> v)
comb = 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 (concrete1 -> Query k v
forall concrete k v. HasQuery concrete k v => concrete -> Query k v
query concrete1
x) (concrete2 -> Query k v
forall concrete k v. HasQuery concrete k v => concrete -> Query k v
query concrete2
y) Fun (v -> v -> v)
comb

chainQ ::
   (Ord k, Ord v, HasQuery concrete1 k v,HasQuery concrete2 v w) =>
   concrete1 -> concrete2 -> Fun (k -> (v, w) -> u) -> Query k u
chainQ :: concrete1 -> concrete2 -> Fun (k -> (v, w) -> u) -> Query k u
chainQ concrete1
x concrete2
y Fun (k -> (v, w) -> u)
p = Query k v -> Query v w -> Fun (k -> (v, w) -> u) -> Query k u
forall k v w u.
(Ord k, Ord v) =>
Query k v -> Query v w -> Fun (k -> (v, w) -> u) -> Query k u
ChainD (concrete1 -> Query k v
forall concrete k v. HasQuery concrete k v => concrete -> Query k v
query concrete1
x) (concrete2 -> Query v w
forall concrete k v. HasQuery concrete k v => concrete -> Query k v
query concrete2
y) Fun (k -> (v, w) -> u)
p

andPQ ::
   (Ord k, HasQuery concrete1 k v, HasQuery concrete2 k u) =>
   concrete1 -> concrete2 -> Fun (k -> (v, u) -> w) -> Query k w
andPQ :: concrete1 -> concrete2 -> Fun (k -> (v, u) -> w) -> Query k w
andPQ concrete1
x concrete2
y Fun (k -> (v, u) -> w)
p = Query k v -> Query k u -> Fun (k -> (v, u) -> w) -> Query k w
forall k v1 u v.
Ord k =>
Query k v1 -> Query k u -> Fun (k -> (v1, u) -> v) -> Query k v
AndPD (concrete1 -> Query k v
forall concrete k v. HasQuery concrete k v => concrete -> Query k v
query concrete1
x) (concrete2 -> Query k u
forall concrete k v. HasQuery concrete k v => concrete -> Query k v
query concrete2
y) Fun (k -> (v, u) -> w)
p

guardQ ::
   (Ord k, HasQuery concrete k v) =>
   concrete -> Fun (k -> v -> Bool) -> Query k v
guardQ :: concrete -> Fun (k -> v -> Bool) -> Query k v
guardQ concrete
x Fun (k -> v -> Bool)
p = 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 (concrete -> Query k v
forall concrete k v. HasQuery concrete k v => concrete -> Query k v
query concrete
x) Fun (k -> v -> Bool)
p

-- Don't know why this won't type check
-- diffQ :: (Ord k, HasQuery concrete1 k v, HasQuery concrete2 k u) => concrete1 -> concrete2 -> Query k v
-- diffQ = \ x y -> DiffD (query x) (query y)

class HasQuery concrete k v where
  query :: concrete -> Query k v

instance HasQuery (Query k v) k v where
   query :: Query k v -> Query k v
query Query k v
xs = Query k v
xs

instance Ord k => HasQuery [(k,v)] k v where
   query :: [(k, v)] -> Query k v
query [(k, v)]
xs = BaseRep List k v -> List 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 List k v
forall k v. Basic List => BaseRep List k v
ListR ((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) [(k, v)]
xs)

instance Ord k => HasQuery (Set.Set k) k () where
   query :: Set k -> Query k ()
query Set k
xs = 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 Set k
xs)

instance Ord k => HasQuery (Map.Map k v) k v where
   query :: Map k v -> Query k v
query Map k v
xs = BaseRep Map k v -> Map 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 Map k v
forall k v. Basic Map => BaseRep Map k v
MapR Map k v
xs

instance (Ord v,Ord k) => HasQuery (BiMap v k v) k v where
   query :: BiMap v k v -> Query k v
query BiMap v k v
xs = BaseRep (BiMap v) k v -> BiMap v 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 (BiMap v) k v
forall v k. (Basic (BiMap v), Ord v) => BaseRep (BiMap v) k v
BiMapR BiMap v k v
xs

instance Ord k => HasQuery (Single k v) k v where
   query :: Single k v -> Query k v
query Single k v
xs = 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 Single k v
xs

-- =================================================
-- Show Instances
-- =================================================

instance Show (BaseRep f k v) where
  show :: BaseRep f k v -> [Char]
show BaseRep f k v
MapR = [Char]
"Map"
  show BaseRep f k v
SetR = [Char]
"Set"
  show BaseRep f k v
ListR = [Char]
"List"
  show BaseRep f k v
SingleR = [Char]
"Single"
  show BaseRep f k v
BiMapR = [Char]
"BiMap"

instance Show (Exp t) where
  show :: Exp t -> [Char]
show (Base BaseRep f k v
MapR f k v
x) = [Char]
"Map("[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++Int -> [Char]
forall a. Show a => a -> [Char]
show(Map k v -> Int
forall k a. Map k a -> Int
Map.size f k v
Map k v
x)[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
")?"
  show (Base BaseRep f k v
SetR (Sett x)) = [Char]
"Set("[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++Int -> [Char]
forall a. Show a => a -> [Char]
show(Set k -> Int
forall a. Set a -> Int
Set.size Set k
x)[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
")?"
  show (Base BaseRep f k v
ListR f k v
xs) = [Char]
"List("[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++Int -> [Char]
forall a. Show a => a -> [Char]
show([(k, v)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (List k v -> [(k, v)]
forall k v. List k v -> [(k, v)]
unList f k v
List k v
xs))[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
")?"
  show (Base BaseRep f k v
SingleR (Single _ _)) = [Char]
"Single(_ _)"
  show (Base BaseRep f k v
SingleR (SetSingle _ )) = [Char]
"SetSingle(_)"
  show (Base BaseRep f k v
rep f k v
_x) = BaseRep f k v -> [Char]
forall a. Show a => a -> [Char]
show BaseRep f k v
rep[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
"?"
  show (Dom Exp (f k v)
x) = [Char]
"(dom "[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++Exp (f k v) -> [Char]
forall a. Show a => a -> [Char]
show Exp (f k v)
x[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
")"
  show (Rng Exp (f k v)
x) = [Char]
"(rng "[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++Exp (f k v) -> [Char]
forall a. Show a => a -> [Char]
show Exp (f k v)
x[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
")"
  show (DRestrict Exp (g k ())
x Exp (f k v)
y) = [Char]
"("[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++Exp (g k ()) -> [Char]
forall a. Show a => a -> [Char]
show Exp (g k ())
x[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
" ◁ "[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++Exp (f k v) -> [Char]
forall a. Show a => a -> [Char]
show Exp (f k v)
y[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
")"
  show (DExclude Exp (g k ())
x Exp (f k v)
y) = [Char]
"("[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++Exp (g k ()) -> [Char]
forall a. Show a => a -> [Char]
show Exp (g k ())
x[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
" ⋪ "[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++Exp (f k v) -> [Char]
forall a. Show a => a -> [Char]
show Exp (f k v)
y[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
")"
  show (RRestrict Exp (f k v)
x Exp (g v ())
y) = [Char]
"("[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++Exp (f k v) -> [Char]
forall a. Show a => a -> [Char]
show Exp (f k v)
x[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
" ▷ "[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++Exp (g v ()) -> [Char]
forall a. Show a => a -> [Char]
show Exp (g v ())
y[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
")"
  show (RExclude Exp (f k v)
x Exp (g v ())
y) = [Char]
"("[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++Exp (f k v) -> [Char]
forall a. Show a => a -> [Char]
show Exp (f k v)
x[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
" ⋫ "[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++Exp (g v ()) -> [Char]
forall a. Show a => a -> [Char]
show Exp (g v ())
y[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
")"
  show (Elem k
k Exp (g k ())
x) = [Char]
"("[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++k -> [Char]
forall a. Show a => a -> [Char]
show k
k[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
" ∈ "[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++Exp (g k ()) -> [Char]
forall a. Show a => a -> [Char]
show Exp (g k ())
x[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
")"
  show (NotElem k
k Exp (g k ())
x) = [Char]
"("[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++k -> [Char]
forall a. Show a => a -> [Char]
show k
k[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
" ∉ "[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++Exp (g k ()) -> [Char]
forall a. Show a => a -> [Char]
show Exp (g k ())
x[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
")"
  show (Intersect Exp (f k v)
x Exp (g k u)
y) = [Char]
"("[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++Exp (f k v) -> [Char]
forall a. Show a => a -> [Char]
show Exp (f k v)
x [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
" ∩ "[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++Exp (g k u) -> [Char]
forall a. Show a => a -> [Char]
show Exp (g k u)
y[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
")"
  show (SetDiff Exp (f k v)
x Exp (g k u)
y) = [Char]
"("[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++Exp (f k v) -> [Char]
forall a. Show a => a -> [Char]
show Exp (f k v)
x [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
" ➖ "[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++Exp (g k u) -> [Char]
forall a. Show a => a -> [Char]
show Exp (g k u)
y[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
")"
  show (Subset Exp (f k v)
x Exp (g k u)
y) = [Char]
"("[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++Exp (f k v) -> [Char]
forall a. Show a => a -> [Char]
show Exp (f k v)
x[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
" ⊆ "[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++Exp (g k u) -> [Char]
forall a. Show a => a -> [Char]
show Exp (g k u)
y[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
")"
  show (UnionOverrideLeft Exp (f k v)
x Exp (g k v)
y) = [Char]
"("[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++Exp (f k v) -> [Char]
forall a. Show a => a -> [Char]
show Exp (f k v)
x[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
" ∪ "[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++Exp (g k v) -> [Char]
forall a. Show a => a -> [Char]
show Exp (g k v)
y[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
")"
  show (UnionPlus Exp (f k n)
x Exp (f k n)
y) = [Char]
"("[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++Exp (f k n) -> [Char]
forall a. Show a => a -> [Char]
show Exp (f k n)
x[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
" ∪+ "[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++Exp (f k n) -> [Char]
forall a. Show a => a -> [Char]
show Exp (f k n)
y[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
")"
  show (UnionOverrideRight Exp (f k v)
x Exp (g k v)
y) = [Char]
"("[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++Exp (f k v) -> [Char]
forall a. Show a => a -> [Char]
show Exp (f k v)
x[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
" ⨃ "[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++Exp (g k v) -> [Char]
forall a. Show a => a -> [Char]
show Exp (g k v)
y[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
")"
  show (Singleton k
_ v
_) = [Char]
"(singleton _ _ )"
  show (SetSingleton k
_) = [Char]
"(setSingleton _ )"
  show (KeyEqual Exp (f k v)
x Exp (g k u)
y) = [Char]
"("[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++Exp (f k v) -> [Char]
forall a. Show a => a -> [Char]
show Exp (f k v)
x[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
" ≍ "[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++Exp (g k u) -> [Char]
forall a. Show a => a -> [Char]
show Exp (g k u)
y[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
")"

ppQuery :: Query k v -> Doc
ppQuery :: Query k v -> Doc
ppQuery (BaseD BaseRep f k v
rep f k v
_f) = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text(BaseRep f k v -> [Char]
forall a. Show a => a -> [Char]
show BaseRep f k v
rep)
ppQuery (ProjectD Query k v
f Fun (k -> v -> v)
p) = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
"Proj" Doc -> Doc -> Doc
<+> Doc -> Doc
align([Doc] -> Doc
vsep[Query k v -> Doc
forall k v. Query k v -> Doc
ppQuery Query k v
f,[Char] -> Doc
text(Fun (k -> v -> v) -> [Char]
forall a. Show a => a -> [Char]
show Fun (k -> v -> v)
p)])
ppQuery (AndD Query k v
f Query k w
g) = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
"And" Doc -> Doc -> Doc
<+> Doc -> Doc
align([Doc] -> Doc
vsep[Query k v -> Doc
forall k v. Query k v -> Doc
ppQuery Query k v
f,Query k w -> Doc
forall k v. Query k v -> Doc
ppQuery Query k w
g])
ppQuery (ChainD Query k v
f Query v w
g Fun (k -> (v, w) -> v)
p) = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
"Chain" Doc -> Doc -> Doc
<+> Doc -> Doc
align([Doc] -> Doc
vsep[Query k v -> Doc
forall k v. Query k v -> Doc
ppQuery Query k v
f,Query v w -> Doc
forall k v. Query k v -> Doc
ppQuery Query v w
g,[Char] -> Doc
text(Fun (k -> (v, w) -> v) -> [Char]
forall a. Show a => a -> [Char]
show Fun (k -> (v, w) -> v)
p)])
ppQuery (OrD Query k v
f Query k v
g Fun (v -> v -> v)
p) = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
"Or" Doc -> Doc -> Doc
<+> Doc -> Doc
align([Doc] -> Doc
vsep[Query k v -> Doc
forall k v. Query k v -> Doc
ppQuery Query k v
f,Query k v -> Doc
forall k v. Query k v -> Doc
ppQuery Query k v
g,[Char] -> Doc
text(Fun (v -> v -> v) -> [Char]
forall a. Show a => a -> [Char]
show Fun (v -> v -> v)
p)])
ppQuery (GuardD Query k v
f Fun (k -> v -> Bool)
p) = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
"Guard" Doc -> Doc -> Doc
<+> Doc -> Doc
align([Doc] -> Doc
vsep[Query k v -> Doc
forall k v. Query k v -> Doc
ppQuery Query k v
f,[Char] -> Doc
text(Fun (k -> v -> Bool) -> [Char]
forall a. Show a => a -> [Char]
show Fun (k -> v -> Bool)
p)])
ppQuery (DiffD Query k v
f Query k u
g) = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
"Diff" Doc -> Doc -> Doc
<+> Doc -> Doc
align([Doc] -> Doc
vsep[Query k v -> Doc
forall k v. Query k v -> Doc
ppQuery Query k v
f,Query k u -> Doc
forall k v. Query k v -> Doc
ppQuery Query k u
g])
ppQuery (AndPD Query k v
f Query k u
g Fun (k -> (v, u) -> v)
p) = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
"AndP" Doc -> Doc -> Doc
<+> Doc -> Doc
align([Doc] -> Doc
vsep[Query k v -> Doc
forall k v. Query k v -> Doc
ppQuery Query k v
f,Query k u -> Doc
forall k v. Query k v -> Doc
ppQuery Query k u
g,[Char] -> Doc
text(Fun (k -> (v, u) -> v) -> [Char]
forall a. Show a => a -> [Char]
show Fun (k -> (v, u) -> v)
p)])


instance Show (Query k v) where
   show :: Query k v -> [Char]
show Query k v
x = Doc -> [Char]
forall a. Show a => a -> [Char]
show(Query k v -> Doc
forall k v. Query k v -> Doc
ppQuery Query k v
x)