{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE StandaloneDeriving #-}

-- | Defines what types can be used in the SetAlgebra, and
--   what operations those types must support (Iter, Basic, Embed)
module Control.Iterate.BaseTypes where

import Control.Iterate.Collect (Collect (..), hasElem, isempty, none, one, when)
import Data.BiMap
import Data.List (sortBy)
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import Data.MapExtras (StrictTriple (..), splitMemberSet)
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.UMap as UM

-- ================= 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
k key -> 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
k key -> 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)

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

-- | 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 used this way. 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 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

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

-- | BaseRep witnesses Basic types. I.e. those types that are instances of both Basic and Iter.
--   Pattern matching against a constructor of type BaseRep, determines which base type. For example
--   data Tag f k v = Tag (BaseRep f k v) (f k v)
--   case Tag MapR x ->  -- here we know x :: Map.Map k v
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
  ViewR ::
    (Monoid coin, Ord cred, Ord ptr, Ord coin, Ord pool) =>
    UM.Tag coin cred pool ptr k v ->
    BaseRep (UM.View coin cred pool ptr) k v

instance Show (BaseRep f k v) where
  show :: BaseRep f k v -> String
show BaseRep f k v
MapR = String
"Map"
  show BaseRep f k v
SetR = String
"Set"
  show BaseRep f k v
ListR = String
"List"
  show BaseRep f k v
SingleR = String
"Single"
  show BaseRep f k v
BiMapR = String
"BiMap"
  show (ViewR Tag coin cred pool ptr k v
UM.Rew) = String
"ViewR-cred-coin"
  show (ViewR Tag coin cred pool ptr k v
UM.Del) = String
"ViewR-cred-keyhash"
  show (ViewR Tag coin cred pool ptr k v
UM.Ptr) = String
"ViewR-ptr-cred"

-- ==================================================================
-- Now for each Basic type we provide instances
-- ==================================================================

-- ========== Basic 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 (Show k, Show v) => Show (List k v) where
  show :: List k v -> String
show (UnSafeList [(k, v)]
xs) = [(k, v)] -> String
forall a. Show a => a -> String
show [(k, v)]
xs

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

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

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)

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

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
k k -> 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
k k -> 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
k key -> key -> Bool
forall a. Eq a => a -> a -> Bool
== key
a
  haskey key
k (Single key
a b
_b) = key
k key -> 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
k key -> 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
k key -> 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 -> String
show (Single k
k v
v) = String
"(Single " String -> ShowS
forall a. [a] -> [a] -> [a]
++ k -> String
forall a. Show a => a -> String
show k
k String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ v -> String
forall a. Show a => a -> String
show v
v String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
  show (SetSingle k
k) = String
"(SetSingle " String -> ShowS
forall a. [a] -> [a] -> [a]
++ k -> String
forall a. Show a => a -> String
show k
k String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
  show Single k v
Fail = String
"Fail"

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

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

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

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 -> StrictTriple (Set k) Bool (Set k)
forall a. Ord a => a -> Set a -> StrictTriple (Set a) Bool (Set a)
splitMemberSet k
key Set k
m of -- NOTE in Log time, we skip over all those tuples in _left
              StrictTriple 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
              StrictTriple 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

-- ================ Basic BiMap ================================

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

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
right) | Map k b -> Bool
forall k a. Map k a -> Bool
Map.null Map k b
right -> 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

-- ============== 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 a. Ord k => k -> Map k a -> Map k a
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.empty

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
right) | Map k b -> Bool
forall k a. Map k a -> Bool
Map.null Map k b
right -> 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 a. Map k a -> 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

-- ==========================================================================
-- Basic ViewMap

instance
  (Monoid coin, Ord coin, Ord cred, Ord ptr, Ord pool) =>
  Basic (UM.View coin cred pool ptr)
  where
  addkv :: (k, v)
-> View coin cred pool ptr k v
-> (v -> v -> v)
-> View coin cred pool ptr k v
addkv (k
k, v
v) View coin cred pool ptr k v
m v -> v -> v
comb = (v -> v -> v)
-> k
-> v
-> View coin cred pool ptr k v
-> View coin cred pool ptr k v
forall cr coin ptr v k pool.
(Ord cr, Monoid coin, Ord ptr) =>
(v -> v -> v)
-> k -> v -> View coin cr pool ptr k v -> View coin cr pool ptr k v
UM.insertWith' v -> v -> v
comb k
k v
v View coin cred pool ptr k v
m
  addpair :: k
-> v -> View coin cred pool ptr k v -> View coin cred pool ptr k v
addpair = k
-> v -> View coin cred pool ptr k v -> View coin cred pool ptr k v
forall cr coin ptr k v pool.
(Ord cr, Monoid coin, Ord ptr) =>
k -> v -> View coin cr pool ptr k v -> View coin cr pool ptr k v
UM.insert'
  removekey :: k -> View coin cred pool ptr k v -> View coin cred pool ptr k v
removekey = k -> View coin cred pool ptr k v -> View coin cred pool ptr k v
forall cr ptr k coin pool v.
(Ord cr, Ord ptr) =>
k -> View coin cr pool ptr k v -> View coin cr pool ptr k v
UM.delete'
  domain :: View coin cred pool ptr k v -> Set k
domain = View coin cred pool ptr k v -> Set k
forall cr coin pool ptr k v.
Ord cr =>
View coin cr pool ptr k v -> Set k
UM.domain
  range :: View coin cred pool ptr k v -> Set v
range = View coin cred pool ptr k v -> Set v
forall coin pool cr ptr k v.
(Ord coin, Ord pool, Ord cr) =>
View coin cr pool ptr k v -> Set v
UM.range

instance
  (Ord coin, Ord cred, Ord ptr) =>
  Iter (UM.View coin cred pool ptr)
  where
  nxt :: View coin cred pool ptr a b
-> Collect (a, b, View coin cred pool ptr a b)
nxt View coin cred pool ptr a b
m =
    (forall ans.
 ans -> ((a, b, View coin cred pool ptr a b) -> ans -> ans) -> ans)
-> Collect (a, b, View coin cred pool ptr a b)
forall tuple.
(forall ans. ans -> (tuple -> ans -> ans) -> ans) -> Collect tuple
Collect
      ( \ans
ans (a, b, View coin cred pool ptr a b) -> ans -> ans
f ->
          case View coin cred pool ptr a b
-> Maybe (a, b, View coin cred pool ptr a b)
forall coin cr pl ptr k v.
View coin cr pl ptr k v -> Maybe (k, v, View coin cr pl ptr k v)
UM.next View coin cred pool ptr a b
m of
            Maybe (a, b, View coin cred pool ptr a b)
Nothing -> ans
ans
            Just (a
k, b
v, View coin cred pool ptr a b
nextm) -> (a, b, View coin cred pool ptr a b) -> ans -> ans
f (a
k, b
v, View coin cred pool ptr a b
nextm) ans
ans
      )
  lub :: k
-> View coin cred pool ptr k b
-> Collect (k, b, View coin cred pool ptr k b)
lub k
key View coin cred pool ptr k b
m =
    (forall ans.
 ans -> ((k, b, View coin cred pool ptr k b) -> ans -> ans) -> ans)
-> Collect (k, b, View coin cred pool ptr k b)
forall tuple.
(forall ans. ans -> (tuple -> ans -> ans) -> ans) -> Collect tuple
Collect
      ( \ans
ans (k, b, View coin cred pool ptr k b) -> ans -> ans
f ->
          case k
-> View coin cred pool ptr k b
-> Maybe (k, b, View coin cred pool ptr k b)
forall ptr cr k coin pool v.
(Ord ptr, Ord cr) =>
k
-> View coin cr pool ptr k v
-> Maybe (k, v, View coin cr pool ptr k v)
UM.leastUpperBound k
key View coin cred pool ptr k b
m of
            Maybe (k, b, View coin cred pool ptr k b)
Nothing -> ans
ans
            Just (k
k, b
v, View coin cred pool ptr k b
nextm) -> (k, b, View coin cred pool ptr k b) -> ans -> ans
f (k
k, b
v, View coin cred pool ptr k b
nextm) ans
ans
      )
  haskey :: key -> View coin cred pool ptr key b -> Bool
haskey = key -> View coin cred pool ptr key b -> Bool
forall cr ptr k coin pool v.
(Ord cr, Ord ptr) =>
k -> View coin cr pool ptr k v -> Bool
UM.member
  isnull :: View coin cred pool ptr k v -> Bool
isnull = View coin cred pool ptr k v -> Bool
forall coin cr pool ptr k v. View coin cr pool ptr k v -> Bool
UM.isNull
  lookup :: key -> View coin cred pool ptr key rng -> Maybe rng
lookup = key -> View coin cred pool ptr key rng -> Maybe rng
forall cr ptr k coin pool v.
(Ord cr, Ord ptr) =>
k -> View coin cr pool ptr k v -> Maybe v
UM.lookup

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

instance Embed (UM.View coin cred pool ptr k v) (UM.View coin cred pool ptr k v) where
  toBase :: View coin cred pool ptr k v -> View coin cred pool ptr k v
toBase View coin cred pool ptr k v
xs = View coin cred pool ptr k v
xs
  fromBase :: View coin cred pool ptr k v -> View coin cred pool ptr k v
fromBase View coin cred pool ptr k v
xs = View coin cred pool ptr k v
xs