{-# 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.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

--  $ClassesForSetAlgebra

-- ================= The Iter class =================================================

-- | The Set algebra include types that encode finite sets and maps of some type. They
-- have a finite domain, and for each domain element they pair a single range
-- element (unit for sets). 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 a b. 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 k b. Ord k => 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 k b. Ord k => k -> f k b -> Maybe (k, b, f k 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 a b. 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 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 k b. Ord k => k -> f k b -> Maybe (k, b, f k b)
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 key b. Ord key => key -> f key b -> 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 map and set operations, we need to know
-- what kind of basic types 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 k v. Ord k => (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

  -- | remove the pair with key 'k', if it is there.
  removekey :: Ord k => k -> f k v -> f k v

  -- | the set of keys
  domain :: Ord k => f k v -> Set k

  -- | the set of values.
  range :: Ord v => f k v -> Set v

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

-- $Deep embedding

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

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"

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

-- MapAndSetTypes

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

-- | Maps stored as lists. Sorted [(key,value)] pairs, with no duplicate keys.
-- The constructor for List is hidden, since it requires some invariants. Use 'fromPairs' to build an initial List.
data List k v where UnSafeList :: Ord k => [(k, v)] -> List k v

unList :: List k v -> [(k, v)]
unList :: forall k v. 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

instance Basic List where
  addkv :: forall k v.
Ord k =>
(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 :: forall k v. Ord k => 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 :: forall k v. Ord k => List k v -> Set k
domain (UnSafeList [(k, v)]
xs) = ((k, v) -> Set k -> Set k) -> Set k -> [(k, v)] -> Set k
forall a b. (a -> b -> b) -> b -> [a] -> b
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 :: forall v k. Ord v => List k v -> Set v
range (UnSafeList [(k, v)]
xs) = ((k, v) -> Set v -> Set v) -> Set v -> [(k, v)] -> Set v
forall a b. (a -> b -> b) -> b -> [a] -> b
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 :: forall k v. Ord k => (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 :: forall k v. Ord k => (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 :: forall a b. 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 :: forall k b. Ord k => 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 :: forall k v. List k v -> Bool
isnull (UnSafeList [(k, v)]
xs) = [(k, v)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(k, v)]
xs
  lookup :: forall key rng. Ord key => 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 :: forall a b. 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 ===============

-- | Maps and sets with zero or a single pair. Iteration is trivial. Succeeds at most 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 :: forall k v.
Ord k =>
(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 :: forall k v. Ord k => 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 :: forall k v. Ord k => 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 :: forall v k. Ord v => 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) = v -> Set v
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 :: forall a b. 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 b
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 :: forall k b. Ord k => 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 b
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 :: forall key b. Ord key => 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 :: forall k v. Single k v -> Bool
isnull Single k v
Fail = Bool
True
  isnull Single k v
_ = Bool
False
  lookup :: forall key rng. Ord key => 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 rng -> Maybe rng
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 :: forall k v. Ord k => 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 :: forall k v.
Ord k =>
(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 :: forall k v. Ord k => 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 :: forall k v. Ord k => Sett k v -> Set k
domain (Sett Set k
xs) = Set k
xs
  range :: forall v k. Ord v => Sett k v -> Set v
range (Sett Set k
_xs) = v -> Set v
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 :: forall a b. 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 :: forall k b. Ord k => 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 :: forall key b. Ord key => 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 :: forall k v. Sett k v -> Bool
isnull (Sett Set k
x) = Set k -> Bool
forall a. Set a -> Bool
Set.null Set k
x
  lookup :: forall key rng. Ord key => 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 rng -> Maybe rng
forall a. a -> Maybe a
Just () else Maybe rng
forall a. Maybe a
Nothing

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

instance Basic Map.Map where
  -- Data.Map uses(\ new old -> ...) while our convention is (\ old new -> ...)
  addkv :: forall k v. Ord k => (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 a b c. (a -> b -> c) -> b -> a -> c
flip v -> v -> v
comb) k
k v
v Map k v
m
  removekey :: forall k v. Ord k => 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 :: forall k v. Ord k => 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 :: forall v k. Ord v => 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 :: forall a b. 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 :: forall k b. Ord k => 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 v. Map k v -> 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 :: forall key b. Ord key => key -> Map key b -> Bool
haskey key
x Map key b
m = case key -> Map key b -> Maybe b
forall key rng. Ord key => key -> Map key rng -> Maybe rng
Map.lookup key
x Map key b
m of Just b
_ -> Bool
True; Maybe b
Nothing -> Bool
False
  isnull :: forall k v. Map k v -> Bool
isnull = Map k v -> Bool
forall k v. Map k v -> Bool
Map.null
  lookup :: forall key rng. Ord key => key -> Map key rng -> Maybe rng
lookup = key -> Map key rng -> Maybe rng
forall key rng. Ord key => key -> Map key rng -> Maybe rng
Map.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 (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