packages feed

gmap (empty) → 0.1

raw patch · 17 files changed

+9973/−0 lines, 17 filesdep +AvlTreedep +COrderingdep +QuickChecksetup-changed

Dependencies added: AvlTree, COrdering, QuickCheck, array, base, random

Files

+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/runhaskell+import Distribution.Simple+main = defaultMain
+ gmap.cabal view
@@ -0,0 +1,35 @@+name:           gmap+version:        0.1+category:       Data Structures+license:	BSD3+description:+        Provides typeclass for and several implementations of composable maps and generic tries.+          OrdMap is roughly equivalent to Data.Map .+          ListMap, EitherMap, MaybeMap, TupleMap and EnumMap allow you to break down the corresponding types.+          InjectKeys is the easiest way to define tries on your own types, see EitherMap for a simple example.+          ChoiceMap and TupleMap correspond to sum and product types, respectively.+        The type-level syntax for creating maps is currently unwieldy. This will improve significantly in the next version.+author:         Jamie Brandon, Adrian Hey+maintainer:     jamiiecb (google mail)+synopsis:       Composable maps and generic tries.+build-depends:  base >= 3.0, QuickCheck, array, COrdering, AvlTree >= 4.2, random+build-type:     Simple+exposed-modules:+        Data.GMap+        Data.GMap.AssocList+        Data.GMap.OrdMap+        Data.GMap.IntMap+        Data.GMap.ListMap+        Data.GMap.EitherMap+        Data.GMap.UnitMap+        Data.GMap.MaybeMap+        Data.GMap.CacheKeys+        Data.GMap.ChoiceMap+        Data.GMap.EnumMap+        Data.GMap.InjectKeys+        Data.GMap.TupleMap+        Test.GMap+        Test.GMap.Utils+hs-source-dirs: src+-- include-dirs:   include+ghc-options:    -O2 -Wall
+ src/Data/GMap.hs view
@@ -0,0 +1,700 @@+{-# OPTIONS_GHC -fglasgow-exts -Wall #-}++module Data.GMap (+Map+,empty+,singleton+,pair+,fromAssocsWith+,fromAssocsMaybe+,status+,nonEmpty+,addSize+,lookup+,lookupCont+,alter+,insertWith+,insertWith'+,insertMaybe+,delete+,adjustWith+,adjustWith'+,adjustMaybe+,venn+,venn'+,vennMaybe+,union+,union'+,unionMaybe+,disjointUnion+,intersection+,intersection'+,intersectionMaybe+,difference+,differenceMaybe+,isSubsetOf+,isSubmapOf+,Data.GMap.map+,map'+,mapMaybe+,mapWithKey+,mapWithKey'+,Data.GMap.filter+,foldElems+,foldKeys+,foldAssocs+,foldElems'+,foldKeys'+,foldAssocs'+,foldElemsUInt+,valid+,disjointUnionError+,Status(None,One,Many)+,vennMaybe'+,alter'+,adjustMaybe'+,insertMaybe'+,unionMaybe'+,intersectionMaybe'+,differenceMaybe'+,mapMaybe'+,isEmpty+,isSingleton+,insert+,insert'+,size+,insertAssocs+,insertAssocsWith+,insertAssocsMaybe+,fromAssocs+,lookupM+,keys+,elems+,assocs+,OrderedMap+,compareKey+,fromAssocsAscWith+,fromAssocsAscMaybe+,fromAssocsDescWith+,fromAssocsDescMaybe+,foldElemsAsc+,foldElemsDesc+,foldKeysAsc+,foldKeysDesc+,foldAssocsAsc+,foldAssocsDesc+,foldElemsAsc'+,foldElemsDesc'+,foldKeysAsc'+,foldKeysDesc'+,foldAssocsAsc'+,foldAssocsDesc'+,fromAssocsAsc+,fromAssocsDesc+,insertAssocsAsc+,insertAssocsDesc+,insertAssocsAscWith+,insertAssocsDescWith+,insertAssocsAscMaybe+,insertAssocsDescMaybe+,elemsAsc+,elemsDesc+,assocsAsc+,assocsDesc+,keysAsc+,keysDesc+,isProperSubsetOf+,isProperSubmapOfBy+-- Partitions are not implemented yet+-- ,partition+-- ,partitionMaybe+-- ,partitionAscList+-- ,partitionDescList+-- ,partitionAscListMaybe+-- ,partitionDescListMaybe+,sortAscWith+,sortDescWith+,nubAscWith+,nubDescWith+)+where++-- import Data.Foldable+-- import Data.Traversable+import GHC.Base+import qualified Data.List as L+import Prelude hiding (map,lookup)++import Control.Monad+import Data.Maybe(maybe)++forceMaybe :: Maybe a -> Maybe a+forceMaybe Nothing = Nothing+forceMaybe (Just a) = a `seq` Just a++on :: (c -> d) -> (a -> b -> c) -> a -> b -> d+on f g a b = f $ g a b++-- | Type of composable maps.+-- For an example of a composed map see Data.GMap.ListMap+class (Eq k) => Map map k | map -> k where++	-- | The empty map.+	empty :: map a++	-- | Create a map with a single association.+	singleton :: k -> a -> map a+	singleton k a = insert k a empty++	-- | Compare two keys and if they are /different/ return a function that will create+	-- a map with two associations (when supplied with the corresponding associated values).+	-- If the keys are the same then this function returns 'Nothing'.+	pair :: k -> k -> Maybe (a -> a -> map a)+	pair k1 k2 = if k1 == k2 then Nothing else Just (\a1 a2 -> fromAssocs [(k1,a1),(k2,a2)])++	-- | Create a map from an unordered list of associations+	-- Combine repeated keys with the provided function.+	fromAssocsWith :: (a -> a -> a) -> [(k,a)] -> map a+	fromAssocsWith f as = L.foldl' (\mp (k,a) -> insertWith (flip f a) k a mp) empty as++	--- | Create a map from an unordered list of associations+	-- Combine repeated keys with the provided function. If the result is Nothing the key is discarded.+	fromAssocsMaybe :: (a -> a -> Maybe a) -> [(k,a)] -> map a+	fromAssocsMaybe f as = L.foldl' (\mp (k,a) -> insertMaybe (flip f a) k a mp) empty as++	-- | See the 'Status' type.+	-- This function provides a way to find out if a map is empty, a singleton,+	-- or contains more than one association.+	-- It is useful if empty or singleton maps require special treatment.+	status :: map a -> Status k a++	-- | Reject empty maps (return Nothing).+	-- Typically used for dealing with nested maps.+	-- eg to delete a key from a nested map:+	-- 'adjustMaybe (nonEmpty $ delete k2) k1'+	nonEmpty :: map a -> Maybe (map a)+	nonEmpty mp = case (status mp) of+		None 	-> Nothing+		_	-> Just mp++	-- | Add number of key\/value pairs in the map to the supplied Int+	addSize :: map a -> Int# -> Int#++	-- | Return the value associated with the supplied key (if any).+	lookup :: k -> map a -> Maybe a++	-- | Find the value associated with the supplied key (if any) and return the result+	-- of applying the supplied continuation function to that value. Useful for nested lookup.+	lookupCont :: (a -> Maybe b) -> k -> map a -> Maybe b+	lookupCont f k mp = f =<< lookup k mp++	-- | This is a combined insert\/modify\/delete operation. The argument to the supplied function+	-- is ('Just' a) if there is a value (a) associated with the supplied key, otherwise 'Nothing'.+	-- If the return value is ('Just' a'), a' becomes the new value associated with the supplied key.+	-- If the return value is 'Nothing', the association for the supplied key (if any) is deleted.+	alter :: (Maybe a -> Maybe a) -> k -> map a -> map a++	-- | Insert a new association in the map if there is currently no value associated with the key.+	-- If there is a value associated with the key then replace it with the result of+	-- applying the supplied function to that value.+	insertWith :: (a -> a) -> k -> a -> map a -> map a+	insertWith f k a = alter (Just . maybe a f) k++	-- | Same as 'insertWith', but applies the supplied function strictly if the search succeeds.+	-- Note that the third argument is not strictly evaluated either way (TODO change this)+	insertWith' :: (a -> a) -> k -> a -> map a -> map a+	insertWith' f k a = alter' (Just . maybe a f) k++	-- | Similar to 'insert', but the association is deleted if the supplied function returns 'Nothing'.+	-- (The supplied function is always applied strictly.)+	insertMaybe :: (a -> Maybe a) -> k -> a -> map a -> map a+	insertMaybe f k a = alter ins k+		where 	ins Nothing = Just a+			ins (Just a') = f a'++	-- | Delete the association for the supplied key (if any).+	delete :: k -> map a -> map a+	delete = alter (const Nothing)++	-- | Find the value associated with the supplied key (if any) and apply the supplied function+	-- to that value.+	adjustWith :: (a -> a) -> k -> map a -> map a+	adjustWith f = alter (liftM f)++	-- | Same as 'adjust' but applies the supplied function strictly.+	adjustWith' :: (a -> a) -> k -> map a -> map a+	adjustWith' f = alter' (fmap f)++	-- | Find the value associated with the supplied key (if any) and apply the supplied function+	-- to that value. Delete the association if the result is 'Nothing'. Replace the old value with+	-- the new value if the result is ('Just' something).+	adjustMaybe :: (a -> Maybe a) -> k -> map a -> map a+	adjustMaybe f = alter (f =<<)++	-- | Returns the left difference, intersection and right difference of the supplied maps+	venn :: (a -> b -> c) -> map a -> map b -> (map a, map c, map b)+	venn f = vennMaybe (Just `on` f)++	-- | Same as 'venn', but the new values in the intersection are evaluated strictly+	venn' :: (a -> b -> c) -> map a -> map b -> (map a, map c, map b)+	venn' f = vennMaybe ((forceMaybe . Just) `on` f)++	-- | Same as 'venn', except that values for which the argument function returns nothing+	-- are dropped from the intersection+	vennMaybe :: (a -> b -> Maybe c) -> map a -> map b -> (map a, map c, map b)++	-- | Evaluate the union of two maps. If the maps contain common keys then combine the+	-- values associated with those keys using the supplied function. The value arguments+	-- to this function are supplied in the same order as the map arguments.+	union :: (a -> a -> a) -> map a -> map a -> map a+	union f = unionMaybe (Just `on` f)++	-- | Same as 'unionWith', but the new associated values are evaluated strictly.+	union' :: (a -> a -> a) -> map a -> map a -> map a+	union' f = unionMaybe ((forceMaybe . Just) `on` f)++	-- | Evaluate the union of two maps, but delete combined associations from the result map+	-- if the combining function returns 'Nothing'.+	unionMaybe :: (a -> a -> Maybe a) -> map a -> map a -> map a+	unionMaybe f mpa mpb = disjointUnion leftDiff (disjointUnion inter rightDiff)+		where (leftDiff,inter,rightDiff) = vennMaybe f mpa mpb++	-- | Evaluate the union of two key-disjoint maps. If the arguments are not disjoint the+	-- behaviour is undefined. This is potentially faster than 'union'.+	disjointUnion :: map a -> map a -> map a+	disjointUnion = union' (\ _ _ -> error ("Data.GMap.disjointUnion: Duplicate key found in map."))++	-- | Evaluate the intersection of two maps, combining common associations using the supplied function.+	intersection :: (a -> b -> c) -> map a -> map b -> map c+	intersection f = intersectionMaybe (Just `on` f)++	-- | Same as 'intersection', but the new associated values are evaluated strictly.+	intersection' :: (a -> b -> c) -> map a -> map b -> map c+	intersection' f = intersectionMaybe ((forceMaybe . Just) `on` f)++	-- | Evaluate the intersection of two maps, but delete combined associations from the result map+	-- if the combining function returns 'Nothing'.+	intersectionMaybe :: (a -> b -> Maybe c) -> map a -> map b -> map c+	intersectionMaybe f mpa mpb = inter+		where (_,inter,_) = vennMaybe f mpa mpb++	-- | Evaluate the difference between two maps. For any key occuring in the second map,+	-- the corresponding association (if any) is deleted from the first map.+	-- The associated values in the second map are irrelevant.+	difference :: map a -> map b -> map a+	difference = differenceMaybe (\ _ _ -> Nothing)++	-- | Difference with a combining function. If the combining function returns+	-- @Just a@ then the corresponding association is not deleted from the result map+	-- (it is retained with @a@ as the associated value).+	differenceMaybe :: (a -> b -> Maybe a) -> map a -> map b -> map a+	differenceMaybe f mpa mpb = disjointUnion leftDiff inter+		where (leftDiff,inter,_) = vennMaybe f mpa mpb++	-- | Returns true if the keys in the first map are a subset of the keys in the second map.+	-- (This includes the case where the key sets are identical). Note that this function does+	-- not examine the associated values (which are irrelevant). See 'isSubmapOf' if you+	-- do want associated values examined.+	isSubsetOf :: map a -> map b -> Bool++	-- | Returns true if the keys in the first map are a subset of the keys in the second map+	-- and the corresponding function always returns true when applied to the values associated+	-- with matching keys.+	isSubmapOf :: (a -> b -> Bool) -> map a -> map b -> Bool++	-- | Apply the supplied function to every associated value in the map.+	map :: (a -> b) -> map a -> map b+	map f = mapMaybe (Just . f)++	-- | Same as 'Data.GMap.map', but the function is applied strictly.+	map' :: (a -> b) -> map a -> map b+	map' f = mapMaybe' (Just . f)++	-- | Apply the supplied function to every associated value in the map.+	-- If the result is 'Nothing' then the delete the corresponding association.+	mapMaybe :: (a -> Maybe b) -> map a -> map b++	-- | Apply the supplied function to every association in the map, and use the result+	-- as the new associated value for the corresponding key.+	mapWithKey :: (k -> a -> b) -> map a -> map b++	-- | Same as 'mapWithKey', but the function is applied strictly.+	mapWithKey' :: (k -> a -> b) -> map a -> map b++	-- | Delete associations for which the supplied predicate returns 'False' when applied to+	-- the associated value.+	filter :: (a -> Bool) -> map a -> map a++	-- | Fold right over the list of elements in an unspecified order.+	foldElems :: (a -> b -> b) -> b -> map a -> b+	foldElems f = foldAssocs (const f)++	-- | Fold right over the list of keys in an unspecified order.+	foldKeys :: (k -> b -> b) -> b -> map a -> b+	foldKeys f = foldAssocs (\ k _ -> f k)++	-- | Fold right over the list of associations in an unspecified order.+	foldAssocs :: (k -> a -> b -> b) -> b -> map a -> b++	-- | A strict version of 'foldElems' which should be used for+	-- accumulating functions which are strict in their second argument.+	foldElems' :: (a -> b -> b) -> b -> map a -> b+	foldElems' f = foldAssocs' (const f)++	-- | A strict version of 'foldKeys' which should be used for+	-- accumulating functions which are strict in their second argument.+	foldKeys' :: (k -> b -> b) -> b -> map a -> b+	foldKeys' f = foldAssocs' (\ k _ -> f k)++	-- | A strict version of 'foldAssocs' which should be used for+	-- accumulating functions which are strict in their third argument.+	foldAssocs' :: (k -> a -> b -> b) -> b -> map a -> b++	-- | Fold over elements in un-specified order using /unboxed/ Int accumulator (with GHC).+	-- Defaults to boxed Int for other Haskells. Typically used for counting functions.+	-- Implementations are free to traverse the map in any order.+	-- The folded function is always applied strictly.+	foldElemsUInt :: (a -> Int# -> Int#)-> Int# -> map a  -> Int#++	-- | Test whatever underlying data structure is used to implement an+	-- instance of this class is valid. Used for debugging.+	-- 'Nothing' indicates the data structure is valid.+	valid :: map a -> Maybe String++-- | Raised by disjointUnion if the arguments are not disjoint. Note that instances of Map are *not* required+-- to test that arguments are disjoint.+disjointUnionError = error "Data.GMap.disjointUnion: Arguments not disjoint"++-- | This is the return type for the 'status' method of the 'Map' class+data Status k a = None | One k a | Many deriving Eq++-- | Same as 'vennMaybe' except that the new associated values are strictly evaluated.+vennMaybe' :: Map map k => (a -> b -> Maybe c) -> map a -> map b -> (map a, map c, map b)+vennMaybe' f = vennMaybe (forceMaybe `on` f)++-- | Like 'alter' except that the new associated value is strictly evaluated+alter' :: Map map k => (Maybe a -> Maybe a) -> k -> map a -> map a+alter' f = alter (forceMaybe . f)++-- | Like 'adjustMaybe' except that the new associated value is strictly evaluated+adjustMaybe' :: Map map k => (a -> Maybe a) -> k -> map a -> map a+adjustMaybe' f = adjustMaybe (forceMaybe . f)++-- | Like 'insertMaybe' except that if the key is already present the new associated+-- value is evaluated strictly. If the key is not present then the supplied value is+-- *not* evaluated strictly. (TODO Change this)+insertMaybe' :: Map map k => (a -> Maybe a) -> k -> a -> map a -> map a+insertMaybe' f = insertMaybe (forceMaybe . f)++-- | Like 'unionMaybe' except that the new associated values are strictly evaluated+unionMaybe' :: Map map k => (a -> a -> Maybe a) -> map a -> map a -> map a+unionMaybe' f = unionMaybe (forceMaybe `on` f)++-- | Like 'intersectionMaybe' except that the new associated values are strictly evaluated+intersectionMaybe' :: Map map k => (a -> b -> Maybe c) -> map a -> map b -> map c+intersectionMaybe' f = intersectionMaybe (forceMaybe `on` f)++-- | Like 'differenceMaybe' except that the new associated values are strictly evaluated+differenceMaybe' :: Map map k => (a -> b -> Maybe a) -> map a -> map b -> map a+differenceMaybe' f = differenceMaybe (forceMaybe `on` f)++-- | Like 'mapMaybe' except that the new associated values are strictly evaluated+mapMaybe' :: Map map k => (a -> Maybe b) -> map a -> map b+mapMaybe' f = mapMaybe (forceMaybe . f)++isEmpty :: Map map l => map a -> Bool+isEmpty mp = case (status mp) of+	None 	-> True+	_	-> False++isSingleton :: Map map l => map a -> Bool+isSingleton mp = case (status mp) of+	One _ _ -> True+	_	-> False++-- | Write a new association in the map, overwriting any value currently associated with the key.+insert :: Map map k => k -> a -> map a -> map a+insert k a mp = insertWith (const a) k a mp++-- | Write a new association in the map, overwriting any value currently associated with the key.+-- The new value is evaluated strictly.+insert' :: Map map k => k -> a -> map a -> map a+insert' k a mp = insertWith' (const a) k a mp++-- | Count the number of associations in a map.+size :: Map map k => map a -> Int+size mp = I# (addSize mp 0#)+{-# INLINE size #-}++-- | Insert an unordered list of key\/value pairs into a map.+-- Repeated keys will be overwritten by the last occurence of the key.+insertAssocs :: Map map k => [(k,a)] -> map a -> map a+insertAssocs = insertAssocsWith (flip const)++insertAssocsWith :: Map map k => (a -> a -> a) -> [(k,a)] -> map a -> map a+insertAssocsWith f as mp = union f mp (fromAssocsWith f as)++insertAssocsMaybe :: Map map k => (a -> a -> Maybe a) -> [(k,a)] -> map a -> map a+insertAssocsMaybe f as mp = unionMaybe f mp (fromAssocsMaybe f as)++fromAssocs :: Map map k => [(k,a)] -> map a+fromAssocs = fromAssocsWith (flip const)++-- | Monadic lookup.+lookupM :: (Map map k, Monad m) => k -> map a -> m a+lookupM k mp = case lookup k mp of+               Just a  -> return a+               Nothing -> fail "Data.Trie.General.lookupM: Key not found."+{-# SPECIALIZE lookupM :: Map map k => k -> map a -> Maybe a #-}++keys :: Map map k => map a -> [k]+keys = foldKeys (:) []++elems :: Map map k => map a -> [a]+elems = foldElems (:) []++assocs :: Map map k => map a -> [(k,a)]+assocs = foldAssocs (\ k a xs -> (k,a):xs) []++-- | Maps which maintain some order on their keys, determined by compareKey.+class Map map k => OrderedMap map k where++	-- | Every function in this class must respect the ordering given by compareKey.+	-- The first argument is required for its type only and should not be evaluated.+	compareKey :: map a -> k -> k -> Ordering++	-- | Create a map from an ascending list of key\/value pairs+	-- Combine repeated keys with the provided function.+	fromAssocsAscWith :: (a -> a -> a) -> [(k,a)] -> map a+	fromAssocsAscWith f as = L.foldl' (\mp (k,a) -> insertWith (flip f a) k a mp) empty as++	--- | Create a map from an ascending list of key\/value pairs+	-- Combine repeated keys with the provided function. If the result is Nothing the key is discarded.+	fromAssocsAscMaybe :: (a -> a -> Maybe a) -> [(k,a)] -> map a+	fromAssocsAscMaybe f as = L.foldl' (\mp (k,a) -> insertMaybe (flip f a) k a mp) empty as++	-- | Create a map from a descending list of key\/value pairs+	-- Combine repeated keys with the provided function.+	fromAssocsDescWith :: (a -> a -> a) -> [(k,a)] -> map a+	fromAssocsDescWith f as = L.foldl' (\mp (k,a) -> insertWith (flip f a) k a mp) empty as++	--- | Create a map from a descending list of key\/value pairs+	-- Combine repeated keys with the provided function. If the result is Nothing the key is discarded.+	fromAssocsDescMaybe :: (a -> a -> Maybe a) -> [(k,a)] -> map a+	fromAssocsDescMaybe f as = L.foldl' (\mp (k,a) -> insertMaybe (flip f a) k a mp) empty as++	-- | Right associative fold over the list of elements in ascending order of keys.+	-- See 'foldElemsAsc'' for a strict version of this function.+	foldElemsAsc :: (a -> b -> b) -> b -> map a -> b+	foldElemsAsc f = foldAssocsAsc (const f)++	-- | Right associative fold over the list of elements in descending order of keys.+	-- See 'foldElemsDesc'' for a strict version of this function.+	foldElemsDesc :: (a -> b -> b) -> b -> map a -> b+	foldElemsDesc f = foldAssocsDesc (const f)++	-- | Right associative fold over the list of keys in ascending order.+	-- See 'foldKeysAsc'' for a strict version of this function.+	foldKeysAsc :: (k -> b -> b) -> b -> map a -> b+	foldKeysAsc f = foldAssocsAsc (\ k _ -> f k)++	-- | Right associative fold over the list of keys in descending order.+	-- See 'foldKeysDesc'' for a strict version of this function.+	foldKeysDesc :: (k -> b -> b) -> b -> map a -> b+	foldKeysDesc f = foldAssocsDesc (\ k _ -> f k)++	-- | Right associative fold over the list of associations in ascending order of keys.+	-- See 'foldAssocsAsc'' for a strict version of this function.+	foldAssocsAsc :: (k -> a -> b -> b) -> b -> map a -> b++	-- | Right associative fold over the list of associations in descending order of keys.+	-- See 'foldAssocsDesc'' for a strict version of this function.+	foldAssocsDesc :: (k -> a -> b -> b) -> b -> map a -> b++	-- | A strict version of 'foldElemsAsc' which should be used for+	-- accumulating functions which are strict in their second argument.+	foldElemsAsc' :: (a -> b -> b) -> b -> map a -> b+	foldElemsAsc' f z as = foldElemsDesc f' id as z -- Note reversed order+  		where f' a c z' = c $! f a z'++	-- | A strict version of 'foldElemsDesc' which should be used for+	-- accumulating functions which are strict in their second argument.+	foldElemsDesc' :: (a -> b -> b) -> b -> map a -> b+	foldElemsDesc' f z as = foldElemsAsc f' id as z -- Note reversed order+  		where f' a c z' = c $! f a z'++	-- | A strict version of 'foldKeysAsc' which should be used for+	-- accumulating functions which are strict in their second argument.+	foldKeysAsc' :: (k -> b -> b) -> b -> map a -> b+	foldKeysAsc' f z ks = foldKeysDesc f' id ks z -- Note reversed order+  		where f' k c z' = c $! f k z'++	-- | A strict version of 'foldKeysDesc' which should be used for+	-- accumulating functions which are strict in their second argument.+	foldKeysDesc' :: (k -> b -> b) -> b -> map a -> b+	foldKeysDesc' f z ks = foldKeysAsc f' id ks z -- Note reversed order+  		where f' k c z' = c $! f k z'++	-- | A strict version of 'foldAssocsAsc' which should be used for+	-- accumulating functions which are strict in their third argument.+	foldAssocsAsc' :: (k -> a -> b -> b) -> b -> map a -> b+	foldAssocsAsc' f z xs = foldAssocsDesc f' id xs z -- Note reversed order+  		where f' k a c z' = c $! f k a z'++	-- | A strict version of 'foldAssocsDesc' which should be used for+	-- accumulating functions which are strict in their third argument.+	foldAssocsDesc' :: (k -> a -> b -> b) -> b -> map a -> b+	foldAssocsDesc' f z xs = foldAssocsAsc f' id xs z -- Note reversed order+  		where f' k a c z' = c $! f k a z'++------------------------------------------------------------------------++fromAssocsAsc :: OrderedMap map k => [(k,a)] -> map a+fromAssocsAsc = fromAssocsAscWith (flip const)++fromAssocsDesc :: OrderedMap map k => [(k,a)] -> map a+fromAssocsDesc = fromAssocsDescWith (flip const)++-- | Insert an ascending list of associations into a map+-- Duplicate keys are replaced by the rightmost value+insertAssocsAsc :: OrderedMap map k => [(k,a)] -> map a -> map a+insertAssocsAsc as = insertAssocsAscWith (flip const) as++-- | Insert a descending list of associations into a map+-- Duplicate keys are replaced by the rightmost value+insertAssocsDesc :: OrderedMap map k => [(k,a)] -> map a -> map a+insertAssocsDesc as = insertAssocsDescWith (flip const) as++-- | Insert an ascending list of associations into a map+-- Duplicate keys are combined with the supplied function+insertAssocsAscWith :: OrderedMap map k => (a -> a -> a) -> [(k,a)] -> map a -> map a+insertAssocsAscWith f as mp = union f mp (fromAssocsAscWith f as)++-- | Insert a descending list of associations into a map+-- Duplicate keys are combined with the supplied function+insertAssocsDescWith :: OrderedMap map k => (a -> a -> a) -> [(k,a)] -> map a -> map a+insertAssocsDescWith f as mp = union f mp (fromAssocsDescWith f as)++-- | Same as 'insertAssocsAscWith' except that if Nothing is returned then the key is discarded+insertAssocsAscMaybe :: OrderedMap map k => (a -> a -> Maybe a) -> [(k,a)] -> map a -> map a+insertAssocsAscMaybe f as mp = unionMaybe f mp (fromAssocsAscMaybe f as)++-- | Same as 'insertAssocsDescWith' except that if Nothing is returned then the key is discarded+insertAssocsDescMaybe :: OrderedMap map k => (a -> a -> Maybe a) -> [(k,a)] -> map a -> map a+insertAssocsDescMaybe f as mp = unionMaybe f mp (fromAssocsDescMaybe f as)++-- | List the elements in the map in ascending order of keys.+elemsAsc :: OrderedMap map k => map a -> [a]+elemsAsc = foldElemsAsc (:) []+{-# INLINE elemsAsc #-}++-- | List the elements in the map in descending order of keys.+elemsDesc :: OrderedMap map k => map a -> [a]+elemsDesc = foldElemsDesc (:) []+{-# INLINE elemsDesc #-}++-- | List all associations in the map in ascending order of keys.+assocsAsc :: OrderedMap map k => map a -> [(k,a)]+assocsAsc = foldAssocsAsc (\k a kas -> (k,a):kas) []+{-# INLINE assocsAsc #-}++-- | List all associations in the map in descending order of keys.+assocsDesc :: OrderedMap map k => map a -> [(k,a)]+assocsDesc = foldAssocsDesc (\k a kas -> (k,a):kas) []+{-# INLINE assocsDesc #-}++-- | List all keys in the map in ascending order.+keysAsc :: OrderedMap map k => map a -> [k]+keysAsc = foldKeysAsc (:) []+{-# INLINE keysAsc #-}++-- | List all keys in the map in descending order.+keysDesc :: OrderedMap map k =>  map a -> [k]+keysDesc = foldKeysDesc (:) []+{-# INLINE keysDesc #-}++-- | Similar to 'isSubsetOf', but also requires that the size of the second map is+-- greater than the first (so does not include the case where the key sets are identical).+isProperSubsetOf :: Map map k =>  map a -> map b -> Bool+isProperSubsetOf mpa mpb = (size mpa < size mpb) && (isSubsetOf mpa mpb)+{-# INLINE isProperSubsetOf #-}++-- | Similar to 'isSubmapOf', but also requires that the size of the second map is+-- greater than the first (so does not include the case where the key sets are identical).+isProperSubmapOfBy :: Map map k =>  (a -> b -> Bool) -> map a -> map b -> Bool+isProperSubmapOfBy f mpa mpb = (size mpa < size mpb) && (isSubmapOf f mpa mpb)+{-# INLINE isProperSubmapOfBy #-}++-- | Applies the supplied function to every value in a map to create a new key (type @k1@). The+-- result is a map of new keys to a corresponding /non-empty/ map of old keys (type k0) to values.+-- Unimplemented !!!+partition :: (Map map0 k0, Map map1 k1) => (a -> k1) -> map0 a -> map1 (map0 a)+partition p map0 = undefined+{-# INLINE partition #-}++-- | Similar to 'partition', but associations with values yielding 'Nothing' are discarded.+-- Unimplemented !!!+partitionMaybe :: (Map map0 k0, Map map1 k1) => (a -> Maybe k1) -> map0 a -> map1 (map0 a)+partitionMaybe p map0 = undefined+{-# INLINE partitionMaybe #-}++-- | Applies the supplied function to every value in a map to create a new key (type @k1@). The+-- result is a map of new keys to a corresponding /non-empty/ list of old key\/value association pairs.+-- Each list is in ascending order of old keys (type k0).+-- Unimplemented !!!+partitionAscList :: (OrderedMap map0 k0, Map map1 k1) => (a -> k1) -> map0 a -> map1 [(k0,a)]+partitionAscList p map0 = foldAssocsDesc' ins empty map0 -- We use Desc!! (strict)+ where ins k0 a map1 = insertWith' ((k0,a):) (p a) [(k0,a)] map1           -- Note use of insert'++-- | Applies the supplied function to every value in a map to create a new key (type @k1@). The+-- result is a map of new keys to a corresponding /non-empty/ list of old key\/value association pairs.+-- Each list is in descending order of old keys (type k0).+-- Unimplemented !!!+partitionDescList :: (OrderedMap map0 k0, Map map1 k1) => (a -> k1) -> map0 a -> map1 [(k0,a)]+partitionDescList p map0 = foldAssocsAsc' ins empty map0 -- We use Asc!! (strict)+ where ins k0 a map1 = insertWith' ((k0,a):) (p a) [(k0,a)] map1           -- Note use of insert'++-- | Similar to 'partitionAscList', but associations with values yielding 'Nothing' are discarded.+-- Unimplemented !!!+partitionAscListMaybe :: (OrderedMap map0 k0, Map map1 k1) => (a -> Maybe k1) -> map0 a -> map1 [(k0,a)]+partitionAscListMaybe p map0 = foldAssocsDesc' ins empty map0  -- We use Desc!! (strict)+ where ins k0 a map1 =  case p a of+                        Nothing -> map1+                        Just k1 -> insertWith' ((k0,a):) k1 [(k0,a)] map1       -- Note use of insert'++-- | Similar to 'partitionDescList', but associations with values yielding 'Nothing' are discarded.+-- Unimplemented !!!+partitionDescListMaybe :: (OrderedMap map0 k0, Map map1 k1) => (a -> Maybe k1) -> map0 a -> map1 [(k0,a)]+partitionDescListMaybe p map0 = foldAssocsAsc' ins empty map0 -- We use Asc!! (strict)+ where ins k0 a map1 = case p a of+                       Nothing -> map1+                       Just k1 -> insertWith' ((k0,a):) k1 [(k0,a)] map1        -- Note use of insert'++like :: a -> a -> a+like a _ = a++-- | Use a map of the supplied type to sort a list of keys into ascending order+-- Slower than nubAscWith, but retains duplicate keys+sortAscWith :: OrderedMap map k => map Int -> [k] -> [k]+sortAscWith mp ks = concat [replicate n k | (k,n) <- as]+ where 	as = assocsAsc $ fromAssocsWith (+) (zip ks $ repeat 1) `like` mp++-- | Use a map of the supplied type to sort a list of keys into descending order+-- Slower than nubDescWith, but retains duplicate keys+sortDescWith :: OrderedMap map k => map Int -> [k] -> [k]+sortDescWith mp ks = concat [replicate n k | (k,n) <- as]+ where 	as = assocsDesc $ fromAssocsWith (+) (zip ks $ repeat 1) `like` mp++-- | Use a map of the supplied type to sort a list of keys into ascending order (eliminating duplicates).+nubAscWith :: OrderedMap map k => map () -> [k] -> [k]+nubAscWith mp ks = keysAsc $ fromAssocs (zip ks $ repeat ()) `like` mp++-- | Use a map of the supplied type to sort a list of keys into descending order (eliminating duplicates).+nubDescWith :: OrderedMap map k => map () -> [k] -> [k]+nubDescWith mp ks = keysDesc $ fromAssocs (zip ks $ repeat ()) `like` mp++-----------------------------------------------------------------------------------------------------------------------------------++-- | Instances of OrdMap must satisfy 'compareKey == Ord.compare'+-- class (OrderedMap map k, Ord k) => OrdMap map k+
+ src/Data/GMap/AssocList.hs view
@@ -0,0 +1,209 @@+{-# OPTIONS_GHC -fglasgow-exts -XNoMonomorphismRestriction -Wall -fno-warn-missing-signatures #-}++module Data.GMap.AssocList where++import Data.GMap +import qualified Data.List as L+import Data.Maybe(catMaybes,isNothing)+import Data.Ord+import GHC.Base++-- Unsorted assoc list with no duplicate keys+newtype AList k a = AL [(k,a)]++keyEq a b = (fst a) == (fst b)+keysOf = L.map fst+elemsAL = L.map snd+withKey k a = (k,a)++deleteByKey k = L.deleteBy keyEq (k,undefined)++-- Strictly evaluluate structure and keys but not elements.+force [] = []+force l@((k,_):rest) = k `seq` force rest `seq` l++seqMaybe Nothing b = b+seqMaybe (Just a) b = a `seq` b+	+al = AL . force++unboxInt (I# i) = i++instance Eq k => Map (AList k) k where+	+	empty = al []+	+	singleton k a = al [(k,a)]+	+	pair k1 k2 = +		if 	k1 == k2+		then	Nothing+		else	Just $ \ a1 a2 -> al [(k1,a1),(k2,a2)]+		 +	status (AL []) = None+	status (AL [(k,a)]) = One k a+	status _ = Many+	+	addSize (AL as) = (+#) (unboxInt (L.length as))+	+	lookup k (AL as) = L.lookup k as+	+	alter f k (AL as) = +		let 	ma = L.lookup k as+		in	case (ma, f ma) of+				(Nothing, Nothing) 	-> al as+				(Nothing, Just a) 	-> al $ (k,a):as+				(Just _, Nothing) 	-> al $ deleteByKey k as+				(Just _, Just a)	-> al $ ((k,a):) $ deleteByKey k as +				+	vennMaybe f (AL as) (AL bs) =+		let	leftDiff = 	[ (k,a) | (k,a) <- as , isNothing (L.lookup k bs) ]+			rightDiff = 	[ (k,b) | (k,b) <- bs , isNothing (L.lookup k as) ]+			inter =	+				let 	ks = L.intersect (keysOf as) (keysOf bs)+					assoc k = do+						a <- L.lookup k as+						b <- L.lookup k bs+						value <- f a b+						return (k,value)+				in	catMaybes (L.map assoc ks)+		in	(al leftDiff,al inter,al rightDiff)+				+	disjointUnion (AL as) (AL bs) = al (as ++ bs)+		+	isSubsetOf (AL as) (AL bs) = L.all (flip L.elem (keysOf bs)) (keysOf as)+	 +	isSubmapOf f (AL as) (AL bs) = L.all (\ (k,a) -> (Just True) == (fmap (f a) $ L.lookup k bs)) as+	+	map f (AL as) = al $ L.map (\(k,a) -> (k,f a)) as+	map' f (AL as) = al $ L.map (\(k,a) -> let a' = f a in a' `seq` (k,a')) as+	+	mapMaybe f (AL as) = al $ catMaybes $ L.map (\(k,a) -> fmap (withKey k) $ f a ) as+	+	mapWithKey f (AL as) = al $ L.map (\ (k,a) -> (k,f k a)) as+	mapWithKey' f (AL as) = al $ L.map (\(k,a) -> let a' = f k a in a' `seq` (k,a')) as+	+	filter f (AL as) = al $ L.filter (f . snd) as+	+	foldElems f b (AL as) = L.foldr f b $ elemsAL as+	foldKeys f b (AL as) = L.foldr f b $ keysOf as+	foldAssocs f b (AL as) = L.foldr (\(k,a) acc -> f k a acc) b as +	+	foldElems' f b (AL as) = L.foldl' (flip f) b $ elemsAL as+	foldKeys' f b (AL as) = L.foldl' (flip f) b $ keysOf as+	foldAssocs' f b (AL as) = L.foldl' (\acc (k,a) -> f k a acc) b as +	+	foldElemsUInt f i (AL as) = fold i as+		where	fold i' []     = i'+			fold i' ((_,a):as') = fold (f a i') as'+	+	valid (AL as) = +		if 	keysOf as == (L.nub $ keysOf as)+		then 	Nothing+		else	Just "Duplicate keys"+		+-- Sorted assoc list with no duplicate keys+-- The map argument is used to determine the ordering used+newtype SList (map :: * -> *) k a = SL [(k,a)] ++sl :: OrderedMap mp k => [(k,a)] -> SList mp k a+sl kas = +    let mp :: SList mp k a -> (mp a)+        mp = undefined+        result = SL $ force $ L.sortBy (\ (k1,_) (k2,_) -> compareKey (mp result) k1 k2) kas+    in  result++instance (Eq k, Ord k, OrderedMap mp k) => Map (SList mp k) k where+	empty = SL []+	+	singleton k a = SL [(k,a)]+	+	pair k1 k2 = +		if 	k1 == k2+		then	Nothing+		else	Just $ \ a1 a2 -> sl [(k1,a1),(k2,a2)]+		 +	status (SL []) = None+	status (SL [(k,a)]) = One k a+	status _ = Many+	+	addSize (SL as) = (+#) (unboxInt (L.length as))+	+	lookup k (SL as) = L.lookup k as+	+	alter f k (SL as) = +		let 	ma = L.lookup k as+		in	case (ma, f ma) of+				(Nothing, Nothing) 	-> SL as+				(Nothing, Just a) 	-> sl $ (k,a):as+				(Just _, Nothing) 	-> SL $ deleteByKey k as+				(Just _, Just a)	-> sl $ ((k,a):) $ deleteByKey k as +	+	vennMaybe f (SL as) (SL bs) =+		let	leftDiff = 	[ (k,a) | (k,a) <- as , isNothing (L.lookup k bs) ]+			rightDiff = 	[ (k,b) | (k,b) <- bs , isNothing (L.lookup k as) ]+			inter =	+				let 	ks = L.intersect (keysOf as) (keysOf bs)+					assoc k = do+						a <- L.lookup k as+						b <- L.lookup k bs+						value <- f a b+						return (k,value)+				in	catMaybes (L.map assoc ks)+		in	(sl leftDiff,sl inter,sl rightDiff)+				+	disjointUnion (SL as) (SL bs) = sl (as ++ bs)+		+	isSubsetOf (SL as) (SL bs) = L.all (flip L.elem (keysOf bs)) (keysOf as)  +	+	isSubmapOf f (SL as) (SL bs) = L.all (\ (k,a) -> (Just True) == (fmap (f a) $ L.lookup k bs)) as  +	+	map f (SL as) = sl $ L.map (\(k,a) -> (k,f a)) as+	map' f (SL as) = sl $ L.map (\(k,a) -> let a' = f a in a' `seq` (k,a')) as+	+	mapMaybe f (SL as) = sl $ catMaybes $ L.map (\(k,a) -> fmap (withKey k) $ f a ) as+	+	mapWithKey f (SL as) = sl $ L.map (\ (k,a) -> (k,f k a)) as+	mapWithKey' f (SL as) = sl $ L.map (\(k,a) -> let a' = f k a in a' `seq` (k,a')) as+	+	filter f (SL as) = SL $ L.filter (f . snd) as+	+	foldElems f b (SL as) = L.foldr f b $ elemsAL as+	foldKeys f b (SL as) = L.foldr f b $ keysOf as+	foldAssocs f b (SL as) = L.foldr (\(k,a) acc -> f k a acc) b as +	+	foldElems' f b (SL as) = L.foldl' (flip f) b $ reverse $ elemsAL as+	foldKeys' f b (SL as) = L.foldl' (flip f) b $ reverse $ keysOf as+	foldAssocs' f b (SL as) = L.foldl' (\acc (k,a) -> f k a acc) b $ reverse as +	+	foldElemsUInt f i (SL as) = fold i as+		where	fold i' []     = i'+			fold i' ((_,a):as') = fold (f a i') as'+	+	valid (SL as) +		| keysOf as /= (L.nub $ keysOf as)	= Just "Duplicate keys"+		| keysOf as /= (L.sort $ keysOf as)	= Just "Unsorted"+		| otherwise				= Nothing+		+instance (Eq k, Ord k, OrderedMap mp k) => OrderedMap (SList mp k) k where+	+	compareKey sl = compareKey (mp sl)+	   where mp :: SList mp k a -> (mp a)+	         mp = undefined +	+	foldAssocsAsc f b (SL as) = L.foldr (uncurry f) b as+	foldAssocsDesc f b (SL as) = L.foldr (uncurry f) b $ reverse as+	+	foldAssocsAsc' f b (SL as) = L.foldl' (flip $ uncurry f) b $ reverse as+	foldAssocsDesc' f b (SL as) = L.foldl' (flip $ uncurry f) b as+   	+-- A map type to tell SList to behave use standard Orderings+data ImaginaryOrdMap k a+instance Eq k => Map (ImaginaryOrdMap k) k+instance (Eq k, Ord k) => OrderedMap (ImaginaryOrdMap k) k where+    compareKey _ = compare++type OList k = SList (ImaginaryOrdMap k) k+	+	+-- instance (Eq k, Ord k) => OrdMap (SList k) k
+ src/Data/GMap/CacheKeys.hs view
@@ -0,0 +1,292 @@+{-# OPTIONS_GHC -fglasgow-exts -fno-monomorphism-restriction -fno-warn-orphans -fno-warn-unused-imports -fallow-undecidable-instances -Wall -fno-warn-missing-signatures #-}++module Data.GMap.CacheKeys+(-- * CacheKeys type+ CacheKeys+,cacheKeys+,uncacheKeys+) where++import Prelude hiding (foldr,map,filter,lookup)+import Data.GMap++import qualified Data.Monoid as M (Monoid(..))+import qualified Data.Foldable as F (Foldable(..))+import Data.Typeable+-- -fno-warn-unused-imports used because ghc currently gives spurious warning with this import+-- See Tickets 1074 and 1148+import qualified Data.List as L++import GHC.Base hiding (map)+import qualified Text.Read as R ++-- | A map transformer that causes keys to be cached alongside elements+data CacheKeys mp k a = CacheKeys !(mp (k,a))++instance (Map mp k) => Map (CacheKeys mp k) k where+	empty                 	= emptyCacheKeys+	singleton             	= singletonCacheKeys+	pair                  	= pairCacheKeys+	nonEmpty              	= nonEmptyCacheKeys+	status                	= statusCacheKeys+	addSize               	= addSizeCacheKeys+	lookup                	= lookupCacheKeys+	lookupCont              = lookupContCacheKeys+	alter			= alterCacheKeys+	insertWith            	= insertWithCacheKeys +	insertWith'           	= insertWithCacheKeys'+	insertMaybe           	= insertMaybeCacheKeys+	fromAssocsWith		= fromAssocsWithCacheKeys+	fromAssocsMaybe 	= fromAssocsMaybeCacheKeys+	delete                	= deleteCacheKeys +	adjustWith           	= adjustWithCacheKeys+	adjustWith' 		= adjustWithCacheKeys'+	adjustMaybe		= adjustMaybeCacheKeys+	venn			= vennCacheKeys+	venn'			= vennCacheKeys'+	vennMaybe		= vennMaybeCacheKeys+	union                 	= unionCacheKeys+	union'                	= unionCacheKeys'+	unionMaybe            	= unionMaybeCacheKeys+	disjointUnion		= disjointUnionCacheKeys+	intersection          	= intersectionCacheKeys+	intersection'         	= intersectionCacheKeys'+	intersectionMaybe     	= intersectionMaybeCacheKeys+	difference            	= differenceCacheKeys+	differenceMaybe       	= differenceMaybeCacheKeys+	isSubsetOf            	= isSubsetOfCacheKeys+	isSubmapOf             = isSubmapOfCacheKeys+	map                   	= mapCacheKeys+	map'                  	= mapCacheKeys'+	mapMaybe              	= mapMaybeCacheKeys+	mapWithKey            	= mapWithKeyCacheKeys+	mapWithKey'           	= mapWithKeyCacheKeys'+	filter                	= filterCacheKeys+	foldKeys		= foldKeysCacheKeys+	foldElems 		= foldElemsCacheKeys+	foldAssocs		= foldAssocsCacheKeys+	foldKeys'		= foldKeysCacheKeys'+	foldElems' 		= foldElemsCacheKeys'+	foldAssocs'		= foldAssocsCacheKeys'+	foldElemsUInt         	= foldElemsUIntCacheKeys+	valid                 	= validCacheKeys+ +instance (OrderedMap mp k) => OrderedMap (CacheKeys mp k) k where+	compareKey 	= compareKeyCacheKeys+	fromAssocsAscWith = fromAssocsAscWithCacheKeys+	fromAssocsDescWith = fromAssocsDescWithCacheKeys+	fromAssocsAscMaybe = fromAssocsAscMaybeCacheKeys+	fromAssocsDescMaybe = fromAssocsDescMaybeCacheKeys+	foldElemsAsc	= foldElemsAscCacheKeys+	foldElemsDesc	= foldElemsDescCacheKeys+	foldKeysAsc	= foldKeysAscCacheKeys+	foldKeysDesc	= foldKeysDescCacheKeys+	foldAssocsAsc	= foldAssocsAscCacheKeys+	foldAssocsDesc	= foldAssocsDescCacheKeys+	foldElemsAsc'	= foldElemsAscCacheKeys'+	foldElemsDesc'	= foldElemsDescCacheKeys'+	foldKeysAsc'	= foldKeysAscCacheKeys'+	foldKeysDesc'	= foldKeysDescCacheKeys'+	foldAssocsAsc'	= foldAssocsAscCacheKeys'+	foldAssocsDesc'	= foldAssocsDescCacheKeys'+	+cacheKeys :: Map mp k => mp a -> CacheKeys mp k a+cacheKeys mp = CacheKeys (mapWithKey' (,) mp)++uncacheKeys :: Map mp k => CacheKeys mp k a -> mp a+uncacheKeys (CacheKeys mp) = map' snd mp++on :: (c -> d) -> (a -> b -> c) -> a -> b -> d+on f g a b = f $ g a b+	+emptyCacheKeys = CacheKeys empty++singletonCacheKeys k a = CacheKeys (singleton k (k,a))++pairCacheKeys k1 k2 = (cacheKeys `on`) `fmap` (pair k1 k2)++nonEmptyCacheKeys (CacheKeys kmp) = CacheKeys `fmap` (nonEmpty kmp)++statusCacheKeys (CacheKeys kmp) = +	case (status kmp) of+		None -> None+		One k (_,a) -> One k a+		Many -> Many++addSizeCacheKeys (CacheKeys kmp) = addSize kmp++lookupCacheKeys k (CacheKeys kmp) = snd `fmap` (lookup k kmp)++lookupContCacheKeys f k (CacheKeys kmp) = lookupCont (f . snd) k kmp++withKey f (k,a) = let a' = f a in a' `seq` (k,a')+withKeyMaybe f (k,a) = do+	a' <- f a+	return (a' `seq` (k,a'))+withMaybeKeyMaybe f k mka = (\a' -> (k,a')) `fmap` (f (snd `fmap` mka))++alterCacheKeys f k (CacheKeys kmp) = CacheKeys (alter (withMaybeKeyMaybe f k) k kmp)++insertWithCacheKeys  f k a (CacheKeys kmp) = CacheKeys (insertWith  (withKey f) k (k,a) kmp)+insertWithCacheKeys' f k a (CacheKeys kmp) = CacheKeys (insertWith' (withKey f) k (a `seq` (k,a)) kmp)+insertMaybeCacheKeys f k a (CacheKeys kmp) = CacheKeys (insertMaybe (withKeyMaybe f) k (k,a) kmp)++deleteCacheKeys k (CacheKeys kmp) = CacheKeys (delete k kmp)++adjustWithCacheKeys  f k (CacheKeys kmp) = CacheKeys (adjustWith  (withKey f) k kmp)+adjustWithCacheKeys' f k (CacheKeys kmp) = CacheKeys (adjustWith' (withKey f) k kmp)+adjustMaybeCacheKeys f k (CacheKeys kmp) = CacheKeys (adjustMaybe (withKeyMaybe f) k kmp)++withKey2 f (k,a1) (_,a2) = let a' = f a1 a2 in a' `seq` (k,f a1 a2)+withKeyMaybe2 f (k,a1) (_,a2) = (\ a -> a `seq` (k,a)) `fmap` (f a1 a2)++vennCacheKeys  f (CacheKeys kmp1) (CacheKeys kmp2) = (CacheKeys leftDiff, CacheKeys inter, CacheKeys rightDiff)+	where (leftDiff,inter,rightDiff) = venn  (withKey2 f) kmp1 kmp2++vennCacheKeys' f (CacheKeys kmp1) (CacheKeys kmp2) = (CacheKeys leftDiff, CacheKeys inter, CacheKeys rightDiff)+	where (leftDiff,inter,rightDiff) = venn' (withKey2 f) kmp1 kmp2+	+vennMaybeCacheKeys f (CacheKeys kmp1) (CacheKeys kmp2) = (CacheKeys leftDiff, CacheKeys inter, CacheKeys rightDiff)+	where (leftDiff,inter,rightDiff) = vennMaybe (withKeyMaybe2 f) kmp1 kmp2++unionCacheKeys  f (CacheKeys kmp1) (CacheKeys kmp2) = CacheKeys (union  (withKey2 f) kmp1 kmp2)+unionCacheKeys' f (CacheKeys kmp1) (CacheKeys kmp2) = CacheKeys (union' (withKey2 f) kmp1 kmp2)+unionMaybeCacheKeys f (CacheKeys kmp1) (CacheKeys kmp2) = CacheKeys (unionMaybe (withKeyMaybe2 f) kmp1 kmp2)+disjointUnionCacheKeys (CacheKeys kmp1) (CacheKeys kmp2) = CacheKeys (disjointUnion kmp1 kmp2)++intersectionCacheKeys  f (CacheKeys kmp1) (CacheKeys kmp2) = CacheKeys (intersection  (withKey2 f) kmp1 kmp2)+intersectionCacheKeys' f (CacheKeys kmp1) (CacheKeys kmp2) = CacheKeys (intersection' (withKey2 f) kmp1 kmp2)+intersectionMaybeCacheKeys f (CacheKeys kmp1) (CacheKeys kmp2) = CacheKeys (intersectionMaybe (withKeyMaybe2 f) kmp1 kmp2)++differenceCacheKeys (CacheKeys kmp1) (CacheKeys kmp2) = CacheKeys (difference kmp1 kmp2)+differenceMaybeCacheKeys f (CacheKeys kmp1) (CacheKeys kmp2) = CacheKeys (differenceMaybe (withKeyMaybe2 f) kmp1 kmp2)++onAssoc f (_,a) = f a+onAssoc2 f (_,a) (_,b) = f a b++isSubsetOfCacheKeys   (CacheKeys kmp1) (CacheKeys kmp2) = isSubsetOf kmp1 kmp2+isSubmapOfCacheKeys f (CacheKeys kmp1) (CacheKeys kmp2) = isSubmapOf (onAssoc2 f) kmp1 kmp2++mapCacheKeys  f (CacheKeys kmp) = CacheKeys (map  (withKey f) kmp)+mapCacheKeys' f (CacheKeys kmp) = CacheKeys (map' (withKey f) kmp)+mapMaybeCacheKeys f (CacheKeys kmp) = CacheKeys (mapMaybe (withKeyMaybe f) kmp)+mapWithKeyCacheKeys  f (CacheKeys kmp) = CacheKeys (map  (\(k,a) -> (k,f k a)) kmp)+mapWithKeyCacheKeys' f (CacheKeys kmp) = CacheKeys (map' (\(k,a) -> let a' = f k a in a' `seq` (k,a')) kmp)++filterCacheKeys f (CacheKeys kmp) = CacheKeys (filter (onAssoc f) kmp)++foldElemsUIntCacheKeys f b (CacheKeys kmp) = foldElemsUInt  (onAssoc f) b kmp++validCacheKeys (CacheKeys kmp) = valid kmp++compareKeyCacheKeys cachemp k1 k2 = compareKey (innermp cachemp) k1 k2+	where 	innermp :: CacheKeys mp k a -> mp a+		innermp _ = undefined++fromAssocsWithCacheKeys      f kas = CacheKeys (fromAssocsWith      (withKey2 f)      [(k,(k,a)) | (k,a) <- kas])+fromAssocsMaybeCacheKeys     f kas = CacheKeys (fromAssocsMaybe     (withKeyMaybe2 f) [(k,(k,a)) | (k,a) <- kas])+fromAssocsAscWithCacheKeys   f kas = CacheKeys (fromAssocsAscWith   (withKey2 f)      [(k,(k,a)) | (k,a) <- kas])+fromAssocsDescWithCacheKeys  f kas = CacheKeys (fromAssocsDescWith  (withKey2 f)      [(k,(k,a)) | (k,a) <- kas])+fromAssocsAscMaybeCacheKeys  f kas = CacheKeys (fromAssocsAscMaybe  (withKeyMaybe2 f) [(k,(k,a)) | (k,a) <- kas])+fromAssocsDescMaybeCacheKeys f kas = CacheKeys (fromAssocsDescMaybe (withKeyMaybe2 f) [(k,(k,a)) | (k,a) <- kas])++foldKeysCacheKeys      f b (CacheKeys kmp) = foldKeys      f b kmp+foldKeysCacheKeys'     f b (CacheKeys kmp) = foldKeys'     f b kmp+foldKeysAscCacheKeys   f b (CacheKeys kmp) = foldKeysAsc   f b kmp+foldKeysDescCacheKeys  f b (CacheKeys kmp) = foldKeysDesc  f b kmp+foldKeysAscCacheKeys'  f b (CacheKeys kmp) = foldKeysAsc'  f b kmp+foldKeysDescCacheKeys' f b (CacheKeys kmp) = foldKeysDesc' f b kmp++foldElemsCacheKeys  f b (CacheKeys kmp) = foldElems  (onAssoc f) b kmp+foldElemsCacheKeys' f b (CacheKeys kmp) = foldElems' (onAssoc f) b kmp+foldElemsAscCacheKeys   f b (CacheKeys kmp) = foldElemsAsc   (onAssoc f) b kmp+foldElemsDescCacheKeys  f b (CacheKeys kmp) = foldElemsDesc  (onAssoc f) b kmp+foldElemsAscCacheKeys'  f b (CacheKeys kmp) = foldElemsAsc'  (onAssoc f) b kmp+foldElemsDescCacheKeys' f b (CacheKeys kmp) = foldElemsDesc' (onAssoc f) b kmp++foldAssocsCacheKeys  f b (CacheKeys kmp) = foldElems  (uncurry f) b kmp+foldAssocsCacheKeys' f b (CacheKeys kmp) = foldElems' (uncurry f) b kmp+foldAssocsAscCacheKeys   f b (CacheKeys kmp) = foldElemsAsc   (uncurry f) b kmp+foldAssocsDescCacheKeys  f b (CacheKeys kmp) = foldElemsDesc  (uncurry f) b kmp+foldAssocsAscCacheKeys'  f b (CacheKeys kmp) = foldElemsAsc'  (uncurry f) b kmp+foldAssocsDescCacheKeys' f b (CacheKeys kmp) = foldElemsDesc' (uncurry f) b kmp++--------------------------------------------------------------------------+--                         OTHER INSTANCES                              --+--------------------------------------------------------------------------++--------+-- Eq --+--------+instance (Eq (mp (k,a))) => Eq (CacheKeys mp k a) where+ (CacheKeys kmp1) == (CacheKeys kmp2) = (kmp1 == kmp2)++---------+-- Ord --+---------+instance (Ord (mp (k,a))) => Ord (CacheKeys mp k a) where+ compare (CacheKeys kmp1) (CacheKeys kmp2) = compare kmp1 kmp2++----------+-- Show --+----------+instance (Show k, Show a, Map mp k) => Show (CacheKeys mp k a) where+  showsPrec d mp  = showParen (d > 10) $+    showString "fromAssocs " . shows (assocs mp)++----------+-- Read --+----------+instance (Read k, Read a, Map mp k) => R.Read (CacheKeys mp k a) where+ readPrec = R.parens $ R.prec 10 $ do R.Ident "fromAssocs" <- R.lexP+                                      xs <- R.readPrec+                                      return (fromAssocs xs)+ readListPrec = R.readListPrecDefault++------------------------+-- Typeable/Typeable1 --+------------------------+instance (Typeable1 mp) => Typeable1 (CacheKeys mp k) where+ typeOf1 m = mkTyConApp (mkTyCon "Data.GMap.CacheKeys.CacheKeys") [typeOf1 innermp]+  where CacheKeys innermp = m -- This is just to get the type for innermp!!+--------------+instance (Typeable1 (CacheKeys mp k), Typeable a) => Typeable (CacheKeys mp k a) where+ typeOf = typeOfDefault++-------------+-- Functor --+-------------+instance (Map mp k) => Functor (CacheKeys mp k) where+-- fmap :: (a -> b) -> EitherMap mapL mapR a -> EitherMap mapL mapR b+   fmap = mapCacheKeys -- The lazy version++-----------------+-- Data.Monoid --+-----------------+instance (Map mp k, M.Monoid a) => M.Monoid (CacheKeys mp k a) where+-- mempty :: EitherMap mapL mapR a+   mempty = emptyCacheKeys+-- mappend :: EitherMap mapL mapR a -> EitherMap mapL mapR a -> EitherMap mapL mapR a+   mappend map0 map1 = unionCacheKeys M.mappend map0 map1+-- mconcat :: [EitherMap mapL mapR a] -> EitherMap mapL mapR a+   mconcat maps = L.foldr (unionCacheKeys M.mappend) emptyCacheKeys maps++-------------------+-- Data.Foldable --+-------------------+instance (Map mp k) => F.Foldable (CacheKeys mp k) where+-- fold :: Monoid m => CacheKeys mapL mapR m -> m+   fold mp = foldElemsCacheKeys M.mappend M.mempty mp+-- foldMap :: Monoid m => (a -> m) -> CacheKeys mapL mapR a -> m+   foldMap f mp = foldElemsCacheKeys (\a b -> M.mappend (f a) b) M.mempty mp+-- fold :: (a -> b -> b) -> b -> CacheKeys mapL mapR a -> b+   foldr f b0 mp = foldElemsCacheKeys f b0 mp+-- foldl :: (a -> b -> a) -> a -> CacheKeys mapL mapR b -> a+   foldl f b0 mp = foldElemsCacheKeys (flip f) b0 mp+{- ToDo: Implement properly. Meantime Foldable class has suitable defaults via lists.+-- fold1 :: (a -> a -> a) -> CacheKeys mapL mapR a -> a+   fold1 = undefined+-- foldl1 :: (a -> a -> a) -> CacheKeys mapL mapR a -> a+   foldl1 = undefined+-}+
+ src/Data/GMap/ChoiceMap.hs view
@@ -0,0 +1,601 @@+{-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans -fno-warn-unused-imports -fallow-undecidable-instances -Wall #-}++module Data.GMap.ChoiceMap+(Choice2(C1of2,C2of2)+,Choice2Map+,Choice3(C1of3,C2of3,C3of3)+,Choice3Map+,Choice4(C1of4,C2of4,C3of4,C4of4)+,Choice4Map+,Choice5(C1of5,C2of5,C3of5,C4of5,C5of5)+,Choice5Map+) where++import Prelude hiding (foldr,map,filter,lookup)+import Data.GMap+import Data.GMap.InjectKeys++import qualified Data.Monoid as M (Monoid(..))+import qualified Data.Foldable as F (Foldable(..))+import Data.Typeable+-- -fno-warn-unused-imports used because ghc currently gives spurious warning with this import+-- See Tickets 1074 and 1148+import qualified Data.List as L++import GHC.Base hiding (map)+import qualified Text.Read as R (Read(..),Lexeme(..),parens,prec,lexP,readListPrecDefault)++data Choice2 a b = C1of2 a | C2of2 b deriving (Eq,Ord,Read,Show)++-- | The 'Map' type for keys of form @('Map' mapL kL, 'Map' mapR kR) => 'Choice2' kL kR@.+data Choice2Map mapL mapR kL kR a = Choice2Map !(mapL a) !(mapR a)++-- Needs -fallow-undecidable-instances due to coverage condition+instance (Map mapL kL, Map mapR kR) => Map (Choice2Map mapL mapR kL kR) (Choice2 kL kR) where+	empty                 	= emptyChoice2Map+	singleton             	= singletonChoice2Map+	pair                  	= pairChoice2Map+	nonEmpty              	= nonEmptyChoice2Map+	status                	= statusChoice2Map+	addSize               	= addSizeChoice2Map+	lookup                	= lookupChoice2Map+	--lookupCont            = lookupContChoice2Map+	alter			= alterChoice2Map+	insertWith            	= insertWithChoice2Map +	insertWith'           	= insertWithChoice2Map'+	insertMaybe           	= insertMaybeChoice2Map+	fromAssocsWith		= fromAssocsWithChoice2Map +	fromAssocsMaybe 	= fromAssocsMaybeChoice2Map+	delete                	= deleteChoice2Map +	adjustWith           	= adjustWithChoice2Map+	adjustWith' 		= adjustWithChoice2Map'+	adjustMaybe		= adjustMaybeChoice2Map+	venn			= vennChoice2Map+	venn'			= vennChoice2Map'+	vennMaybe		= vennMaybeChoice2Map+	disjointUnion		= disjointUnionChoice2Map+	union                 	= unionChoice2Map+	union'                	= unionChoice2Map'+	unionMaybe            	= unionMaybeChoice2Map+	intersection          	= intersectionChoice2Map+	intersection'         	= intersectionChoice2Map'+	intersectionMaybe     	= intersectionMaybeChoice2Map+	difference            	= differenceChoice2Map+	differenceMaybe       	= differenceMaybeChoice2Map+	isSubsetOf            	= isSubsetOfChoice2Map+	isSubmapOf              = isSubmapOfChoice2Map+	map                   	= mapChoice2Map+	map'                  	= mapChoice2Map'+	mapMaybe              	= mapMaybeChoice2Map+	mapWithKey            	= mapWithKeyChoice2Map+	mapWithKey'           	= mapWithKeyChoice2Map'+	filter                	= filterChoice2Map+	foldKeys		= foldKeysChoice2Map+	foldElems 		= foldElemsChoice2Map+	foldAssocs		= foldAssocsChoice2Map+	foldKeys'		= foldKeysChoice2Map'+	foldElems' 		= foldElemsChoice2Map'+	foldAssocs'		= foldAssocsChoice2Map'+	foldElemsUInt         	= foldElemsUIntChoice2Map+	valid                 	= validChoice2Map+ +instance (OrderedMap mapL kL, OrderedMap mapR kR) => OrderedMap (Choice2Map mapL mapR kL kR) (Choice2 kL kR) where+	compareKey 	= compareKeyChoice2Map+	fromAssocsAscWith = fromAssocsAscWithChoice2Map+	fromAssocsDescWith = fromAssocsDescWithChoice2Map+	fromAssocsAscMaybe = fromAssocsAscMaybeChoice2Map+	fromAssocsDescMaybe = fromAssocsDescMaybeChoice2Map+	foldElemsAsc	= foldElemsAscChoice2Map+	foldElemsDesc	= foldElemsDescChoice2Map+	foldKeysAsc	= foldKeysAscChoice2Map+	foldKeysDesc	= foldKeysDescChoice2Map+	foldAssocsAsc	= foldAssocsAscChoice2Map+	foldAssocsDesc	= foldAssocsDescChoice2Map+	foldElemsAsc'	= foldElemsAscChoice2Map'+	foldElemsDesc'	= foldElemsDescChoice2Map'+	foldKeysAsc'	= foldKeysAscChoice2Map'+	foldKeysDesc'	= foldKeysDescChoice2Map'+	foldAssocsAsc'	= foldAssocsAscChoice2Map'+	foldAssocsDesc'	= foldAssocsDescChoice2Map'+	+-- | See 'Map' class method 'empty'.+emptyChoice2Map :: (Map mapL kL, Map mapR kR) => Choice2Map mapL mapR kL kR a+emptyChoice2Map = Choice2Map empty empty++-- | See 'Map' class method 'singleton'.+singletonChoice2Map :: (Map mapL kL, Map mapR kR) => Choice2 kL kR -> a -> Choice2Map mapL mapR kL kR a+singletonChoice2Map (C1of2  kL) a = Choice2Map (singleton kL a) empty+singletonChoice2Map (C2of2 kR) a = Choice2Map empty (singleton kR a)++-- | See 'Map' class method 'pair'.+pairChoice2Map :: (Map mapL kL, Map mapR kR) => Choice2 kL kR -> Choice2 kL kR -> Maybe (a -> a -> Choice2Map mapL mapR kL kR a)+pairChoice2Map (C1of2  k0) (C1of2  k1) = case pair k0 k1 of+                                     Nothing -> Nothing+                                     Just f  -> Just (\a0 a1 -> Choice2Map (f a0 a1) empty)+pairChoice2Map (C1of2  kL) (C2of2 kR) = Just (\aL aR -> Choice2Map (singleton kL aL) (singleton kR aR))+pairChoice2Map (C2of2 kR) (C1of2  kL) = Just (\aR aL -> Choice2Map (singleton kL aL) (singleton kR aR))+pairChoice2Map (C2of2 k0) (C2of2 k1) = case pair k0 k1 of+                                     Nothing -> Nothing+                                     Just f  -> Just (\a0 a1 -> Choice2Map empty (f a0 a1))++-- | See 'Map' class method 'nonEmpty'.+nonEmptyChoice2Map :: (Map mapL kL, Map mapR kR) => Choice2Map mapL mapR kL kR a -> Maybe (Choice2Map mapL mapR kL kR a)+nonEmptyChoice2Map egt = if isEmpty egt then Nothing else Just egt++-- | See 'Map' class method 'status'.+statusChoice2Map :: (Map mapL kL, Map mapR kR) => Choice2Map mapL mapR kL kR a -> Status (Choice2 kL kR) a+statusChoice2Map (Choice2Map mapL mapR) = s (status mapL) (status mapR) where+ s None        None        = None+ s None        (One kR aR) = One (C2of2 kR) aR+ s (One kL aL) None        = One (C1of2  kL) aL+ s _           _           = Many++-- | See 'Map' class method 'addSize'.+addSizeChoice2Map :: (Map mapL kL, Map mapR kR) => Choice2Map mapL mapR kL kR a -> Int# -> Int#+addSizeChoice2Map (Choice2Map mapL mapR) n = addSize mapL (addSize mapR n)++-- | See 'Map' class method 'lookup'.+lookupChoice2Map :: (Map mapL kL, Map mapR kR) => Choice2 kL kR -> Choice2Map mapL mapR kL kR a -> Maybe a+lookupChoice2Map (C1of2  kL) (Choice2Map mapL _   ) = lookup kL mapL+lookupChoice2Map (C2of2 kR) (Choice2Map _    mapR) = lookup kR mapR++-- | See 'Map' class method 'alter'.+alterChoice2Map :: (Map mapL kL, Map mapR kR) => (Maybe a -> Maybe a) -> Choice2 kL kR -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR a+alterChoice2Map f (C1of2  kL) (Choice2Map mapL mapR) = Choice2Map (alter f kL mapL) mapR+alterChoice2Map f (C2of2 kR) (Choice2Map mapL mapR) = Choice2Map mapL (alter f kR mapR)++-- | See 'Map' class method 'insert'.+insertWithChoice2Map :: (Map mapL kL, Map mapR kR) => (a -> a) -> Choice2 kL kR -> a -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR a+insertWithChoice2Map f (C1of2  kL) a (Choice2Map mapL mapR) = Choice2Map (insertWith f kL a mapL) mapR+insertWithChoice2Map f (C2of2 kR) a (Choice2Map mapL mapR) = Choice2Map mapL (insertWith f kR a mapR)++-- | See 'Map' class method 'insert''.+insertWithChoice2Map' :: (Map mapL kL, Map mapR kR) => (a -> a) -> Choice2 kL kR -> a -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR a+insertWithChoice2Map' f (C1of2  kL) a (Choice2Map mapL mapR) = Choice2Map (insertWith' f kL a mapL) mapR+insertWithChoice2Map' f (C2of2 kR) a (Choice2Map mapL mapR) = Choice2Map mapL (insertWith' f kR a mapR)++-- | See 'Map' class method 'insertMaybe'.+insertMaybeChoice2Map :: (Map mapL kL, Map mapR kR) => (a -> Maybe a) -> Choice2 kL kR -> a -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR a+insertMaybeChoice2Map f (C1of2  kL) a (Choice2Map mapL mapR) = Choice2Map (insertMaybe f kL a mapL) mapR+insertMaybeChoice2Map f (C2of2 kR) a (Choice2Map mapL mapR) = Choice2Map mapL (insertMaybe f kR a mapR)++isC1of2 :: Choice2 a b -> Bool+isC1of2 (C1of2 _) = True+isC1of2 (C2of2 _) = False++isC2of2 :: Choice2 a b -> Bool+isC2of2 (C1of2 _) = False +isC2of2 (C2of2 _) = True++fromAssocsWithChoice2Map :: (Map mapL kL, Map mapR kR) => (a -> a -> a) -> [(Choice2 kL kR,a)] -> Choice2Map mapL mapR kL kR a+fromAssocsWithChoice2Map f as = Choice2Map (fromAssocsWith f ls) (fromAssocsWith f rs)+	where	ls = L.map (\((C1of2 k), a) -> (k,a)) lefts+		rs = L.map (\((C2of2 k), a) -> (k,a)) rights+		(lefts,rights) = L.partition (isC1of2 . fst) as+		+fromAssocsMaybeChoice2Map :: (Map mapL kL, Map mapR kR) => (a -> a -> Maybe a) -> [(Choice2 kL kR,a)] -> Choice2Map mapL mapR kL kR a+fromAssocsMaybeChoice2Map f as = Choice2Map (fromAssocsMaybe f ls) (fromAssocsMaybe f rs)+	where	ls = L.map (\((C1of2 k), a) -> (k,a)) lefts+		rs = L.map (\((C2of2 k), a) -> (k,a)) rights+		(lefts,rights) = L.partition (isC1of2 . fst) as+		+fromAssocsAscWithChoice2Map :: (OrderedMap mapL kL, OrderedMap mapR kR) => (a -> a -> a) -> [(Choice2 kL kR,a)] -> Choice2Map mapL mapR kL kR a+fromAssocsAscWithChoice2Map f as = Choice2Map (fromAssocsAscWith f ls) (fromAssocsAscWith f rs)+	where	ls = L.map (\((C1of2 k), a) -> (k,a)) lefts+		rs = L.map (\((C2of2 k), a) -> (k,a)) rights+		(lefts,rights) = L.span (isC1of2 . fst) as+		+fromAssocsAscMaybeChoice2Map :: (OrderedMap mapL kL, OrderedMap mapR kR) => (a -> a -> Maybe a) -> [(Choice2 kL kR,a)] -> Choice2Map mapL mapR kL kR a+fromAssocsAscMaybeChoice2Map f as = Choice2Map (fromAssocsAscMaybe f ls) (fromAssocsAscMaybe f rs)+	where	ls = L.map (\((C1of2 k), a) -> (k,a)) lefts+		rs = L.map (\((C2of2 k), a) -> (k,a)) rights+		(lefts,rights) = L.span (isC1of2 . fst) as+		+fromAssocsDescWithChoice2Map :: (OrderedMap mapL kL, OrderedMap mapR kR) => (a -> a -> a) -> [(Choice2 kL kR,a)] -> Choice2Map mapL mapR kL kR a+fromAssocsDescWithChoice2Map f as = Choice2Map (fromAssocsDescWith f ls) (fromAssocsDescWith f rs)+	where	ls = L.map (\((C1of2 k), a) -> (k,a)) lefts+		rs = L.map (\((C2of2 k), a) -> (k,a)) rights+		(rights,lefts) = L.span (isC2of2 . fst) as+		+fromAssocsDescMaybeChoice2Map :: (OrderedMap mapL kL, OrderedMap mapR kR) => (a -> a -> Maybe a) -> [(Choice2 kL kR,a)] -> Choice2Map mapL mapR kL kR a+fromAssocsDescMaybeChoice2Map f as = Choice2Map (fromAssocsDescMaybe f ls) (fromAssocsDescMaybe f rs)+	where	ls = L.map (\((C1of2 k), a) -> (k,a)) lefts+		rs = L.map (\((C2of2 k), a) -> (k,a)) rights+		(rights,lefts) = L.span (isC2of2 . fst) as++-- | See 'Map' class method 'delete'.+deleteChoice2Map :: (Map mapL kL, Map mapR kR) => Choice2 kL kR -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR a+deleteChoice2Map (C1of2  kL) (Choice2Map mapL mapR) = Choice2Map (delete kL mapL) mapR+deleteChoice2Map (C2of2 kR) (Choice2Map mapL mapR) = Choice2Map mapL (delete kR mapR)++-- | See 'Map' class method 'adjustWith'.+adjustWithChoice2Map :: (Map mapL kL, Map mapR kR) => (a -> a) -> Choice2 kL kR -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR a+adjustWithChoice2Map f (C1of2  kL) (Choice2Map mapL mapR) = Choice2Map (adjustWith f kL mapL) mapR+adjustWithChoice2Map f (C2of2 kR) (Choice2Map mapL mapR) = Choice2Map mapL (adjustWith f kR mapR)++-- | See 'Map' class method 'adjustWith'.+adjustWithChoice2Map' :: (Map mapL kL, Map mapR kR) => (a -> a) -> Choice2 kL kR -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR a+adjustWithChoice2Map' f (C1of2  kL) (Choice2Map mapL mapR) = Choice2Map (adjustWith' f kL mapL) mapR+adjustWithChoice2Map' f (C2of2 kR) (Choice2Map mapL mapR) = Choice2Map mapL (adjustWith' f kR mapR)++-- | See 'Map' class method 'adjustMaybe'.+adjustMaybeChoice2Map :: (Map mapL kL, Map mapR kR) => (a -> Maybe a) -> Choice2 kL kR -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR a+adjustMaybeChoice2Map f (C1of2  kL) (Choice2Map mapL mapR) = Choice2Map (adjustMaybe f kL mapL) mapR+adjustMaybeChoice2Map f (C2of2 kR) (Choice2Map mapL mapR) = Choice2Map mapL (adjustMaybe f kR mapR)++-- | See 'Map' class method 'venn'.+vennChoice2Map :: (Map mapL kL, Map mapR kR) => (a -> b -> c) -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR b -> (Choice2Map mapL mapR kL kR a, Choice2Map mapL mapR kL kR c, Choice2Map mapL mapR kL kR b)+vennChoice2Map f (Choice2Map mapL0 mapR0) (Choice2Map mapL1 mapR1) =+ (Choice2Map leftDiffL leftDiffR, Choice2Map interL interR, Choice2Map rightDiffL rightDiffR)+ where (leftDiffL, interL, rightDiffL) = venn f mapL0 mapL1+       (leftDiffR, interR, rightDiffR) = venn f mapR0 mapR1+       +-- | See 'Map' class method 'venn''.+vennChoice2Map' :: (Map mapL kL, Map mapR kR) => (a -> b -> c) -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR b -> (Choice2Map mapL mapR kL kR a, Choice2Map mapL mapR kL kR c, Choice2Map mapL mapR kL kR b)+vennChoice2Map' f (Choice2Map mapL0 mapR0) (Choice2Map mapL1 mapR1) =+ (Choice2Map leftDiffL leftDiffR, Choice2Map interL interR, Choice2Map rightDiffL rightDiffR)+ where (leftDiffL, interL, rightDiffL) = venn' f mapL0 mapL1+       (leftDiffR, interR, rightDiffR) = venn' f mapR0 mapR1+       +-- | See 'Map' class method 'vennMaybe'.+vennMaybeChoice2Map :: (Map mapL kL, Map mapR kR) => (a -> b -> Maybe c) -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR b -> (Choice2Map mapL mapR kL kR a, Choice2Map mapL mapR kL kR c, Choice2Map mapL mapR kL kR b)+vennMaybeChoice2Map f (Choice2Map mapL0 mapR0) (Choice2Map mapL1 mapR1) =+ (Choice2Map leftDiffL leftDiffR, Choice2Map interL interR, Choice2Map rightDiffL rightDiffR)+ where (leftDiffL, interL, rightDiffL) = vennMaybe f mapL0 mapL1+       (leftDiffR, interR, rightDiffR) = vennMaybe f mapR0 mapR1++-- | See 'Map' class method 'disjointUnion'.+disjointUnionChoice2Map :: (Map mapL kL, Map mapR kR) => Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR a+disjointUnionChoice2Map (Choice2Map mapL0 mapR0) (Choice2Map mapL1 mapR1) =+ Choice2Map (disjointUnion mapL0 mapL1) (disjointUnion mapR0 mapR1)++-- | See 'Map' class method 'union'.+unionChoice2Map :: (Map mapL kL, Map mapR kR) => (a -> a -> a) -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR a+unionChoice2Map f (Choice2Map mapL0 mapR0) (Choice2Map mapL1 mapR1) =+ Choice2Map (union f mapL0 mapL1) (union f mapR0 mapR1)++-- | See 'Map' class method 'union''.+unionChoice2Map' :: (Map mapL kL, Map mapR kR) => (a -> a -> a) -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR a+unionChoice2Map' f (Choice2Map mapL0 mapR0) (Choice2Map mapL1 mapR1) =+ Choice2Map (union' f mapL0 mapL1) (union' f mapR0 mapR1)++-- | See 'Map' class method 'unionMaybe'.+unionMaybeChoice2Map :: (Map mapL kL, Map mapR kR) => (a -> a -> Maybe a) -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR a+unionMaybeChoice2Map f (Choice2Map mapL0 mapR0) (Choice2Map mapL1 mapR1) =+ Choice2Map (unionMaybe f mapL0 mapL1) (unionMaybe f mapR0 mapR1)++-- | See 'Map' class method 'intersection'.+intersectionChoice2Map :: (Map mapL kL, Map mapR kR) => (a -> b -> c) -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR b -> Choice2Map mapL mapR kL kR c+intersectionChoice2Map f (Choice2Map mapL0 mapR0) (Choice2Map mapL1 mapR1) =+ Choice2Map (intersection f mapL0 mapL1) (intersection f mapR0 mapR1)++-- | See 'Map' class method 'intersection''.+intersectionChoice2Map' :: (Map mapL kL, Map mapR kR) => (a -> b -> c) -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR b -> Choice2Map mapL mapR kL kR c+intersectionChoice2Map' f (Choice2Map mapL0 mapR0) (Choice2Map mapL1 mapR1) =+ Choice2Map (intersection' f mapL0 mapL1) (intersection' f mapR0 mapR1)++-- | See 'Map' class method 'intersectionMaybe'.+intersectionMaybeChoice2Map :: (Map mapL kL, Map mapR kR) => (a -> b -> Maybe c) -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR b -> Choice2Map mapL mapR kL kR c+intersectionMaybeChoice2Map f (Choice2Map mapL0 mapR0) (Choice2Map mapL1 mapR1) =+ Choice2Map (intersectionMaybe f mapL0 mapL1) (intersectionMaybe f mapR0 mapR1)++-- | See 'Map' class method 'difference'.+differenceChoice2Map :: (Map mapL kL, Map mapR kR) => Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR b -> Choice2Map mapL mapR kL kR a+differenceChoice2Map (Choice2Map mapL0 mapR0) (Choice2Map mapL1 mapR1) =+ Choice2Map (difference mapL0 mapL1) (difference mapR0 mapR1)++-- | See 'Map' class method 'differenceMaybe'.+differenceMaybeChoice2Map :: (Map mapL kL, Map mapR kR) => (a -> b -> Maybe a) -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR b -> Choice2Map mapL mapR kL kR a+differenceMaybeChoice2Map f (Choice2Map mapL0 mapR0) (Choice2Map mapL1 mapR1) =+ Choice2Map (differenceMaybe f mapL0 mapL1) (differenceMaybe f mapR0 mapR1)++-- | See 'Map' class method 'isSubsetOf'.+isSubsetOfChoice2Map :: (Map mapL kL, Map mapR kR) => Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR b -> Bool+isSubsetOfChoice2Map (Choice2Map mapL0 mapR0) (Choice2Map mapL1 mapR1) =+ isSubsetOf mapL0 mapL1 && isSubsetOf mapR0 mapR1++-- | See 'Map' class method 'isSubmapOf'.+isSubmapOfChoice2Map :: (Map mapL kL, Map mapR kR) => (a -> b -> Bool) -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR b -> Bool+isSubmapOfChoice2Map f (Choice2Map mapL0 mapR0) (Choice2Map mapL1 mapR1) =+ isSubmapOf f mapL0 mapL1 && isSubmapOf f mapR0 mapR1++-- | See 'Map' class method 'map'.+mapChoice2Map :: (Map mapL kL, Map mapR kR) => (a -> b) -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR b+mapChoice2Map f (Choice2Map mapL mapR) = Choice2Map (map f mapL) (map f mapR)++-- | See 'Map' class method 'map''.+mapChoice2Map' :: (Map mapL kL, Map mapR kR) => (a -> b) -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR b+mapChoice2Map' f (Choice2Map mapL mapR) = Choice2Map (map' f mapL) (map' f mapR)++-- | See 'Map' class method 'mapMaybe'.+mapMaybeChoice2Map :: (Map mapL kL, Map mapR kR) => (a -> Maybe b) -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR b+mapMaybeChoice2Map f (Choice2Map mapL mapR) = Choice2Map (mapMaybe f mapL) (mapMaybe f mapR)++-- | See 'Map' class method 'mapWithKey'.+mapWithKeyChoice2Map :: (Map mapL kL, Map mapR kR) => (Choice2 kL kR -> a -> b) -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR b+mapWithKeyChoice2Map f (Choice2Map mapL mapR) =+ Choice2Map (mapWithKey (\kL a -> f (C1of2 kL) a) mapL) (mapWithKey (\kR a -> f (C2of2 kR) a) mapR)++-- | See 'Map' class method 'mapWithKey''.+mapWithKeyChoice2Map' :: (Map mapL kL, Map mapR kR) => (Choice2 kL kR -> a -> b) -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR b+mapWithKeyChoice2Map' f (Choice2Map mapL mapR) =+ Choice2Map (mapWithKey' (\kL a -> f (C1of2 kL) a) mapL) (mapWithKey' (\kR a -> f (C2of2 kR) a) mapR)++-- | See 'Map' class method 'filter'.+filterChoice2Map :: (Map mapL kL, Map mapR kR) => (a -> Bool) -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR a+filterChoice2Map p (Choice2Map mapL mapR) = Choice2Map (filter p mapL) (filter p mapR)++-- | See 'Map' class method 'foldElems'.+foldElemsChoice2Map :: (Map mapL kL, Map mapR kR) => (a -> b -> b) -> b -> Choice2Map mapL mapR kL kR a -> b+foldElemsChoice2Map f b (Choice2Map mapL mapR) =+ foldElems f (foldElems f b mapR) mapL++-- | See 'Map' class method 'foldKeys'.+foldKeysChoice2Map :: (Map mapL kL, Map mapR kR) => (Choice2 kL kR -> b -> b) -> b -> Choice2Map mapL mapR kL kR a -> b+foldKeysChoice2Map f b0 (Choice2Map mapL mapR) =+ foldKeys (\kL b -> f (C1of2 kL) b) (foldKeys (\kR b -> f (C2of2 kR) b) b0 mapR) mapL++-- | See 'Map' class method 'foldAssocs'.+foldAssocsChoice2Map :: (Map mapL kL, Map mapR kR) => (Choice2 kL kR -> a -> b -> b) -> b -> Choice2Map mapL mapR kL kR a -> b+foldAssocsChoice2Map f b0 (Choice2Map mapL mapR) =+ foldAssocs (\kL a b -> f (C1of2 kL) a b) (foldAssocs (\kR a b -> f (C2of2 kR) a b) b0 mapR) mapL++-- | See 'Map' class method 'foldElems''.+foldElemsChoice2Map' :: (Map mapL kL, Map mapR kR) => (a -> b -> b) -> b -> Choice2Map mapL mapR kL kR a -> b+foldElemsChoice2Map' f b (Choice2Map mapL mapR) =+ (\z -> foldElems' f z mapL) $! foldElems' f b mapR+ +-- | See 'Map' class method 'foldKeys''.+foldKeysChoice2Map' :: (Map mapL kL, Map mapR kR) => (Choice2 kL kR -> b -> b) -> b -> Choice2Map mapL mapR kL kR a -> b+foldKeysChoice2Map' f b0 (Choice2Map mapL mapR) =+ (\z -> foldKeys' (\kL b -> f (C1of2 kL) b) z mapL) $! foldKeys' (\kR b -> f (C2of2 kR) b) b0 mapR++-- | See 'Map' class method 'foldAssocs''.+foldAssocsChoice2Map' :: (Map mapL kL, Map mapR kR) => (Choice2 kL kR -> a -> b -> b) -> b -> Choice2Map mapL mapR kL kR a -> b+foldAssocsChoice2Map' f b0 (Choice2Map mapL mapR) =+ (\z -> foldAssocs' (\kL a b -> f (C1of2 kL) a b) z mapL) $! foldAssocs' (\kR a b -> f (C2of2 kR) a b) b0 mapR+ + ------------------------++-- | See 'Map' class method 'foldElemsAsc'.+foldElemsAscChoice2Map :: (OrderedMap mapL kL, OrderedMap mapR kR) => (a -> b -> b) -> b -> Choice2Map mapL mapR kL kR a -> b+foldElemsAscChoice2Map f b (Choice2Map mapL mapR) =+ foldElemsAsc f (foldElemsAsc f b mapR) mapL++-- | See 'Map' class method 'foldElemsDesc'.+foldElemsDescChoice2Map :: (OrderedMap mapL kL, OrderedMap mapR kR) => (a -> b -> b) -> b -> Choice2Map mapL mapR kL kR a -> b+foldElemsDescChoice2Map f b (Choice2Map mapL mapR) =+ foldElemsDesc f (foldElemsDesc f b mapL) mapR++-- | See 'Map' class method 'foldKeysAsc'.+foldKeysAscChoice2Map :: (OrderedMap mapL kL, OrderedMap mapR kR) => (Choice2 kL kR -> b -> b) -> b -> Choice2Map mapL mapR kL kR a -> b+foldKeysAscChoice2Map f b0 (Choice2Map mapL mapR) =+ foldKeysAsc (\kL b -> f (C1of2 kL) b) (foldKeysAsc (\kR b -> f (C2of2 kR) b) b0 mapR) mapL++-- | See 'Map' class method 'foldKeysDesc'.+foldKeysDescChoice2Map :: (OrderedMap mapL kL, OrderedMap mapR kR) => (Choice2 kL kR -> b -> b) -> b -> Choice2Map mapL mapR kL kR a -> b+foldKeysDescChoice2Map f b0 (Choice2Map mapL mapR) =+ foldKeysDesc (\kR b -> f (C2of2 kR) b) (foldKeysDesc (\kL b -> f (C1of2 kL) b) b0 mapL) mapR++-- | See 'Map' class method 'foldAssocsAsc'.+foldAssocsAscChoice2Map :: (OrderedMap mapL kL, OrderedMap mapR kR) => (Choice2 kL kR -> a -> b -> b) -> b -> Choice2Map mapL mapR kL kR a -> b+foldAssocsAscChoice2Map f b0 (Choice2Map mapL mapR) =+ foldAssocsAsc (\kL a b -> f (C1of2 kL) a b) (foldAssocsAsc (\kR a b -> f (C2of2 kR) a b) b0 mapR) mapL++-- | See 'Map' class method 'foldAssocsDesc'.+foldAssocsDescChoice2Map :: (OrderedMap mapL kL, OrderedMap mapR kR) => (Choice2 kL kR -> a -> b -> b) -> b -> Choice2Map mapL mapR kL kR a -> b+foldAssocsDescChoice2Map f b0 (Choice2Map mapL mapR) =+ foldAssocsDesc (\kR a b -> f (C2of2 kR) a b) (foldAssocsDesc (\kL a b -> f (C1of2 kL) a b) b0 mapL) mapR++-- | See 'Map' class method 'foldElemsAsc''.+foldElemsAscChoice2Map' :: (OrderedMap mapL kL, OrderedMap mapR kR) => (a -> b -> b) -> b -> Choice2Map mapL mapR kL kR a -> b+foldElemsAscChoice2Map' f b (Choice2Map mapL mapR) =+ (\z -> foldElemsAsc' f z mapL) $! foldElemsAsc' f b mapR++-- | See 'Map' class method 'foldElemsDesc''.+foldElemsDescChoice2Map' :: (OrderedMap mapL kL, OrderedMap mapR kR) => (a -> b -> b) -> b -> Choice2Map mapL mapR kL kR a -> b+foldElemsDescChoice2Map' f b (Choice2Map mapL mapR) =+ (\z -> foldElemsDesc' f z mapR) $! foldElemsDesc' f b mapL++-- | See 'Map' class method 'foldKeysAsc''.+foldKeysAscChoice2Map' :: (OrderedMap mapL kL, OrderedMap mapR kR) => (Choice2 kL kR -> b -> b) -> b -> Choice2Map mapL mapR kL kR a -> b+foldKeysAscChoice2Map' f b0 (Choice2Map mapL mapR) =+ (\z -> foldKeysAsc' (\kL b -> f (C1of2 kL) b) z mapL) $! foldKeysAsc' (\kR b -> f (C2of2 kR) b) b0 mapR++-- | See 'Map' class method 'foldKeysDesc''.+foldKeysDescChoice2Map' :: (OrderedMap mapL kL, OrderedMap mapR kR) => (Choice2 kL kR -> b -> b) -> b -> Choice2Map mapL mapR kL kR a -> b+foldKeysDescChoice2Map' f b0 (Choice2Map mapL mapR) =+ (\z -> foldKeysDesc' (\kR b -> f (C2of2 kR) b) z mapR) $! foldKeysDesc' (\kL b -> f (C1of2 kL) b) b0 mapL++-- | See 'Map' class method 'foldAssocsAsc''.+foldAssocsAscChoice2Map' :: (OrderedMap mapL kL, OrderedMap mapR kR) => (Choice2 kL kR -> a -> b -> b) -> b -> Choice2Map mapL mapR kL kR a -> b+foldAssocsAscChoice2Map' f b0 (Choice2Map mapL mapR) =+ (\z -> foldAssocsAsc' (\kL a b -> f (C1of2 kL) a b) z mapL) $! foldAssocsAsc' (\kR a b -> f (C2of2 kR) a b) b0 mapR++-- | See 'Map' class method 'foldAssocsDesc''.+foldAssocsDescChoice2Map' :: (OrderedMap mapL kL, OrderedMap mapR kR) => (Choice2 kL kR -> a -> b -> b) -> b -> Choice2Map mapL mapR kL kR a -> b+foldAssocsDescChoice2Map' f b0 (Choice2Map mapL mapR) =+ (\z -> foldAssocsDesc' (\kR a b -> f (C2of2 kR) a b) z mapR) $! foldAssocsDesc' (\kL a b -> f (C1of2 kL) a b) b0 mapL++-- | See 'Map' class method 'foldElemsUInt'.+foldElemsUIntChoice2Map :: (Map mapL kL, Map mapR kR) => (a -> Int# -> Int#) -> Int# -> Choice2Map mapL mapR kL kR a -> Int#+foldElemsUIntChoice2Map f n (Choice2Map mapL mapR) = foldElemsUInt f (foldElemsUInt f n mapR) mapL ++-- | See 'Map' class method 'valid'.+validChoice2Map :: (Map mapL kL, Map mapR kR) => Choice2Map mapL mapR kL kR a -> Maybe String+validChoice2Map (Choice2Map mapL mapR) = case valid mapL of+                                     Nothing -> valid mapR+                                     j       -> j++-- | See 'Map' class method 'compareKeys'+compareKeyChoice2Map :: (OrderedMap mapL kl, OrderedMap mapR kr) =>+                       Choice2Map mapL mapR kL kR a -> Choice2 kl kr -> Choice2 kl kr -> Ordering+compareKeyChoice2Map mp (C1of2 k1) (C1of2 k2) = compareKey (leftMap mp) k1 k2+	where 	leftMap :: Choice2Map mapL mapR kL kR a -> mapL a+		leftMap = undefined+compareKeyChoice2Map _ (C1of2 _) (C2of2 _) = LT+compareKeyChoice2Map _ (C2of2 _) (C1of2 _) = GT+compareKeyChoice2Map mp (C2of2 k1) (C2of2 k2) = compareKey (rightMap mp) k1 k2+	where	rightMap :: Choice2Map mapL mapR kL kR a -> mapR a+		rightMap = undefined+--------------------------------------------------------------------------+--                         OTHER INSTANCES                              --+--------------------------------------------------------------------------++--------+-- Eq --+--------+instance (Eq (mapL a), Eq (mapR a)) => Eq (Choice2Map mapL mapR kL kR a) where+ Choice2Map mapL0 mapR0 == Choice2Map mapL1 mapR1 = (mapL0 == mapL1) && (mapR0 == mapR1)++---------+-- Ord --+---------+instance (Map mapL kL, Map mapR kR, Ord (mapL a), Ord (mapR a)) => Ord (Choice2Map mapL mapR kL kR a) where+ compare (Choice2Map mapL0 mapR0) (Choice2Map mapL1 mapR1) = c (isEmpty mapL0) (isEmpty mapL1) where+  c True  True  = compare mapR0 mapR1+  c True  False = if isEmpty mapR0 then LT else GT+  c False True  = if isEmpty mapR1 then GT else LT+  c False False = case compare mapL0 mapL1 of+                  LT -> LT+                  EQ -> compare mapR0 mapR1+                  GT -> GT++----------+-- Show --+----------+instance (Map mapL kL, Map mapR kR, Show kL, Show kR, Show a) => Show (Choice2Map mapL mapR kL kR a) where+  showsPrec d mp  = showParen (d > 10) $+    showString "fromAssocs " . shows (assocs mp)++----------+-- Read --+----------+instance (Map mapL kL, Map mapR kR, R.Read kL, R.Read kR, R.Read a) => R.Read (Choice2Map mapL mapR kL kR a) where+ readPrec = R.parens $ R.prec 10 $ do R.Ident "fromAssocs" <- R.lexP+                                      xs <- R.readPrec+                                      return (fromAssocs xs)+ readListPrec = R.readListPrecDefault++------------------------+-- Typeable/Typeable1 --+------------------------+instance (Typeable1 mapL, Typeable1 mapR) => Typeable1 (Choice2Map mapL mapR kL kR) where+ typeOf1 m = mkTyConApp (mkTyCon "Data.GMap.ChoiceMap.Choice2Map") [typeOf1 mapL, typeOf1 mapR]+  where Choice2Map mapL mapR = m -- This is just to get types for mapL & mapR !!+--------------+instance (Typeable1 (Choice2Map mapL mapR kL kR), Typeable a) => Typeable (Choice2Map mapL mapR kL kR a) where+ typeOf = typeOfDefault++-------------+-- Functor --+-------------+instance (Map mapL kL, Map mapR kR) => Functor (Choice2Map mapL mapR kL kR) where+-- fmap :: (a -> b) -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR b+   fmap = mapChoice2Map -- The lazy version++-----------------+-- Data.Monoid --+-----------------+instance (Map mapL kL, Map mapR kR, M.Monoid a) => M.Monoid (Choice2Map mapL mapR kL kR a) where+-- mempty :: Choice2Map mapL mapR kL kR a+   mempty = emptyChoice2Map+-- mappend :: Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR a+   mappend map0 map1 = unionChoice2Map M.mappend map0 map1+-- mconcat :: [Choice2Map mapL mapR kL kR a] -> Choice2Map mapL mapR kL kR a+   mconcat maps = L.foldr (unionChoice2Map M.mappend) emptyChoice2Map maps++-------------------+-- Data.Foldable --+-------------------+instance (Map mapL kL, Map mapR kR) => F.Foldable (Choice2Map mapL mapR kL kR) where+-- fold :: Monoid m => Choice2Map mapL mapR m -> m+   fold mp = foldElemsChoice2Map M.mappend M.mempty mp+-- foldMap :: Monoid m => (a -> m) -> Choice2Map mapL mapR kL kR a -> m+   foldMap f mp = foldElemsChoice2Map (\a b -> M.mappend (f a) b) M.mempty mp+-- fold :: (a -> b -> b) -> b -> Choice2Map mapL mapR kL kR a -> b+   foldr f b0 mp = foldElemsChoice2Map f b0 mp+-- foldl :: (a -> b -> a) -> a -> Choice2Map mapL mapR kL kR b -> a+   foldl f b0 mp = foldElemsChoice2Map (flip f) b0 mp+{- ToDo: Implement properly. Meantime Foldable class has suitable defaults via lists.+-- fold1 :: (a -> a -> a) -> Choice2Map mapL mapR kL kR a -> a+   fold1 = undefined+-- foldl1 :: (a -> a -> a) -> Choice2Map mapL mapR kL kR a -> a+   foldl1 = undefined+-}++-------------------------------------------------------------------------------++data Choice3 a b c = C1of3 a | C2of3 b | C3of3 c deriving (Eq,Ord,Read,Show)++data InjectChoice3 a b c++instance Injection (InjectChoice3 a b c) (Choice3 a b c) (Choice2 a (Choice2 b c)) where+	inject _ choice = case choice of+		C1of3 a -> C1of2 a+		C2of3 b -> C2of2 (C1of2 b)+		C3of3 c -> C2of2 (C2of2 c)+	outject _ choice = case choice of+		C1of2 a 	-> C1of3 a+		C2of2 (C1of2 b) -> C2of3 b+		C2of2 (C2of2 c) -> C3of3 c++type Choice3Map mapa mapb mapc a b c =+	InjectKeys (InjectChoice3 a b c) (Choice3 a b c) (Choice2 a (Choice2 b c))+		(Choice2Map mapa +			(Choice2Map mapb mapc b c)+		a (Choice2 b c))+		+		+		+data Choice4 a b c d = C1of4 a | C2of4 b | C3of4 c | C4of4 d deriving (Eq,Ord,Read,Show)++data InjectChoice4 a b c d++instance Injection (InjectChoice4 a b c d) (Choice4 a b c d) (Choice2 (Choice2 a b) (Choice2 c d)) where+	inject _ choice = case choice of+		C1of4 a -> C1of2 (C1of2 a)+		C2of4 b -> C1of2 (C2of2 b)+		C3of4 c -> C2of2 (C1of2 c)+		C4of4 d -> C2of2 (C2of2 d)+	outject _ choice = case choice of+		C1of2 (C1of2 a) -> C1of4 a+		C1of2 (C2of2 b) -> C2of4 b+		C2of2 (C1of2 c) -> C3of4 c+  		C2of2 (C2of2 d) -> C4of4 d++type Choice4Map mapa mapb mapc mapd a b c d =+	InjectKeys (InjectChoice4 a b c d) (Choice4 a b c d) (Choice2 (Choice2 a b) (Choice2 c d))+		(Choice2Map  +			(Choice2Map mapa mapb a b)+			(Choice2Map mapc mapd c d)+		(Choice2 a b) (Choice2 c d))+		+		+		+data Choice5 a b c d e = C1of5 a | C2of5 b | C3of5 c | C4of5 d | C5of5 e deriving (Eq,Ord,Read,Show)++data InjectChoice5 a b c d e++instance Injection (InjectChoice5 a b c d e) (Choice5 a b c d e) (Choice2 (Choice2 a b) (Choice2 c (Choice2 d e))) where+	inject _ choice = case choice of+		C1of5 a -> C1of2 (C1of2 a)+		C2of5 b -> C1of2 (C2of2 b)+		C3of5 c -> C2of2 (C1of2 c)+		C4of5 d -> C2of2 (C2of2 (C1of2 d))+		C5of5 e -> C2of2 (C2of2 (C2of2 e))+	outject _ choice = case choice of+		C1of2 (C1of2 a)	        -> C1of5 a+		C1of2 (C2of2 b)         -> C2of5 b+		C2of2 (C1of2 c)         -> C3of5 c+		C2of2 (C2of2 (C1of2 d)) -> C4of5 d+		C2of2 (C2of2 (C2of2 e)) -> C5of5 e+		+type Choice5Map mapa mapb mapc mapd mape a b c d e =+	InjectKeys (InjectChoice5 a b c d e) (Choice5 a b c d e) (Choice2 (Choice2 a b) (Choice2 c (Choice2 d e)))+		(Choice2Map  +			(Choice2Map mapa mapb a b)+			(Choice2Map mapc +				(Choice2Map mapd mape d e)+			c (Choice2 d e))+		(Choice2 a b) (Choice2 c (Choice2 d e)))
+ src/Data/GMap/EitherMap.hs view
@@ -0,0 +1,25 @@+{-# OPTIONS_GHC -fglasgow-exts -Wall -fno-warn-missing-signatures #-}++module Data.GMap.EitherMap+(+ EitherMap+) where++import Data.GMap()++import Data.GMap.ChoiceMap+import Data.GMap.InjectKeys++--------------------------------------------------------------------------------------------+--                     Map Type for Either                 --+--------------------------------------------------------------------------------------------++data InjectEither l r++instance Injection (InjectEither l r) (Either l r) (Choice2 l r) where+	inject _ (Left l)  = C1of2 l+	inject _ (Right r) = C2of2 r+	outject _ (C1of2 l) = Left l+	outject _ (C2of2 r) = Right r++type EitherMap mapL mapR l r = InjectKeys (InjectEither l r) (Either l r) (Choice2 l r) (Choice2Map mapL mapR l r)
+ src/Data/GMap/EnumMap.hs view
@@ -0,0 +1,23 @@+{-# OPTIONS_GHC -fglasgow-exts -Wall -fno-warn-missing-signatures #-}++module Data.GMap.EnumMap+(-- * EnumMap type+ EnumMap+) where++import Data.GMap()++import Data.GMap.IntMap+import Data.GMap.InjectKeys++--------------------------------------------------------------------------------------------+--                     Map Type for 'Enum'erable keys                   --+--------------------------------------------------------------------------------------------++data InjectEnum k++instance Enum k => Injection (InjectEnum k) k Int where+	inject _ = fromEnum+	outject _ = toEnum++type EnumMap k = InjectKeys (InjectEnum k) k Int IntMap
+ src/Data/GMap/InjectKeys.hs view
@@ -0,0 +1,299 @@+{-# OPTIONS_GHC -fglasgow-exts -Wall -fno-warn-missing-signatures -fno-monomorphism-restriction #-}++module Data.GMap.InjectKeys+(-- * InjectKeys type+ InjectKeys+,Injection+,inject+,outject+) where++import Prelude hiding (foldr,map,filter,lookup)+import Data.GMap++import Data.Typeable+import qualified Data.Foldable as F+import qualified Data.Monoid as M+-- -fno-warn-unused-imports used because ghc currently gives spurious warning with this import+-- See Tickets 1074 and 1148+import Data.Maybe hiding (mapMaybe)++import GHC.Base hiding (map)+import qualified Text.Read as R (Read(..),Lexeme(..),parens,prec,lexP,readListPrecDefault)++import qualified Data.List as L++--------------------------------------------------------------------------------------------+--                     Used when keys can be transformed into the key type of an existing maps+--		       eg. to store Enums in an IntMap+--------------------------------------------------------------------------------------------++data InjectKeys t k1 k2 map a = InjectKeys !(map a)++-- | 't' is a phantom type which determines the encoding and decoding functions used.+-- 't' is passed as an undefined value.+-- 'inject' must be injective (ie (inject a) == (inject b) implies a == b) and reversible by 'outject'+class Injection t k1 k2 | t -> k1, t -> k2 where+	inject :: t -> k1 -> k2+	outject :: t -> k2 -> k1++transformOf :: InjectKeys t k1 k2 map a -> t+transformOf = undefined++-- Dont export these, used to force correct types+injectFor :: Injection t k1 k2 => InjectKeys t k1 k2 map a -> k1 -> k2+injectFor mp k1 = inject (transformOf mp) k1++outjectFor :: Injection t k1 k2 => InjectKeys t k1 k2 map a -> k2 -> k1+outjectFor mp k2 = outject (transformOf mp) k2++-- | InjectKeys is an instance of Map.+instance (Eq k1, Injection t k1 k2, Map map k2) => Map (InjectKeys t k1 k2 map) k1 where+	empty                 	= emptyInjectKeys+	singleton             	= singletonInjectKeys+	pair                  	= pairInjectKeys+	nonEmpty              	= nonEmptyInjectKeys+	status                	= statusInjectKeys+	addSize               	= addSizeInjectKeys+	lookup                	= lookupInjectKeys+	lookupCont            	= lookupContInjectKeys+	alter			= alterInjectKeys+	insertWith            	= insertWithInjectKeys +	insertWith'           	= insertWithInjectKeys'+	insertMaybe           	= insertMaybeInjectKeys+-- 	fromAssocsWith	        = fromAssocsWithInjectKeys+-- 	fromAssocsMaybe 	= fromAssocsMaybeInjectKeys+	delete                	= deleteInjectKeys +	adjustWith           	= adjustWithInjectKeys+	adjustWith' 		= adjustWithInjectKeys'+	adjustMaybe		= adjustMaybeInjectKeys+	venn			= vennInjectKeys+	venn'			= vennInjectKeys'+	vennMaybe		= vennMaybeInjectKeys+	disjointUnion		= disjointUnionInjectKeys+	union                 	= unionInjectKeys+	union'                	= unionInjectKeys'+	unionMaybe            	= unionMaybeInjectKeys+	intersection          	= intersectionInjectKeys+	intersection'         	= intersectionInjectKeys'+	intersectionMaybe     	= intersectionMaybeInjectKeys+	difference            	= differenceInjectKeys+	differenceMaybe       	= differenceMaybeInjectKeys+	isSubsetOf            	= isSubsetOfInjectKeys+	isSubmapOf            	= isSubmapOfInjectKeys +	map                   	= mapInjectKeys+	map'                  	= mapInjectKeys'+	mapMaybe              	= mapMaybeInjectKeys+	mapWithKey            	= mapWithInjectionKeys+	mapWithKey'           	= mapWithInjectionKeys'+	filter                	= filterInjectKeys+	foldKeys		= foldKeysInjectKeys+	foldElems 		= foldElemsInjectKeys+	foldAssocs		= foldAssocsInjectKeys+	foldKeys'		= foldKeysInjectKeys'+	foldElems' 		= foldElemsInjectKeys'+	foldAssocs'		= foldAssocsInjectKeys'+	foldElemsUInt         	= foldElemsUIntInjectKeys+	valid                 	= validInjectKeys+ +instance (Eq k1, Injection t k1 k2, OrderedMap map k2) => OrderedMap (InjectKeys t k1 k2 map) k1 where+	compareKey 	= compareInjectionKeys+	fromAssocsAscWith = fromAssocsAscWithInjectKeys+	fromAssocsDescWith = fromAssocsDescWithInjectKeys+	fromAssocsAscMaybe = fromAssocsAscMaybeInjectKeys+	fromAssocsDescMaybe = fromAssocsDescMaybeInjectKeys+ 	foldElemsAsc	= foldElemsAscInjectKeys+	foldElemsDesc	= foldElemsDescInjectKeys+	foldKeysAsc	= foldKeysAscInjectKeys+	foldKeysDesc	= foldKeysDescInjectKeys+	foldAssocsAsc	= foldAssocsAscInjectKeys+	foldAssocsDesc	= foldAssocsDescInjectKeys+	foldElemsAsc'	= foldElemsAscInjectKeys'+	foldElemsDesc'	= foldElemsDescInjectKeys'+	foldKeysAsc'	= foldKeysAscInjectKeys'+	foldKeysDesc'	= foldKeysDescInjectKeys'+	foldAssocsAsc'	= foldAssocsAscInjectKeys'+	foldAssocsDesc'	= foldAssocsDescInjectKeys'++emptyInjectKeys = InjectKeys empty++singletonInjectKeys k a = let tk = InjectKeys (singleton (injectFor tk k) a) in tk++fromAssocsAscWithInjectKeys   f kas = let tk = InjectKeys (fromAssocsAscWith   f [(injectFor tk k,a) | (k,a) <- kas]) in tk+fromAssocsDescWithInjectKeys  f kas = let tk = InjectKeys (fromAssocsDescWith  f [(injectFor tk k,a) | (k,a) <- kas]) in tk+fromAssocsAscMaybeInjectKeys  f kas = let tk = InjectKeys (fromAssocsAscMaybe  f [(injectFor tk k,a) | (k,a) <- kas]) in tk+fromAssocsDescMaybeInjectKeys f kas = let tk = InjectKeys (fromAssocsDescMaybe f [(injectFor tk k,a) | (k,a) <- kas]) in tk++pairInjectKeys k1 k2 = +	let 	tk = (fromJust pairf) undefined undefined -- Roundabout way of getting hold of the transform type+		pairf = +			case pair (injectFor tk k1) (injectFor tk k2) of+				Nothing -> Nothing+				Just f -> Just (\a1 a2 -> InjectKeys (f a1 a2))+	in	pairf++nonEmptyInjectKeys (InjectKeys mp) = fmap InjectKeys (nonEmpty mp) ++statusInjectKeys tk@(InjectKeys mp) = +	case status mp of+		None    -> None+		One k a -> One (outjectFor tk k) a+		Many    -> Many++addSizeInjectKeys (InjectKeys mp) = addSize mp++lookupInjectKeys k tk@(InjectKeys mp) = lookup (injectFor tk k) mp++lookupContInjectKeys f k tk@(InjectKeys mp) = lookupCont f (injectFor tk k) mp++alterInjectKeys  f k tk@(InjectKeys mp) = InjectKeys (alter  f (injectFor tk k) mp)++insertWithInjectKeys  f k a tk@(InjectKeys mp) = InjectKeys (insertWith  f (injectFor tk k) a mp)+insertWithInjectKeys' f k a tk@(InjectKeys mp) = InjectKeys (insertWith' f (injectFor tk k) a mp)++insertMaybeInjectKeys  f k a tk@(InjectKeys mp) = InjectKeys (insertMaybe  f (injectFor tk k) a mp)++deleteInjectKeys k tk@(InjectKeys mp) = InjectKeys (delete (injectFor tk k) mp)++adjustWithInjectKeys  f k tk@(InjectKeys mp) = InjectKeys (adjustWith  f (injectFor tk k) mp)+adjustWithInjectKeys' f k tk@(InjectKeys mp) = InjectKeys (adjustWith' f (injectFor tk k) mp)++adjustMaybeInjectKeys  f k tk@(InjectKeys mp) = InjectKeys (adjustMaybe  f (injectFor tk k) mp)++vennInjectKeys f (InjectKeys mp1) (InjectKeys mp2) = (InjectKeys leftDiff, InjectKeys inter, InjectKeys rightDiff)+ where (leftDiff, inter, rightDiff) = venn f mp1 mp2 +vennInjectKeys' f (InjectKeys mp1) (InjectKeys mp2) = (InjectKeys leftDiff, InjectKeys inter, InjectKeys rightDiff)+ where (leftDiff, inter, rightDiff) = venn' f mp1 mp2 +vennMaybeInjectKeys f (InjectKeys mp1) (InjectKeys mp2) = (InjectKeys leftDiff, InjectKeys inter, InjectKeys rightDiff)+ where (leftDiff, inter, rightDiff) = vennMaybe f mp1 mp2 ++disjointUnionInjectKeys (InjectKeys mp1) (InjectKeys mp2) = InjectKeys (disjointUnion mp1 mp2)+unionInjectKeys  f (InjectKeys mp1) (InjectKeys mp2) = InjectKeys (union  f mp1 mp2) +unionInjectKeys' f (InjectKeys mp1) (InjectKeys mp2) = InjectKeys (union' f mp1 mp2) ++unionMaybeInjectKeys  f (InjectKeys mp1) (InjectKeys mp2) = InjectKeys (unionMaybe  f mp1 mp2) ++intersectionInjectKeys  f (InjectKeys mp1) (InjectKeys mp2) = InjectKeys (intersection  f mp1 mp2) +intersectionInjectKeys' f (InjectKeys mp1) (InjectKeys mp2) = InjectKeys (intersection' f mp1 mp2) ++intersectionMaybeInjectKeys  f (InjectKeys mp1) (InjectKeys mp2) = InjectKeys (intersectionMaybe  f mp1 mp2) ++differenceInjectKeys (InjectKeys mp1) (InjectKeys mp2) = InjectKeys (difference mp1 mp2) ++differenceMaybeInjectKeys  f (InjectKeys mp1) (InjectKeys mp2) = InjectKeys (differenceMaybe  f mp1 mp2) ++isSubsetOfInjectKeys   (InjectKeys mp1) (InjectKeys mp2) = isSubsetOf   mp1 mp2+isSubmapOfInjectKeys f (InjectKeys mp1) (InjectKeys mp2) = isSubmapOf f mp1 mp2++mapInjectKeys  f (InjectKeys mp) = InjectKeys (map  f mp)+mapInjectKeys' f (InjectKeys mp) = InjectKeys (map' f mp)++mapMaybeInjectKeys  f (InjectKeys mp) = InjectKeys (mapMaybe  f mp)++mapWithInjectionKeys  f tk@(InjectKeys mp) = InjectKeys (mapWithKey  (\k a -> f (outjectFor tk k) a) mp)+mapWithInjectionKeys' f tk@(InjectKeys mp) = InjectKeys (mapWithKey' (\k a -> f (outjectFor tk k) a) mp)++filterInjectKeys f (InjectKeys mp) = InjectKeys (filter f mp)++foldElemsInjectKeys   f b    (InjectKeys mp) = foldElems f b mp+foldKeysInjectKeys    f b tk@(InjectKeys mp) = foldKeys (\ k b' -> f (outjectFor tk k) b') b mp+foldAssocsInjectKeys  f b tk@(InjectKeys mp) = foldAssocs (\ k a b' -> f (outjectFor tk k) a b') b mp+foldElemsInjectKeys'  f b    (InjectKeys mp) = foldElems' f b mp+foldKeysInjectKeys'   f b tk@(InjectKeys mp) = foldKeys' (\ k b' -> f (outjectFor tk k) b') b mp+foldAssocsInjectKeys' f b tk@(InjectKeys mp) = foldAssocs' (\ k a b' -> f (outjectFor tk k) a b') b mp+foldElemsAscInjectKeys     f b    (InjectKeys mp) = foldElemsAsc f b mp+foldElemsDescInjectKeys    f b    (InjectKeys mp) = foldElemsDesc f b mp+foldKeysAscInjectKeys      f b tk@(InjectKeys mp) = foldKeysAsc (\ k b' -> f (outjectFor tk k) b') b mp+foldKeysDescInjectKeys     f b tk@(InjectKeys mp) = foldKeysDesc (\ k b' -> f (outjectFor tk k) b') b mp+foldAssocsAscInjectKeys    f b tk@(InjectKeys mp) = foldAssocsAsc (\ k a b' -> f (outjectFor tk k) a b') b mp+foldAssocsDescInjectKeys   f b tk@(InjectKeys mp) = foldAssocsDesc (\ k a b' -> f (outjectFor tk k) a b') b mp+foldElemsAscInjectKeys'    f b    (InjectKeys mp) = foldElemsAsc' f b mp+foldElemsDescInjectKeys'   f b    (InjectKeys mp) = foldElemsDesc' f b mp+foldKeysAscInjectKeys'     f b tk@(InjectKeys mp) = foldKeysAsc' (\ k b' -> f (outjectFor tk k) b') b mp+foldKeysDescInjectKeys'    f b tk@(InjectKeys mp) = foldKeysDesc' (\ k b' -> f (outjectFor tk k) b') b mp+foldAssocsAscInjectKeys'   f b tk@(InjectKeys mp) = foldAssocsAsc' (\ k a b' -> f (outjectFor tk k) a b') b mp+foldAssocsDescInjectKeys'  f b tk@(InjectKeys mp) = foldAssocsDesc' (\ k a b' -> f (outjectFor tk k) a b') b mp+foldElemsUIntInjectKeys    f b    (InjectKeys mp) = foldElemsUInt f b mp++validInjectKeys (InjectKeys mp) = valid mp++compareInjectionKeys tk k1 k2 = compareKey (innerMap tk) (injectFor tk k1) (injectFor tk k2)+	where 	innerMap :: InjectKeys t k1 k2 map a -> map a+		innerMap = undefined++--------------------------------------------------------------------------+--                         OTHER INSTANCES                              --+--------------------------------------------------------------------------++--------+-- Eq --+--------+instance (Eq (map a)) => Eq (InjectKeys t k1 k2 map a) where+ (InjectKeys  kmp1) == (InjectKeys  kmp2) = (kmp1 == kmp2)++---------+-- Ord --+---------+instance (Ord (map a)) => Ord (InjectKeys t k1 k2 map a) where+ compare (InjectKeys  kmp1) (InjectKeys  kmp2) = compare kmp1 kmp2++-- Show and read instances require transforming keys. Not hard but no time right now.+-- ----------+-- -- Show --+-- ----------+-- instance (Show (map a)) => Show (InjectKeys t k1 k2 map a) where+--   showsPrec d (InjectKeys  mp)  = showsPrec d mp+-- +-- ----------+-- -- Read --+-- ----------+-- instance (Read (map a)) => R.Read (InjectKeys t k1 k2 map a) where+--  readPrec = InjectKeys  `fmap` R.readPrec+--  readListPrec = (L.map InjectKeys ) `fmap` R.readListPrec++------------------------+-- Typeable/Typeable1 --+------------------------+instance (Typeable1 map) => Typeable1 (InjectKeys t k1 k2 map) where+ typeOf1 m = mkTyConApp (mkTyCon "Data.GMap.InjectKeys.InjectKeys") [typeOf1 innermp]+  where InjectKeys  innermp = m -- This is just to get the type for innermp!!+--------------+instance (Typeable1 (InjectKeys t k1 k2 map), Typeable a) => Typeable (InjectKeys t k1 k2 map a) where+ typeOf = typeOfDefault++-------------+-- Functor --+-------------+instance (Map map k2) => Functor (InjectKeys t k1 k2 map) where+-- fmap :: (a -> b) -> EitherMap mapL mapR a -> EitherMap mapL mapR b+   fmap = mapInjectKeys  -- The lazy version++-----------------+-- Data.Monoid --+-----------------+instance (Map map k2, M.Monoid a) => M.Monoid (InjectKeys t k1 k2 map a) where+-- mempty :: EitherMap mapL mapR a+   mempty = emptyInjectKeys +-- mappend :: EitherMap mapL mapR a -> EitherMap mapL mapR a -> EitherMap mapL mapR a+   mappend map0 map1 = unionInjectKeys  M.mappend map0 map1+-- mconcat :: [EitherMap mapL mapR a] -> EitherMap mapL mapR a+   mconcat maps = L.foldr (unionInjectKeys  M.mappend) emptyInjectKeys  maps++-------------------+-- Data.Foldable --+-------------------+instance (Map map k2) => F.Foldable (InjectKeys t k1 k2 map) where+-- fold :: Monoid m => InjectKeys  mapL mapR m -> m+   fold mp = foldElemsInjectKeys  M.mappend M.mempty mp+-- foldMap :: Monoid m => (a -> m) -> InjectKeys  mapL mapR a -> m+   foldMap f mp = foldElemsInjectKeys  (\a b -> M.mappend (f a) b) M.mempty mp+-- fold :: (a -> b -> b) -> b -> InjectKeys  mapL mapR a -> b+   foldr f b0 mp = foldElemsInjectKeys  f b0 mp+-- foldl :: (a -> b -> a) -> a -> InjectKeys  mapL mapR b -> a+   foldl f b0 mp = foldElemsInjectKeys  (flip f) b0 mp+{- ToDo: Implement properly. Meantime Foldable class has suitable defaults via lists.+-- fold1 :: (a -> a -> a) -> InjectKeys  mapL mapR a -> a+   fold1 = undefined+-- foldl1 :: (a -> a -> a) -> InjectKeys  mapL mapR a -> a+   foldl1 = undefined+-}
+ src/Data/GMap/IntMap.hs view
@@ -0,0 +1,4010 @@+{-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans -fno-warn-unused-imports -Wall #-}++module Data.GMap.IntMap+(-- * IntMap type+ IntMap+) where++import Prelude hiding (foldr,map,filter,lookup)+import Data.GMap++import qualified Data.Monoid as M (Monoid(..))+import qualified Data.Foldable as F (Foldable(..))+import Data.Bits(shiftR,(.&.))+import Data.Typeable+-- -fno-warn-unused-imports used because ghc currently gives spurious warning with this import+-- See Tickets 1074 and 1148+import qualified Data.List as L+import qualified Data.Maybe as MB+import Control.Monad(foldM)++import GHC.Base hiding (map)+import qualified Text.Read as R (Read(..),Lexeme(..),parens,prec,lexP,readListPrecDefault)++-- | Type synonym used to distinguish a key Int# from other Int#.+-- (BTW, the Haddock lies. This synonym is not exported.+-- This is only used in the haddock to distinguish Ints that are Keys from Ints used for other purposes.)+type Key = Int#++-- This is basically the same as AVL (from Data.Tree.AVL package) but with an+-- extra Int field (which is unboxed for ghc).+-- | The GT type for 'Int' keys.+data IntMap a = E                                              -- ^ Empty IntMap+             | N {-# UNPACK #-} !Key (IntMap a) a (IntMap a)    -- ^ BF=-1 (right height > left height)+             | Z {-# UNPACK #-} !Key (IntMap a) a (IntMap a)    -- ^ BF= 0+             | P {-# UNPACK #-} !Key (IntMap a) a (IntMap a)    -- ^ BF=+1 (left height > right height)++instance Map IntMap Int where+-- fromAssocsWith+-- fromAssocsMaybe+ empty                      = emptyIntMap+ nonEmpty                   = nonEmptyIntMap+ status                     = statusIntMap+ addSize                    = addSizeIntMap+ union                      = unionIntMap+ union'                     = unionIntMap'+ unionMaybe                 = unionMaybeIntMap+ disjointUnion              = disjointUnionIntMap+ intersection               = intersectionIntMap+ intersection'              = intersectionIntMap'+ intersectionMaybe          = intersectionMaybeIntMap+ difference                 = differenceIntMap+ differenceMaybe            = differenceMaybeIntMap+ isSubsetOf                 = isSubsetOfIntMap+ isSubmapOf                 = isSubmapOfIntMap+ map                        = mapIntMap+ map'                       = mapIntMap'+ mapMaybe                   = mapMaybeIntMap+ mapWithKey  f imp          = mapWithKeyIntMap  (\i a -> f (I# (i)) a) imp+ mapWithKey' f imp          = mapWithKeyIntMap' (\i a -> f (I# (i)) a) imp+ filter                     = filterIntMap+ foldKeys   f imp b0        = foldKeysAscIntMap     (\i b   -> f (I# (i))   b) imp b0+ foldAssocs   f imp b0      = foldAssocsAscIntMap   (\i a b -> f (I# (i)) a b) imp b0+ foldElems                  = foldElemsAscIntMap+ foldElems'                 = foldElemsAscIntMap'+ foldKeys'    f imp b0      = foldKeysAscIntMap'    (\i b   -> f (I# (i))   b) imp b0+ foldAssocs'  f imp b0      = foldAssocsAscIntMap'  (\i a b -> f (I# (i)) a b) imp b0+ foldElemsUInt              = foldElemsUIntIntMap+ valid                      = validIntMap+ singleton (I# (i)) a            = singletonIntMap i a+ pair (I# (i0)) (I# (i1))        = pairIntMap i0 i1+ lookup       (I# (i)) imp       = lookupIntMap       i imp+ lookupCont f (I# (i)) imp       = lookupContIntMap f i imp+ alter       f (I# (i)) imp      = alterIntMap       f i imp+ insertWith  f (I# (i)) a imp   = insertWithIntMap       f i a imp+ insertWith' f (I# (i)) a imp   = insertWithIntMap'      f i a imp+ insertMaybe  f (I# (i)) a imp   = insertMaybeIntMap  f i a imp+ delete        (I# (i)) imp      = deleteIntMap i imp+ adjustWith   f (I# (i)) imp	 = adjustWithIntMap f i imp+ adjustWith'  f (I# (i)) imp	 = adjustWithIntMap' f i imp+ adjustMaybe f (I# (i)) imp      = adjustMaybeIntMap f i imp+ venn                            = vennIntMap+ venn'                           = vennIntMap'+ vennMaybe                       = vennMaybeIntMap++instance OrderedMap IntMap Int where+ compareKey                = compareKeyIntMap+ fromAssocsAscWith         = fromAssocsAscWithIntMap+ fromAssocsDescWith        = fromAssocsDescWithIntMap+ fromAssocsAscMaybe        = fromAssocsAscMaybeIntMap+ fromAssocsDescMaybe       = fromAssocsDescMaybeIntMap+ foldKeysAsc     f imp b0 = foldKeysAscIntMap     (\i b   -> f (I# (i))   b) imp b0+ foldKeysDesc    f imp b0 = foldKeysDescIntMap    (\i b   -> f (I# (i))   b) imp b0+ foldAssocsAsc   f imp b0 = foldAssocsAscIntMap   (\i a b -> f (I# (i)) a b) imp b0+ foldAssocsDesc  f imp b0 = foldAssocsDescIntMap  (\i a b -> f (I# (i)) a b) imp b0+ foldElemsAsc        = foldElemsAscIntMap+ foldElemsDesc       = foldElemsDescIntMap+ foldElemsAsc'       = foldElemsAscIntMap'+ foldElemsDesc'      = foldElemsDescIntMap'+ foldKeysAsc'    f imp b0 = foldKeysAscIntMap'    (\i b   -> f (I# (i))   b) imp b0+ foldKeysDesc'   f imp b0 = foldKeysDescIntMap'   (\i b   -> f (I# (i))   b) imp b0+ foldAssocsAsc'  f imp b0 = foldAssocsAscIntMap'  (\i a b -> f (I# (i)) a b) imp b0+ foldAssocsDesc' f imp b0 = foldAssocsDescIntMap' (\i a b -> f (I# (i)) a b) imp b0++-- Local module error prefix+mErr :: String+mErr = "Data.Trie.General.IntMap.Set-"++-- | See 'Map' class method 'empty'.+emptyIntMap :: IntMap a+emptyIntMap = E+{-# INLINE emptyIntMap #-}++-- | See 'Map' class method 'singleton'.+singletonIntMap :: Key -> a -> IntMap a+singletonIntMap i a = Z i E a E+{-# INLINE singletonIntMap #-}++-- !!! This might cause problems where the list and the map cant both fit into memory at the same time. Dont use length.+fromAssocsAscIntMap :: [(Int,a)] -> IntMap a+fromAssocsAscIntMap ias = fromAssocsAscLIntMap (length ias) ias+{-# INLINE fromAssocsAscIntMap #-}++fromAssocsDescIntMap :: [(Int,a)] -> IntMap a+fromAssocsDescIntMap ias = fromAssocsDescLIntMap (length ias) ias+{-# INLINE fromAssocsDescIntMap #-}++fromAssocsAscLIntMap :: Int -> [(Int,a)] -> IntMap a+fromAssocsAscLIntMap n ias = case suba (rep n) ias of+                                     (# imp,[] #) -> imp+                                     (# _,_ #)    -> error (mErr ++ "fromAssocsAscLIntMap: List too long.")+ where+ suba  ET      as = (# E,as #)+ suba (NT l r) as = suba_ N l r as+ suba (ZT l r) as = suba_ Z l r as+ suba (PT l r) as = suba_ P l r as+ {-# INLINE suba_ #-}+ suba_ c l r as = case suba l as of+                  (# l_,as_ #) -> case as_ of+                                  (((I# (ka),a):as__)) -> case suba r as__ of+                                                          (# r_,as___ #) -> let t = c ka l_ a r_+                                                                            in t `seq` (# t,as___ #)+                                  [] -> error (mErr ++ "fromAssocsAscLIntMap: List too short.")++fromAssocsDescLIntMap :: Int -> [(Int,a)] -> IntMap a+fromAssocsDescLIntMap n ias = case subd (rep n) ias of+                                      (# imp,[] #) -> imp+                                      (# _,_ #)    -> error (mErr ++ "fromAssocsDescLIntMap: List too long.")+ where+ subd  ET      as = (# E,as #)+ subd (NT l r) as = subd_ N l r as+ subd (ZT l r) as = subd_ Z l r as+ subd (PT l r) as = subd_ P l r as+ {-# INLINE subd_ #-}+ subd_ c l r as = case subd r as of+                  (# r_,as_ #) -> case as_ of+                                  (((I# (ka),a):as__)) -> case subd l as__ of+                                                          (# l_,as___ #) -> let t = c ka l_ a r_+                                                                            in t `seq` (# t,as___ #)+                                  [] -> error (mErr ++ "fromAssocsDescLIntMap: List too short.")++-- Group an ordered list of assocs by key+clump :: Eq k => [(k,a)] -> [(k,[a])]+clump [] = []+clump kas = list' [(k',as' [])]+	where 	(k',as',list') = L.foldl' combine (fst $ head kas,id,id) kas+		-- 'as' and 'list' are list building continuations - so order of 'kas' is preserved+		combine (k1,as,list) (k2,a) =+			if 	k1 == k2+			then	(k1,  as . (a:), list                 )+			else	(k2, (a:),       list . ((k1,as []):) )++fromAssocsAscWithIntMap :: (a -> a -> a) -> [(Int,a)] -> IntMap a+fromAssocsAscWithIntMap f kas = fromAssocsAscIntMap [ (k,L.foldl1' f as) | (k,as) <- clump kas]++fromAssocsDescWithIntMap :: (a -> a -> a) -> [(Int,a)] -> IntMap a+fromAssocsDescWithIntMap f kas = fromAssocsDescIntMap [ (k,L.foldl1' f as) | (k,as) <- clump kas]++fromAssocsAscMaybeIntMap :: (a -> a -> Maybe a) -> [(Int,a)] -> IntMap a+fromAssocsAscMaybeIntMap f kas = fromAssocsAscIntMap $ MB.catMaybes [ fld k as | (k,as) <- clump kas]+	where fld k as = (\a -> (k,a)) `fmap` foldM f (head as) (tail as)+	+fromAssocsDescMaybeIntMap :: (a -> a -> Maybe a) -> [(Int,a)] -> IntMap a+fromAssocsDescMaybeIntMap f kas = fromAssocsDescIntMap $ MB.catMaybes [ fld k as | (k,as) <- clump kas]+	where fld k as = (\a -> (k,a)) `fmap` foldM f (head as) (tail as)++-- | See 'Map' class method 'pair'.+pairIntMap :: Key -> Key -> Maybe (a -> a -> IntMap a)+pairIntMap i0 i1 = case compareInt# i0 i1 of+                  LT -> Just (\a0 a1 -> P i1 (Z i0 E a0 E) a1 E)+                  EQ -> Nothing+                  GT -> Just (\a0 a1 -> P i0 (Z i1 E a1 E) a0 E)++-- | See 'Map' class method 'nonEmpty'.+nonEmptyIntMap :: IntMap a -> Maybe (IntMap a)+nonEmptyIntMap E   = Nothing+nonEmptyIntMap imp = Just imp++-- | See 'Map' class method 'status'.+statusIntMap :: IntMap a -> Status Int a+statusIntMap E           = None+statusIntMap (Z i E a _) = One (I# (i)) a+statusIntMap _           = Many++{-----------------------------------------+Notes for fast size calculation.+ case (h,avl)+      (0,_      ) -> 0            -- Must be E+      (1,_      ) -> 1            -- Must be (Z  E        _  E       )+      (2,N _ _ _) -> 2            -- Must be (N  E        _ (Z E _ E))+      (2,Z _ _ _) -> 3            -- Must be (Z (Z E _ E) _ (Z E _ E))+      (2,P _ _ _) -> 2            -- Must be (P (Z E _ E) _  E       )+      (3,N _ _ r) -> 2 + size 2 r -- Must be (N (Z E _ E) _  r       )+      (3,P l _ _) -> 2 + size 2 l -- Must be (P  l        _ (Z E _ E))+------------------------------------------}++-- | See 'Map' class method 'addSize'.+addSizeIntMap :: IntMap a -> Int# -> Int#+addSizeIntMap E           n = n+addSizeIntMap (N _ l _ r) n = case addHeight 2# l of+                             2# -> ((n)+#2#)+                             h    -> fasN n h l r+addSizeIntMap (Z _ l _ r) n = case addHeight 1# l of+                             1# -> ((n)+#1#)+                             2# -> ((n)+#3#)+                             h    -> fasZ n h l r+addSizeIntMap (P _ l _ r) n = case addHeight 2# r of+                             2# -> ((n)+#2#)+                             h    -> fasP n h l r++-- Local utilities used by addSizeIntMap, Only work if h >=3 !!+fasN,fasZ,fasP :: Int# -> Int# -> IntMap e -> IntMap e -> Int#+fasN n 3# _ r = fas ((n)+#2#)                    2#       r+fasN n h    l r = fas (fas ((n)+#1#) ((h)-#2#) l) ((h)-#1#) r -- h>=4+fasZ n h    l r = fas (fas ((n)+#1#) ((h)-#1#) l) ((h)-#1#) r+fasP n 3# l _ = fas ((n)+#2#)                    2#       l+fasP n h    l r = fas (fas ((n)+#1#) ((h)-#2#) r) ((h)-#1#) l -- h>=4++-- Local Utility used by fasN,fasZ,fasP, Only works if h >= 2 !!+fas :: Int# -> Int# -> IntMap e -> Int#+fas _ 2#  E          = error "fas: Bug0"+fas n 2# (N _ _ _ _) = ((n)+#2#)+fas n 2# (Z _ _ _ _) = ((n)+#3#)+fas n 2# (P _ _ _ _) = ((n)+#2#)+-- So h must be >= 3 if we get here+fas n h    (N _ l _ r) = fasN n h l r+fas n h    (Z _ l _ r) = fasZ n h l r+fas n h    (P _ l _ r) = fasP n h l r+fas _ _     E          = error "fas: Bug1"+-----------------------------------------------------------------------+------------------------ addSizeIntMap Ends Here -----------------------+-----------------------------------------------------------------------+++-- | Adds the height of a tree to the first argument.+--+-- Complexity: O(log n)+addHeight :: Int# -> IntMap e -> Int#+addHeight h  E          = h+addHeight h (N _ l _ _) = addHeight ((h)+#2#) l+addHeight h (Z _ l _ _) = addHeight ((h)+#1#) l+addHeight h (P _ _ _ r) = addHeight ((h)+#2#) r++-- | See 'Map' class method 'lookup'.+lookupIntMap :: Key -> IntMap a -> Maybe a+lookupIntMap i0 t = rd t where+ rd  E          = Nothing+ rd (N i l a r) = rd_ i l a r+ rd (Z i l a r) = rd_ i l a r+ rd (P i l a r) = rd_ i l a r+ rd_   i l a r  = case compareInt# i0 i of+                  LT -> rd l+                  EQ -> Just a+                  GT -> rd r++-- | See 'Map' class method 'lookupCont'.+lookupContIntMap :: (a -> Maybe b) -> Key -> IntMap a -> Maybe b+lookupContIntMap f i0 t = rd t where+ rd  E          = Nothing+ rd (N i l a r) = rd_ i l a r+ rd (Z i l a r) = rd_ i l a r+ rd (P i l a r) = rd_ i l a r+ rd_   i l a r  = case compareInt# i0 i of+                  LT -> rd l+                  EQ -> f a+                  GT -> rd r++-- | Determine if the supplied key is present in the IntMap.+hasKeyIntMap :: IntMap a -> Key -> Bool+hasKeyIntMap t i0 = rd t where+ rd  E          = False+ rd (N i l _ r) = rd_ i l r+ rd (Z i l _ r) = rd_ i l r+ rd (P i l _ r) = rd_ i l r+ rd_   i l   r  = case compareInt# i0 i of+                  LT -> rd l+                  EQ -> True+                  GT -> rd r++-- | Overwrite an existing association pair. This function does not force evaluation of the new associated+-- value. An error is raised if the IntMap does not already contain an entry for the Key.+--+-- Complexity: O(log n)+assertWriteIntMap :: Key -> a -> IntMap a -> IntMap a+assertWriteIntMap i0 a0 = w where+ w  E          = error "assertWrite: Key not found."+ w (N i l a r) = case compareInt# i0 i of+                 LT -> let l' = w l in l' `seq` N i l' a r+                 EQ -> N i0 l a0 r+                 GT -> let r' = w r in r' `seq` N i l  a r'+ w (Z i l a r) = case compareInt# i0 i of+                 LT -> let l' = w l in l' `seq` Z i l' a r+                 EQ -> Z i0 l a0 r+                 GT -> let r' = w r in r' `seq` Z i l  a r'+ w (P i l a r) = case compareInt# i0 i of+                 LT -> let l' = w l in l' `seq` P i l' a r+                 EQ -> P i0 l a0 r+                 GT -> let r' = w r in r' `seq` P i l  a r'++-- | See 'Map' class method 'alter'.+alterIntMap :: (Maybe a -> Maybe a) -> Key -> IntMap a -> IntMap a+alterIntMap f i t = case lookupIntMap i t of+                   Nothing -> case f Nothing of+                              Nothing -> t+                              Just a  -> ins i a t+                   ja      -> case f ja of+                              Nothing -> del i t+                              Just a' -> assertWriteIntMap i a' t++-- | See 'Map' class method 'insertMaybe'.+insertMaybeIntMap :: (a -> Maybe a) -> Key -> a -> IntMap a -> IntMap a+insertMaybeIntMap f i0 a0 t = case lookupIntMap i0 t of+                             Nothing -> ins i0 a0 t+                             Just a' -> case f a' of+                                        Nothing  -> del i0 t+                                        Just a'' -> assertWriteIntMap i0 a'' t++-- | See 'Map' class method 'delete'.+deleteIntMap :: Key -> IntMap a -> IntMap a+deleteIntMap i t = if t `hasKeyIntMap` i then del i t else t++-- | See 'Map' class method 'adjust'.+adjustWithIntMap :: (a -> a) -> Key -> IntMap a -> IntMap a+adjustWithIntMap f i t = case lookupIntMap i t of+                         Nothing -> t+                         Just a -> assertWriteIntMap i (f a) t++-- | See 'Map' class method 'adjust''.+adjustWithIntMap' :: (a -> a) -> Key -> IntMap a -> IntMap a+adjustWithIntMap' f i t = case lookupIntMap i t of+                         Nothing -> t+                         Just a -> let a' = f a in a' `seq` assertWriteIntMap i a' t++-- | See 'Map' class method 'adjustMaybe'.+adjustMaybeIntMap :: (a -> Maybe a) -> Key -> IntMap a -> IntMap a+adjustMaybeIntMap f i t = case lookupIntMap i t of+                         Nothing -> t+                         Just a -> case f a of+                                   Nothing -> del i t+                                   Just a' -> assertWriteIntMap i a' t++-- | See 'Map' class method 'isSubsetOf'.+isSubsetOfIntMap :: IntMap a -> IntMap b -> Bool+isSubsetOfIntMap = s where+ -- s :: IntMap a -> IntMap b -> Bool+ s  E              _             = True+ s  _              E             = False+ s (N ka la _ ra) (N kb lb _ rb) = s' ka la ra kb lb rb+ s (N ka la _ ra) (Z kb lb _ rb) = s' ka la ra kb lb rb+ s (N ka la _ ra) (P kb lb _ rb) = s' ka la ra kb lb rb+ s (Z ka la _ ra) (N kb lb _ rb) = s' ka la ra kb lb rb+ s (Z ka la _ ra) (Z kb lb _ rb) = s' ka la ra kb lb rb+ s (Z ka la _ ra) (P kb lb _ rb) = s' ka la ra kb lb rb+ s (P ka la _ ra) (N kb lb _ rb) = s' ka la ra kb lb rb+ s (P ka la _ ra) (Z kb lb _ rb) = s' ka la ra kb lb rb+ s (P ka la _ ra) (P kb lb _ rb) = s' ka la ra kb lb rb+ s' ka la ra kb lb rb =+  case compareInt# ka kb of+  -- ka < kb, so (la < ka < kb) & (ka < kb < rb)+  LT -> case forkL ka lb of+        (# False,_  ,_,_  ,_ #) -> False+        (# True ,llb,_,lrb,_ #) -> (s la llb) && case forkR ra kb of  -- (llb < ka  < kb) & (ka < lrb < kb)+              (# rla,_,rra,_ #) -> (s rla lrb) && (s rra rb)          -- (ka  < rla < kb) & (ka < kb  < rra)+  -- ka = kb+  EQ -> (s la lb) && (s ra rb)+  -- kb < ka, so (lb < kb < ka) & (kb < ka < ra)+  GT -> case forkL ka rb of+        (# False,_  ,_,_  ,_ #) -> False+        (# True ,rlb,_,rrb,_ #) -> (s ra rrb) && case forkR la kb of  -- (kb  < rlb < ka) & (kb < ka  < rrb)+              (# lla,_,lra,_ #) -> (s lra rlb) && (s lla lb)          -- (lla < kb  < ka) & (kb < lra < ka)+ -- forkL returns False if tb does not contain ka (which implies set a cannot be a subset of set b)+ -- forkL :: Key -> IntMap b -> (# Bool,IntMap b,Int#,IntMap b,Int# #) -- Vals b..4 only valid if Bool is True!+ forkL ka tb = forkL_ tb 0# where+  forkL_  E          h = (# False,E,h,E,h #)+  forkL_ (N k l b r) h = forkL__ k l ((h)-#2#) b r ((h)-#1#)+  forkL_ (Z k l b r) h = forkL__ k l ((h)-#1#) b r ((h)-#1#)+  forkL_ (P k l b r) h = forkL__ k l ((h)-#1#) b r ((h)-#2#)+  forkL__ k l hl b r hr = case compareInt# ka k of+                          LT -> case forkL_ l hl of+                                (# False,t0,ht0,t1,ht1 #) -> (# False,t0,ht0,t1,ht1 #)+                                (# True ,t0,ht0,t1,ht1 #) -> case spliceH k t1 ht1 b r hr of+                                                             (# t1_,ht1_ #) -> (# True,t0,ht0,t1_,ht1_ #)+                          EQ -> (# True,l,hl,r,hr #)+                          GT -> case forkL_ r hr of+                                (# False,t0,ht0,t1,ht1 #) -> (# False,t0,ht0,t1,ht1 #)+                                (# True ,t0,ht0,t1,ht1 #) -> case spliceH k l hl b t0 ht0 of+                                                             (# t0_,ht0_ #) -> (# True,t0_,ht0_,t1,ht1 #)+ -- forkR discards an element from set a if it is equal to the element from set b+ -- forkR :: IntMap a -> Key -> (# IntMap a,Int#,IntMap a,Int# #)+ forkR ta kb = forkR_ ta 0# where+  forkR_  E          h = (# E,h,E,h #) -- Relative heights!!+  forkR_ (N k l a r) h = forkR__ k l ((h)-#2#) a r ((h)-#1#)+  forkR_ (Z k l a r) h = forkR__ k l ((h)-#1#) a r ((h)-#1#)+  forkR_ (P k l a r) h = forkR__ k l ((h)-#1#) a r ((h)-#2#)+  forkR__ k l hl a r hr = case compareInt# k kb of+                          LT -> case forkR_ r hr of+                                (# t0,ht0,t1,ht1 #) -> case spliceH k l hl a t0 ht0 of+                                 (# t0_,ht0_ #)     -> (# t0_,ht0_,t1,ht1 #)+                          EQ -> (# l,hl,r,hr #)     -- e is discarded from set a+                          GT -> case forkR_ l hl of+                                (# t0,ht0,t1,ht1 #) -> case spliceH k t1 ht1 a r hr of+                                 (# t1_,ht1_ #)     -> (# t0,ht0,t1_,ht1_ #)+-----------------------------------------------------------------------+----------------------- isSubsetOfIntMap Ends Here ---------------------+-----------------------------------------------------------------------++-- | See 'Map' class method 'isSubmapOf'.+isSubmapOfIntMap :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool+isSubmapOfIntMap p = s where+ -- s :: IntMap a -> IntMap b -> Bool+ s  E              _             = True+ s  _              E             = False+ s (N ka la a ra) (N kb lb b rb) = s' ka la a ra kb lb b rb+ s (N ka la a ra) (Z kb lb b rb) = s' ka la a ra kb lb b rb+ s (N ka la a ra) (P kb lb b rb) = s' ka la a ra kb lb b rb+ s (Z ka la a ra) (N kb lb b rb) = s' ka la a ra kb lb b rb+ s (Z ka la a ra) (Z kb lb b rb) = s' ka la a ra kb lb b rb+ s (Z ka la a ra) (P kb lb b rb) = s' ka la a ra kb lb b rb+ s (P ka la a ra) (N kb lb b rb) = s' ka la a ra kb lb b rb+ s (P ka la a ra) (Z kb lb b rb) = s' ka la a ra kb lb b rb+ s (P ka la a ra) (P kb lb b rb) = s' ka la a ra kb lb b rb+ s' ka la a ra kb lb b rb =+  case compareInt# ka kb of+  -- ka < kb, so (la < ka < kb) & (ka < kb < rb)+  LT -> case forkL ka a lb of+        (# False,_  ,_,_  ,_ #) -> False+        (# True ,llb,_,lrb,_ #) -> (s la llb) && case forkR ra kb b of  -- (llb < ka  < kb) & (ka < lrb < kb)+              (# False,_  ,_,_  ,_ #) -> False+              (# True ,rla,_,rra,_ #) -> (s rla lrb) && (s rra rb)      -- (ka  < rla < kb) & (ka < kb  < rra)+  -- ka = kb+  EQ -> (p a b) && (s la lb) && (s ra rb)+  -- kb < ka, so (lb < kb < ka) & (kb < ka < ra)+  GT -> case forkL ka a rb of+        (# False,_  ,_,_  ,_ #) -> False+        (# True ,rlb,_,rrb,_ #) -> (s ra rrb) && case forkR la kb b of  -- (kb  < rlb < ka) & (kb < ka  < rrb)+              (# False,_  ,_,_  ,_ #) -> False+              (# True, lla,_,lra,_ #) -> (s lra rlb) && (s lla lb)      -- (lla < kb  < ka) & (kb < lra < ka)+ -- forkL returns False if tb does not contain ka (which implies set a cannot be a subset of set b)+ -- forkL :: Key -> a -> IntMap b -> (# Bool,IntMap b,Int#,IntMap b,Int# #) -- Vals b..4 only valid if Bool is True!+ forkL ka a tb = forkL_ tb 0# where+  forkL_  E          h = (# False,E,h,E,h #)+  forkL_ (N k l b r) h = forkL__ k l ((h)-#2#) b r ((h)-#1#)+  forkL_ (Z k l b r) h = forkL__ k l ((h)-#1#) b r ((h)-#1#)+  forkL_ (P k l b r) h = forkL__ k l ((h)-#1#) b r ((h)-#2#)+  forkL__ k l hl b r hr = case compareInt# ka k of+                          LT -> case forkL_ l hl of+                                (# False,t0,ht0,t1,ht1 #) -> (# False,t0,ht0,t1,ht1 #)+                                (# True ,t0,ht0,t1,ht1 #) -> case spliceH k t1 ht1 b r hr of+                                                             (# t1_,ht1_ #) -> (# True,t0,ht0,t1_,ht1_ #)+                          EQ -> let bool = p a b in bool `seq` (# bool,l,hl,r,hr #)+                          GT -> case forkL_ r hr of+                                (# False,t0,ht0,t1,ht1 #) -> (# False,t0,ht0,t1,ht1 #)+                                (# True ,t0,ht0,t1,ht1 #) -> case spliceH k l hl b t0 ht0 of+                                                             (# t0_,ht0_ #) -> (# True,t0_,ht0_,t1,ht1 #)+ -- forkR discards an element from set a if it is equal to the element from set b+ -- forkR :: IntMap a -> Key -> b -> (# Bool,IntMap a,Int#,IntMap a,Int# #)+ forkR ta kb b = forkR_ ta 0# where+  forkR_  E          h = (# True,E,h,E,h #) -- Relative heights!!+  forkR_ (N k l a r) h = forkR__ k l ((h)-#2#) a r ((h)-#1#)+  forkR_ (Z k l a r) h = forkR__ k l ((h)-#1#) a r ((h)-#1#)+  forkR_ (P k l a r) h = forkR__ k l ((h)-#1#) a r ((h)-#2#)+  forkR__ k l hl a r hr = case compareInt# k kb of+                          LT -> case forkR_ r hr of+                                (# False,t0,ht0,t1,ht1 #) -> (# False,t0,ht0,t1,ht1 #)+                                (# True ,t0,ht0,t1,ht1 #) -> case spliceH k l hl a t0 ht0 of+                                       (# t0_,ht0_ #)     -> (# True,t0_,ht0_,t1,ht1 #)+                          EQ -> let bool = p a b in bool `seq` (# bool,l,hl,r,hr #) -- e is discarded from set a+                          GT -> case forkR_ l hl of+                                (# False,t0,ht0,t1,ht1 #) -> (# False,t0,ht0,t1,ht1 #)+                                (# True ,t0,ht0,t1,ht1 #) -> case spliceH k t1 ht1 a r hr of+                                         (# t1_,ht1_ #)   -> (# True,t0,ht0,t1_,ht1_ #)+-----------------------------------------------------------------------+----------------------- isSubmapOfIntMap Ends Here ---------------------+-----------------------------------------------------------------------++-- | See 'Map' class method 'map'.+mapIntMap :: (a -> b) -> IntMap a -> IntMap b+mapIntMap f = mapit where+ mapit  E          = E+ mapit (N i l a r) = let l_ = mapit l+                         r_ = mapit r+                     in l_ `seq` r_ `seq` N i l_ (f a) r_+ mapit (Z i l a r) = let l_ = mapit l+                         r_ = mapit r+                     in l_ `seq` r_ `seq` Z i l_ (f a) r_+ mapit (P i l a r) = let l_ = mapit l+                         r_ = mapit r+                     in l_ `seq` r_ `seq` P i l_ (f a) r_++-- | See 'Map' class method 'map''.+mapIntMap' :: (a -> b) -> IntMap a -> IntMap b+mapIntMap' f = mapit where+ mapit  E          = E+ mapit (N i l a r) = let l_ = mapit l+                         r_ = mapit r+                         b  = f a+                     in b `seq` l_ `seq` r_ `seq` N i l_ b r_+ mapit (Z i l a r) = let l_ = mapit l+                         r_ = mapit r+                         b  = f a+                     in b `seq` l_ `seq` r_ `seq` Z i l_ b r_+ mapit (P i l a r) = let l_ = mapit l+                         r_ = mapit r+                         b  = f a+                     in b `seq` l_ `seq` r_ `seq` P i l_ b r_++-- | See 'Map' class method 'mapMaybe'.+mapMaybeIntMap :: (a -> Maybe b) -> IntMap a -> IntMap b+mapMaybeIntMap f t0 = case mapMaybe_ 0# t0 of (# t_,_ #) -> t_  -- Work with relative heights!!+ where mapMaybe_ h t = case t of+                       E         -> (# E,h #)+                       N i l a r -> m i l ((h)-#2#) a r ((h)-#1#)+                       Z i l a r -> m i l ((h)-#1#) a r ((h)-#1#)+                       P i l a r -> m i l ((h)-#1#) a r ((h)-#2#)+        where m i l hl a r hr =                  case mapMaybe_ hl l of+                                (# l_,hl_ #)  -> case mapMaybe_ hr r of+                                 (# r_,hr_ #) -> case f a of+                                                 Just b  -> spliceH i l_ hl_ b r_ hr_+                                                 Nothing ->   joinH   l_ hl_   r_ hr_++-- | See 'Map' class method 'mapWithKey'.+mapWithKeyIntMap :: (Key -> a -> b) -> IntMap a -> IntMap b+mapWithKeyIntMap f = mapit where+ mapit  E          = E+ mapit (N i l a r) = let l_ = mapit l+                         r_ = mapit r+                     in l_ `seq` r_ `seq` N i l_ (f i a) r_+ mapit (Z i l a r) = let l_ = mapit l+                         r_ = mapit r+                     in l_ `seq` r_ `seq` Z i l_ (f i a) r_+ mapit (P i l a r) = let l_ = mapit l+                         r_ = mapit r+                     in l_ `seq` r_ `seq` P i l_ (f i a) r_++-- | See 'Map' class method 'mapWithKey''.+mapWithKeyIntMap' :: (Key -> a -> b) -> IntMap a -> IntMap b+mapWithKeyIntMap' f = mapit where+ mapit  E          = E+ mapit (N i l a r) = let l_ = mapit l+                         r_ = mapit r+                         b  = f i a+                     in b `seq` l_ `seq` r_ `seq` N i l_ b r_+ mapit (Z i l a r) = let l_ = mapit l+                         r_ = mapit r+                         b  = f i a+                     in b `seq` l_ `seq` r_ `seq` Z i l_ b r_+ mapit (P i l a r) = let l_ = mapit l+                         r_ = mapit r+                         b  = f i a+                     in b `seq` l_ `seq` r_ `seq` P i l_ b r_++-- | See 'Map' class method 'filter'.+filterIntMap :: (a -> Bool) -> IntMap a -> IntMap a+filterIntMap p t0 = case filter_ 0# t0 of (# _,t_,_ #) -> t_  -- Work with relative heights!!+ where filter_ h t = case t of+                     E         -> (# False,E,h #)+                     N i l e r -> f i l ((h)-#2#) e r ((h)-#1#)+                     Z i l e r -> f i l ((h)-#1#) e r ((h)-#1#)+                     P i l e r -> f i l ((h)-#1#) e r ((h)-#2#)+        where f i l hl e r hr =                     case filter_ hl l of+                                (# bl,l_,hl_ #)  -> case filter_ hr r of+                                 (# br,r_,hr_ #) -> if p e+                                                    then if bl || br+                                                         then case spliceH i l_ hl_ e r_ hr_ of+                                                              (# t_,h_ #) -> (# True,t_,h_ #)+                                                         else (# False,t,h #)+                                                    else case joinH l_ hl_ r_ hr_ of+                                                         (# t_,h_ #) -> (# True,t_,h_ #)++-- | See 'Map' class method 'foldElemsAsc'.+foldElemsAscIntMap :: (a -> b -> b) -> b -> IntMap a -> b+foldElemsAscIntMap f bb mp = foldU mp bb  where+ foldU  E          b = b+ foldU (N _ l a r) b = foldV l a r b+ foldU (Z _ l a r) b = foldV l a r b+ foldU (P _ l a r) b = foldV l a r b+ foldV      l a r  b = foldU l (f a (foldU r b))++-- | See 'Map' class method 'foldElemsDesc'.+foldElemsDescIntMap :: (a -> b -> b) -> b -> IntMap a -> b+foldElemsDescIntMap f bb mp = foldU mp bb  where+ foldU  E          b = b+ foldU (N _ l a r) b = foldV l a r b+ foldU (Z _ l a r) b = foldV l a r b+ foldU (P _ l a r) b = foldV l a r b+ foldV      l a r  b = foldU r (f a (foldU l b))++-- | See 'Map' class method 'foldKeysAsc'.+foldKeysAscIntMap :: (Key -> b -> b) -> b -> IntMap a -> b+foldKeysAscIntMap f bb mp = foldU mp bb  where+ foldU  E          b = b+ foldU (N k l _ r) b = foldV k l r b+ foldU (Z k l _ r) b = foldV k l r b+ foldU (P k l _ r) b = foldV k l r b+ foldV    k l   r  b = foldU l (f k (foldU r b))++-- | See 'Map' class method 'foldKeysDesc'.+foldKeysDescIntMap :: (Key -> b -> b) -> b -> IntMap a -> b+foldKeysDescIntMap f bb mp = foldU mp bb  where+ foldU  E          b = b+ foldU (N k l _ r) b = foldV k l r b+ foldU (Z k l _ r) b = foldV k l r b+ foldU (P k l _ r) b = foldV k l r b+ foldV    k l   r  b = foldU r (f k (foldU l b))++-- | See 'Map' class method 'foldAssocsAsc'.+foldAssocsAscIntMap :: (Key -> a -> b -> b) -> b -> IntMap a -> b+foldAssocsAscIntMap f bb mp = foldU mp bb  where+ foldU  E          b = b+ foldU (N k l a r) b = foldV k l a r b+ foldU (Z k l a r) b = foldV k l a r b+ foldU (P k l a r) b = foldV k l a r b+ foldV    k l a r  b = foldU l (f k a (foldU r b))++-- | See 'Map' class method 'foldAssocsDesc'.+foldAssocsDescIntMap :: (Key -> a -> b -> b) -> b -> IntMap a -> b+foldAssocsDescIntMap f bb mp = foldU mp bb  where+ foldU  E          b = b+ foldU (N k l a r) b = foldV k l a r b+ foldU (Z k l a r) b = foldV k l a r b+ foldU (P k l a r) b = foldV k l a r b+ foldV    k l a r  b = foldU r (f k a (foldU l b))++-- | See 'Map' class method 'foldElemsAsc''.+foldElemsAscIntMap' :: (a -> b -> b) -> b -> IntMap a -> b+foldElemsAscIntMap' f bb mp = foldU mp bb  where+ foldU  E          b = b+ foldU (N _ l a r) b = foldV l a r b+ foldU (Z _ l a r) b = foldV l a r b+ foldU (P _ l a r) b = foldV l a r b+ foldV      l a r  b = let b'  = foldU r b+                           b'' = f a b'+                       in b' `seq` b'' `seq` foldU l b''++-- | See 'Map' class method 'foldElemsDesc''.+foldElemsDescIntMap' :: (a -> b -> b) -> b -> IntMap a -> b+foldElemsDescIntMap' f bb mp = foldU mp bb  where+ foldU  E          b = b+ foldU (N _ l a r) b = foldV l a r b+ foldU (Z _ l a r) b = foldV l a r b+ foldU (P _ l a r) b = foldV l a r b+ foldV      l a r  b = let b'  = foldU l b+                           b'' = f a b'+                       in b' `seq` b'' `seq` foldU r b''++-- | See 'Map' class method 'foldKeysAsc''.+foldKeysAscIntMap' :: (Key -> b -> b) -> b -> IntMap a -> b+foldKeysAscIntMap' f bb mp = foldU mp bb  where+ foldU  E          b = b+ foldU (N k l _ r) b = foldV k l r b+ foldU (Z k l _ r) b = foldV k l r b+ foldU (P k l _ r) b = foldV k l r b+ foldV    k l   r  b = let b'  = foldU r b+                           b'' = f k b'+                       in b' `seq` b'' `seq` foldU l b''++-- | See 'Map' class method 'foldKeysDesc''.+foldKeysDescIntMap' :: (Key -> b -> b) -> b -> IntMap a -> b+foldKeysDescIntMap' f bb mp = foldU mp bb  where+ foldU  E          b = b+ foldU (N k l _ r) b = foldV k l r b+ foldU (Z k l _ r) b = foldV k l r b+ foldU (P k l _ r) b = foldV k l r b+ foldV    k l   r  b = let b'  = foldU l b+                           b'' = f k b'+                       in b' `seq` b'' `seq` foldU r b''++-- | See 'Map' class method 'foldAssocsAsc''.+foldAssocsAscIntMap' :: (Key -> a -> b -> b) -> b -> IntMap a -> b+foldAssocsAscIntMap' f bb mp = foldU mp bb  where+ foldU  E          b = b+ foldU (N k l a r) b = foldV k l a r b+ foldU (Z k l a r) b = foldV k l a r b+ foldU (P k l a r) b = foldV k l a r b+ foldV    k l a r  b = let b'  = foldU r b+                           b'' = f k a b'+                       in b' `seq` b'' `seq` foldU l b''++-- | See 'Map' class method 'foldAssocsDesc''.+foldAssocsDescIntMap' :: (Key -> a -> b -> b) -> b -> IntMap a -> b+foldAssocsDescIntMap' f bb mp = foldU mp bb  where+ foldU  E          b = b+ foldU (N k l a r) b = foldV k l a r b+ foldU (Z k l a r) b = foldV k l a r b+ foldU (P k l a r) b = foldV k l a r b+ foldV    k l a r  b = let b'  = foldU l b+                           b'' = f k a b'+                       in b' `seq` b'' `seq` foldU r b''++-- | See 'Map' class method 'foldElemsUInt'.+foldElemsUIntIntMap :: (a -> Int# -> Int#) -> Int# -> IntMap a -> Int#+foldElemsUIntIntMap f bb mp = foldU mp bb  where+ foldU  E          b = b+ foldU (N _ l a r) b = foldV l a r b+ foldU (Z _ l a r) b = foldV l a r b+ foldU (P _ l a r) b = foldV l a r b+ foldV      l a r  b = foldU l (f a (foldU r b))++-- | See 'Map' class method 'valid'.+validIntMap :: IntMap a -> Maybe String+validIntMap imp = if (isBalanced imp) then if (isSorted imp) then Nothing+                                                            else Just "IntMap: Tree is not sorted."+                                     else Just "IntMap: Tree is not balanced."++-- | Verify that an IntMap (tree) is height balanced and that the BF of each node is correct.+--+-- Complexity: O(n)+isBalanced :: IntMap a -> Bool+isBalanced t = not (cH t ==# -1#)++-- Local utility, returns height if balanced, -1 if not+cH :: IntMap a -> Int#+cH  E          = 0#+cH (N _ l _ r) = cH_ 1# l r -- (hr-hl) = 1+cH (Z _ l _ r) = cH_ 0# l r -- (hr-hl) = 0+cH (P _ l _ r) = cH_ 1# r l -- (hl-hr) = 1+cH_ :: Int# -> IntMap a -> IntMap a -> Int#+cH_ delta l r = let hl = cH l+                in if hl ==# -1# then hl+                                   else let hr = cH r+                                        in if hr ==# -1# then hr+                                                           else if ((hr)-#(hl)) ==# delta then ((hr)+#1#)+                                                                                           else -1#++-- | Verify that an IntMap (tree) is sorted.+--+-- Complexity: O(n)+isSorted :: IntMap a -> Bool+isSorted  E          = True+isSorted (N i l _ r) = isSorted_ i l r+isSorted (Z i l _ r) = isSorted_ i l r+isSorted (P i l _ r) = isSorted_ i l r+isSorted_ :: Int# -> IntMap a -> IntMap a -> Bool+isSorted_   i l   r  = (isSortedU l i) && (isSortedL i r)+-- Verify tree is sorted and rightmost element is less than an upper limit (ul)+isSortedU :: IntMap a -> Int# -> Bool+isSortedU  E          _  = True+isSortedU (N i l _ r) ul = isSortedU_ i l r ul+isSortedU (Z i l _ r) ul = isSortedU_ i l r ul+isSortedU (P i l _ r) ul = isSortedU_ i l r ul+isSortedU_ :: Int# -> IntMap a -> IntMap a -> Int# -> Bool+isSortedU_   i l   r  ul = case compareInt# i ul of+                           LT -> (isSortedU l i) && (isSortedLU i r ul)+                           _  -> False+-- Verify tree is sorted and leftmost element is greater than a lower limit (ll)+isSortedL :: Int# -> IntMap a -> Bool+isSortedL  _   E          = True+isSortedL  ll (N i l _ r) = isSortedL_ ll i l r+isSortedL  ll (Z i l _ r) = isSortedL_ ll i l r+isSortedL  ll (P i l _ r) = isSortedL_ ll i l r+isSortedL_ :: Int# -> Int# -> IntMap a -> IntMap a -> Bool+isSortedL_ ll    i l   r  = case compareInt# i ll of+                            GT -> (isSortedLU ll l i) && (isSortedL i r)+                            _  -> False+-- Verify tree is sorted and leftmost element is greater than a lower limit (ll)+-- and rightmost element is less than an upper limit (ul)+isSortedLU :: Int# -> IntMap a -> Int# -> Bool+isSortedLU  _   E          _  = True+isSortedLU  ll (N i l _ r) ul = isSortedLU_ ll i l r ul+isSortedLU  ll (Z i l _ r) ul = isSortedLU_ ll i l r ul+isSortedLU  ll (P i l _ r) ul = isSortedLU_ ll i l r ul+isSortedLU_ :: Int# -> Int# -> IntMap a -> IntMap a -> Int# -> Bool+isSortedLU_ ll    i l   r  ul = case compareInt# i ll of+                                GT -> case compareInt# i ul of+                                      LT -> (isSortedLU ll l i) && (isSortedLU i r ul)+                                      _  -> False+                                _  -> False+-- isSorted ends --+-------------------++-- | See 'Map' class method compareKey+compareKeyIntMap :: IntMap a -> Int -> Int -> Ordering+compareKeyIntMap _ = compare++urk :: String+urk = "Urk .. Bug in IntMap!"++-- | See 'Map' class method 'insert'.+insertWithIntMap :: (a -> a) -> Key -> a -> IntMap a -> IntMap a+insertWithIntMap _ k0 a0  E          = Z k0 E a0 E+insertWithIntMap f k0 a0 (N k l a r) = putN f k0 a0 k l a r+insertWithIntMap f k0 a0 (Z k l a r) = putZ f k0 a0 k l a r+insertWithIntMap f k0 a0 (P k l a r) = putP f k0 a0 k l a r++-- | Same as 'insertWithIntMap', but takes the (relative) tree height as an extra argument and+-- returns the updated (relative) tree height.+pushH :: (a -> a) -> Key -> a -> Int# -> IntMap a -> (# IntMap a, Int# #)+pushH _ k0 a0 h E           = (# Z k0 E a0 E, ((h)+#1#) #)+pushH f k0 a0 h (N k l a r) = let t_ = putN f k0 a0 k l a r in t_ `seq` (# t_,h #) -- Height can't change+pushH f k0 a0 h (Z k l a r) = let t_ = putZ f k0 a0 k l a r in+                              case t_ of+                              E         -> error urk -- impossible+                              Z _ _ _ _ -> (# t_,        h  #)+                              _         -> (# t_,((h)+#1#) #)+pushH f k0 a0 h (P k l a r) = let t_ = putP f k0 a0 k l a r in t_ `seq` (# t_,h #) -- Height can't change++----------------------------- LEVEL 1 ---------------------------------+--                       putN, putZ, putP                            --+-----------------------------------------------------------------------++-- Put in (N k l a r), BF=-1  , (never returns P)+putN :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+putN f k0 a0 k l a r = case compareInt# k0 k of+                       LT -> putNL f k0 a0 k l a r+                       EQ -> let a' = f a in N k0 l a' r+                       GT -> putNR f k0 a0 k l a r++-- Put in (Z k l a r), BF= 0+putZ :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+putZ f k0 a0 k l a r = case compareInt# k0 k of+                       LT -> putZL f k0 a0 k l a r+                       EQ -> let a' = f a in Z k0 l a' r+                       GT -> putZR f k0 a0 k l a r++-- Put in (P k l a r), BF=+1 , (never returns N)+putP :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+putP f k0 a0 k l a r = case compareInt# k0 k of+                       LT -> putPL f k0 a0 k l a r+                       EQ -> let a' = f a in P k0 l a' r+                       GT -> putPR f k0 a0 k l a r++----------------------------- LEVEL 2 ---------------------------------+--                      putNL, putZL, putPL                          --+--                      putNR, putZR, putPR                          --+-----------------------------------------------------------------------++-- (putNL k l a r): Put in L subtree of (N k l a r), BF=-1 (Never requires rebalancing) , (never returns P)+{-# INLINE putNL #-}+putNL :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+putNL _ k0 a0 k  E              a r = Z k (Z k0 E a0 E) a r              -- L subtree empty, H:0->1, parent BF:-1-> 0+putNL f k0 a0 k (N lk ll la lr) a r = let l' = putN f k0 a0 lk ll la lr  -- L subtree BF<>0, H:h->h, parent BF:-1->-1+                                      in l' `seq` N k l' a r+putNL f k0 a0 k (P lk ll la lr) a r = let l' = putP f k0 a0 lk ll la lr  -- L subtree BF<>0, H:h->h, parent BF:-1->-1+                                      in l' `seq` N k l' a r+putNL f k0 a0 k (Z lk ll la lr) a r = let l' = putZ f k0 a0 lk ll la lr  -- L subtree BF= 0, so need to look for changes+                                      in case l' of+                                      E         -> error urk -- impossible+                                      Z _ _ _ _ -> N k l' a r -- L subtree BF:0-> 0, H:h->h  , parent BF:-1->-1+                                      _         -> Z k l' a r -- L subtree BF:0->+/-1, H:h->h+1, parent BF:-1-> 0++-- (putZL k l a r): Put in L subtree of (Z k l a r), BF= 0  (Never requires rebalancing) , (never returns N)+{-# INLINE putZL #-}+putZL :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+putZL _ k0 a0 k  E              a r = P k (Z k0 E a0 E) a r              -- L subtree        H:0->1, parent BF: 0->+1+putZL f k0 a0 k (N lk ll la lr) a r = let l' = putN f k0 a0 lk ll la lr  -- L subtree BF<>0, H:h->h, parent BF: 0-> 0+                                      in l' `seq` Z k l' a r+putZL f k0 a0 k (P lk ll la lr) a r = let l' = putP f k0 a0 lk ll la lr  -- L subtree BF<>0, H:h->h, parent BF: 0-> 0+                                      in l' `seq` Z k l' a r+putZL f k0 a0 k (Z lk ll la lr) a r = let l' = putZ f k0 a0 lk ll la lr  -- L subtree BF= 0, so need to look for changes+                                      in case l' of+                                      E         -> error urk -- impossible+                                      Z _ _ _ _ -> Z k l' a r -- L subtree BF: 0-> 0, H:h->h  , parent BF: 0-> 0+                                      _         -> P k l' a r -- L subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->+1++-- (putZR k l a r): Put in R subtree of (Z k l a r), BF= 0 (Never requires rebalancing) , (never returns P)+{-# INLINE putZR #-}+putZR :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+putZR _ k0 a0 k l a  E              = N k l a (Z k0 E a0 E)              -- R subtree        H:0->1, parent BF: 0->-1+putZR f k0 a0 k l a (N rk rl ra rr) = let r' = putN f k0 a0 rk rl ra rr  -- R subtree BF<>0, H:h->h, parent BF: 0-> 0+                                      in r' `seq` Z k l a r'+putZR f k0 a0 k l a (P rk rl ra rr) = let r' = putP f k0 a0 rk rl ra rr  -- R subtree BF<>0, H:h->h, parent BF: 0-> 0+                                      in r' `seq` Z k l a r'+putZR f k0 a0 k l a (Z rk rl ra rr) = let r' = putZ f k0 a0 rk rl ra rr  -- R subtree BF= 0, so need to look for changes+                                      in case r' of+                                      E         -> error urk -- impossible+                                      Z _ _ _ _ -> Z k l a r' -- R subtree BF: 0-> 0, H:h->h  , parent BF: 0-> 0+                                      _         -> N k l a r' -- R subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->-1++-- (putPR k l a r): Put in R subtree of (P k l a r), BF=+1 (Never requires rebalancing) , (never returns N)+{-# INLINE putPR #-}+putPR :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+putPR _ k0 a0 k l a  E              = Z k l a (Z k0 E a0 E)              -- R subtree empty, H:0->1,     parent BF:+1-> 0+putPR f k0 a0 k l a (N rk rl ra rr) = let r' = putN f k0 a0 rk rl ra rr  -- R subtree BF<>0, H:h->h,     parent BF:+1->+1+                                      in r' `seq` P k l a r'+putPR f k0 a0 k l a (P rk rl ra rr) = let r' = putP f k0 a0 rk rl ra rr  -- R subtree BF<>0, H:h->h,     parent BF:+1->+1+                                      in r' `seq` P k l a r'+putPR f k0 a0 k l a (Z rk rl ra rr) = let r' = putZ f k0 a0 rk rl ra rr  -- R subtree BF= 0, so need to look for changes+                                      in case r' of+                                      E         -> error urk -- impossible+                                      Z _ _ _ _ -> P k l a r' -- R subtree BF:0-> 0, H:h->h  , parent BF:+1->+1+                                      _         -> Z k l a r' -- R subtree BF:0->+/-1, H:h->h+1, parent BF:+1-> 0++     -------- These 2 cases (NR and PL) may need rebalancing if they go to LEVEL 3 ---------++-- (putNR k l a r): Put in R subtree of (N k l a r), BF=-1 , (never returns P)+{-# INLINE putNR #-}+putNR :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+putNR _ _  _  _ _ _  E              = error urk      -- impossible if BF=-1+putNR f k0 a0 k l a (N rk rl ra rr) = let r' = putN f k0 a0 rk rl ra rr  -- R subtree BF<>0, H:h->h, parent BF:-1->-1+                                      in r' `seq` N k l a r'+putNR f k0 a0 k l a (P rk rl ra rr) = let r' = putP f k0 a0 rk rl ra rr  -- R subtree BF<>0, H:h->h, parent BF:-1->-1+                                      in r' `seq` N k l a r'+putNR f k0 a0 k l a (Z rk rl ra rr) = case compareInt# k0 rk of  -- determine if RR or RL+                                      LT -> putNRL f k0 a0 k l a rk rl ra  rr          -- RL (never returns P)+                                      EQ -> let ra' = f ra in N k l a (Z k0 rl ra' rr) -- new ra+                                      GT -> putNRR f k0 a0 k l a rk rl ra  rr          -- RR (never returns P)++-- (putPL k l a r): Put in L subtree of (P k l a r), BF=+1 , (never returns N)+{-# INLINE putPL #-}+putPL :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+putPL _ _  _  _  E              _ _ = error urk      -- impossible if BF=+1+putPL f k0 a0 k (N lk ll la lr) a r = let l' = putN f k0 a0 lk ll la lr  -- L subtree BF<>0, H:h->h, parent BF:+1->+1+                                      in l' `seq` P k l' a r+putPL f k0 a0 k (P lk ll la lr) a r = let l' = putP f k0 a0 lk ll la lr  -- L subtree BF<>0, H:h->h, parent BF:+1->+1+                                      in l' `seq` P k l' a r+putPL f k0 a0 k (Z lk ll la lr) a r = case compareInt# k0 lk of  -- determine if LL or LR+                                      LT -> putPLL f k0 a0 k lk ll la lr a r           -- LL (never returns N)+                                      EQ -> let la' = f la in P k (Z k0 ll la' lr) a r -- new la+                                      GT -> putPLR f k0 a0 k lk ll la lr a r           -- LR (never returns N)++----------------------------- LEVEL 3 ---------------------------------+--                        putNRR, putPLL                             --+--                        putNRL, putPLR                             --+-----------------------------------------------------------------------++-- (putNRR k l a rk rl ra rr): Put in RR subtree of (N k l a (Z rk rl ra rr)) , (never returns P)+{-# INLINE putNRR #-}+putNRR :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+putNRR _ k0 a0 k l a rk rl ra  E                  = Z rk (Z k l a rl) ra (Z k0 E a0 E)     -- l and rl must also be E, special CASE RR!!+putNRR f k0 a0 k l a rk rl ra (N rrk rrl rra rrr) = let rr' = putN f k0 a0 rrk rrl rra rrr -- RR subtree BF<>0, H:h->h, so no change+                                                    in rr' `seq` N k l a (Z rk rl ra rr')+putNRR f k0 a0 k l a rk rl ra (P rrk rrl rra rrr) = let rr' = putP f k0 a0 rrk rrl rra rrr -- RR subtree BF<>0, H:h->h, so no change+                                                    in rr' `seq` N k l a (Z rk rl ra rr')+putNRR f k0 a0 k l a rk rl ra (Z rrk rrl rra rrr) = let rr' = putZ f k0 a0 rrk rrl rra rrr -- RR subtree BF= 0, so need to look for changes+                                                    in case rr' of+                                                    E         -> error urk -- impossible+                                                    Z _ _ _ _ -> N k l a (Z rk rl ra rr') -- RR subtree BF: 0-> 0, H:h->h, so no change+                                                    _         -> Z rk (Z k l a rl) ra rr' -- RR subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE RR !!++-- (putPLL k lk ll la lr a r): Put in LL subtree of (P k (Z lk ll la lr) a r) , (never returns N)+{-# INLINE putPLL #-}+putPLL :: (a -> a) -> Key -> a -> Key -> Key -> IntMap a -> a -> IntMap a -> a -> IntMap a -> IntMap a+putPLL _ k0 a0 k lk  E                  la lr a r = Z lk (Z k0 E a0 E) la (Z k lr a r)     -- r and lr must also be E, special CASE LL!!+putPLL f k0 a0 k lk (N llk lll lla llr) la lr a r = let ll' = putN f k0 a0 llk lll lla llr -- LL subtree BF<>0, H:h->h, so no change+                                                    in ll' `seq` P k (Z lk ll' la lr) a r+putPLL f k0 a0 k lk (P llk lll lla llr) la lr a r = let ll' = putP f k0 a0 llk lll lla llr -- LL subtree BF<>0, H:h->h, so no change+                                                    in ll' `seq` P k (Z lk ll' la lr) a r+putPLL f k0 a0 k lk (Z llk lll lla llr) la lr a r = let ll' = putZ f k0 a0 llk lll lla llr -- LL subtree BF= 0, so need to look for changes+                                                    in case ll' of+                                                    E         -> error urk -- impossible+                                                    Z _ _ _ _ -> P k (Z lk ll' la lr) a r -- LL subtree BF: 0-> 0, H:h->h, so no change+                                                    _         -> Z lk ll' la (Z k lr a r) -- LL subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE LL !!++-- (putNRL k l a rk rl ra rr): Put in RL subtree of (N k l a (Z rk rl ra rr)) , (never returns P)+{-# INLINE putNRL #-}+putNRL :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+putNRL _ k0 a0 k l a rk  E                  ra rr = Z k0 (Z k l a E) a0 (Z rk E ra rr)     -- l and rr must also be E, special CASE LR !!+putNRL f k0 a0 k l a rk (N rlk rll rla rlr) ra rr = let rl' = putN f k0 a0 rlk rll rla rlr -- RL subtree BF<>0, H:h->h, so no change+                                                    in rl' `seq` N k l a (Z rk rl' ra rr)+putNRL f k0 a0 k l a rk (P rlk rll rla rlr) ra rr = let rl' = putP f k0 a0 rlk rll rla rlr -- RL subtree BF<>0, H:h->h, so no change+                                                    in rl' `seq` N k l a (Z rk rl' ra rr)+putNRL f k0 a0 k l a rk (Z rlk rll rla rlr) ra rr = let rl' = putZ f k0 a0 rlk rll rla rlr -- RL subtree BF= 0, so need to look for changes+                                                    in case rl' of+                                                    E                     -> error urk -- impossible+                                                    Z _    _    _    _    -> N k l a (Z rk rl' ra rr)                     -- RL subtree BF: 0-> 0, H:h->h, so no change+                                                    N rlk' rll' rla' rlr' -> Z rlk' (P k l a rll') rla' (Z rk rlr' ra rr) -- RL subtree BF: 0->-1, SO.. CASE RL(1) !!+                                                    P rlk' rll' rla' rlr' -> Z rlk' (Z k l a rll') rla' (N rk rlr' ra rr) -- RL subtree BF: 0->+1, SO.. CASE RL(2) !!++-- (putPLR k lk ll la lr a r): Put in LR subtree of (P k (Z lk ll la lr) a r) , (never returns N)+{-# INLINE putPLR #-}+putPLR :: (a -> a) -> Key -> a -> Key -> Key -> IntMap a -> a -> IntMap a -> a -> IntMap a -> IntMap a+putPLR _ k0 a0 k lk ll la  E                  a r = Z k0 (Z lk ll la E) a0 (Z k E a r)      -- r and ll must also be E, special CASE LR !!+putPLR f k0 a0 k lk ll la (N lrk lrl lra lrr) a r = let lr' = putN f k0 a0 lrk lrl lra lrr  -- LR subtree BF<>0, H:h->h, so no change+                                                    in lr' `seq` P k (Z lk ll la lr') a r+putPLR f k0 a0 k lk ll la (P lrk lrl lra lrr) a r = let lr' = putP f k0 a0 lrk lrl lra lrr  -- LR subtree BF<>0, H:h->h, so no change+                                                    in lr' `seq` P k (Z lk ll la lr') a r+putPLR f k0 a0 k lk ll la (Z lrk lrl lra lrr) a r = let lr' = putZ f k0 a0 lrk lrl lra lrr  -- LR subtree BF= 0, so need to look for changes+                                                    in case lr' of+                                                    E                     -> error urk -- impossible+                                                    Z _    _    _    _    -> P k (Z lk ll la lr') a r                     -- LR subtree BF: 0-> 0, H:h->h, so no change+                                                    N lrk' lrl' lra' lrr' -> Z lrk' (P lk ll la lrl') lra' (Z k lrr' a r) -- LR subtree BF: 0->-1, SO.. CASE LR(2) !!+                                                    P lrk' lrl' lra' lrr' -> Z lrk' (Z lk ll la lrl') lra' (N k lrr' a r) -- LR subtree BF: 0->+1, SO.. CASE LR(1) !!+-----------------------------------------------------------------------+--------------------- insertWithIntMap/pushH Ends Here ---------------------+-----------------------------------------------------------------------++-----------------------------------------------------------------------+--------------------- insertWithIntMap/pushH Ends Here ---------------------+-----------------------------------------------------------------------++-- | Same as 'insertWithIntMap', but takes the (relative) tree height as an extra argument and+-- returns the updated (relative) tree height.+pushH' -- cpp madness+       :: (a -> a) -> Key -> a -> Int# -> IntMap a -> (# IntMap a, Int# #)+pushH' _ k0 a0 h E           = -- cpp madness+                               (# Z k0 E a0 E, ((h)+#1#) #)+pushH' f k0 a0 h (N k l a r) = let t_ = pputN f k0 a0 k l a r in t_ `seq`+                               (# t_,h #) -- Height can't change+pushH' f k0 a0 h (Z k l a r) = let t_ = pputZ f k0 a0 k l a r in+                               case t_ of+                               E         -> error urk -- impossible+                               Z _ _ _ _ -> (# t_,        h  #)+                               _         -> (# t_,((h)+#1#) #)+pushH' f k0 a0 h (P k l a r) = let t_ = pputP f k0 a0 k l a r in t_ `seq`+                               (# t_,h #) -- Height can't change++----------------------------- LEVEL 1 ---------------------------------+--                       pputN, pputZ, pputP                         --+-----------------------------------------------------------------------++-- Put in (N k l a r), BF=-1  , (never returns P)+pputN :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+pputN f k0 a0 k l a r = case compareInt# k0 k of+                        LT -> pputNL f k0 a0 k l a r+                        EQ -> let a' = f a in a' `seq` N k0 l a' r+                        GT -> pputNR f k0 a0 k l a r++-- Put in (Z k l a r), BF= 0+pputZ :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+pputZ f k0 a0 k l a r = case compareInt# k0 k of+                        LT -> pputZL f k0 a0 k l a r+                        EQ -> let a' = f a in a' `seq` Z k0 l a' r+                        GT -> pputZR f k0 a0 k l a r++-- Put in (P k l a r), BF=+1 , (never returns N)+pputP :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+pputP f k0 a0 k l a r = case compareInt# k0 k of+                        LT -> pputPL f k0 a0 k l a r+                        EQ -> let a' = f a in a' `seq` P k0 l a' r+                        GT -> pputPR f k0 a0 k l a r++----------------------------- LEVEL 2 ---------------------------------+--                      pputNL, pputZL, pputPL                       --+--                      pputNR, pputZR, pputPR                       --+-----------------------------------------------------------------------++-- (pputNL k l a r): Put in L subtree of (N k l a r), BF=-1 (Never requires rebalancing) , (never returns P)+{-# INLINE pputNL #-}+pputNL :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+pputNL _ k0 a0 k  E              a r = Z k (Z k0 E a0 E) a r              -- L subtree empty, H:0->1, parent BF:-1-> 0+pputNL f k0 a0 k (N lk ll la lr) a r = let l' = pputN f k0 a0 lk ll la lr  -- L subtree BF<>0, H:h->h, parent BF:-1->-1+                                       in l' `seq` N k l' a r+pputNL f k0 a0 k (P lk ll la lr) a r = let l' = pputP f k0 a0 lk ll la lr  -- L subtree BF<>0, H:h->h, parent BF:-1->-1+                                       in l' `seq` N k l' a r+pputNL f k0 a0 k (Z lk ll la lr) a r = let l' = pputZ f k0 a0 lk ll la lr  -- L subtree BF= 0, so need to look for changes+                                       in case l' of+                                       E         -> error urk -- impossible+                                       Z _ _ _ _ -> N k l' a r -- L subtree BF:0-> 0, H:h->h  , parent BF:-1->-1+                                       _         -> Z k l' a r -- L subtree BF:0->+/-1, H:h->h+1, parent BF:-1-> 0++-- (pputZL k l a r): Put in L subtree of (Z k l a r), BF= 0  (Never requires rebalancing) , (never returns N)+{-# INLINE pputZL #-}+pputZL :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+pputZL _ k0 a0 k  E              a r = P k (Z k0 E a0 E) a r              -- L subtree        H:0->1, parent BF: 0->+1+pputZL f k0 a0 k (N lk ll la lr) a r = let l' = pputN f k0 a0 lk ll la lr  -- L subtree BF<>0, H:h->h, parent BF: 0-> 0+                                       in l' `seq` Z k l' a r+pputZL f k0 a0 k (P lk ll la lr) a r = let l' = pputP f k0 a0 lk ll la lr  -- L subtree BF<>0, H:h->h, parent BF: 0-> 0+                                       in l' `seq` Z k l' a r+pputZL f k0 a0 k (Z lk ll la lr) a r = let l' = pputZ f k0 a0 lk ll la lr  -- L subtree BF= 0, so need to look for changes+                                       in case l' of+                                       E         -> error urk -- impossible+                                       Z _ _ _ _ -> Z k l' a r -- L subtree BF: 0-> 0, H:h->h  , parent BF: 0-> 0+                                       _         -> P k l' a r -- L subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->+1++-- (pputZR k l a r): Put in R subtree of (Z k l a r), BF= 0 (Never requires rebalancing) , (never returns P)+{-# INLINE pputZR #-}+pputZR :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+pputZR _ k0 a0 k l a  E              = N k l a (Z k0 E a0 E)              -- R subtree        H:0->1, parent BF: 0->-1+pputZR f k0 a0 k l a (N rk rl ra rr) = let r' = pputN f k0 a0 rk rl ra rr  -- R subtree BF<>0, H:h->h, parent BF: 0-> 0+                                       in r' `seq` Z k l a r'+pputZR f k0 a0 k l a (P rk rl ra rr) = let r' = pputP f k0 a0 rk rl ra rr  -- R subtree BF<>0, H:h->h, parent BF: 0-> 0+                                       in r' `seq` Z k l a r'+pputZR f k0 a0 k l a (Z rk rl ra rr) = let r' = pputZ f k0 a0 rk rl ra rr  -- R subtree BF= 0, so need to look for changes+                                       in case r' of+                                       E         -> error urk -- impossible+                                       Z _ _ _ _ -> Z k l a r' -- R subtree BF: 0-> 0, H:h->h  , parent BF: 0-> 0+                                       _         -> N k l a r' -- R subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->-1++-- (pputPR k l a r): Put in R subtree of (P k l a r), BF=+1 (Never requires rebalancing) , (never returns N)+{-# INLINE pputPR #-}+pputPR :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+pputPR _ k0 a0 k l a  E              = Z k l a (Z k0 E a0 E)              -- R subtree empty, H:0->1,     parent BF:+1-> 0+pputPR f k0 a0 k l a (N rk rl ra rr) = let r' = pputN f k0 a0 rk rl ra rr  -- R subtree BF<>0, H:h->h,     parent BF:+1->+1+                                       in r' `seq` P k l a r'+pputPR f k0 a0 k l a (P rk rl ra rr) = let r' = pputP f k0 a0 rk rl ra rr  -- R subtree BF<>0, H:h->h,     parent BF:+1->+1+                                       in r' `seq` P k l a r'+pputPR f k0 a0 k l a (Z rk rl ra rr) = let r' = pputZ f k0 a0 rk rl ra rr  -- R subtree BF= 0, so need to look for changes+                                       in case r' of+                                       E         -> error urk -- impossible+                                       Z _ _ _ _ -> P k l a r' -- R subtree BF:0-> 0, H:h->h  , parent BF:+1->+1+                                       _         -> Z k l a r' -- R subtree BF:0->+/-1, H:h->h+1, parent BF:+1-> 0++     -------- These 2 cases (NR and PL) may need rebalancing if they go to LEVEL 3 ---------++-- (pputNR k l a r): Put in R subtree of (N k l a r), BF=-1 , (never returns P)+{-# INLINE pputNR #-}+pputNR :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+pputNR _ _  _  _ _ _  E              = error urk      -- impossible if BF=-1+pputNR f k0 a0 k l a (N rk rl ra rr) = let r' = pputN f k0 a0 rk rl ra rr  -- R subtree BF<>0, H:h->h, parent BF:-1->-1+                                       in r' `seq` N k l a r'+pputNR f k0 a0 k l a (P rk rl ra rr) = let r' = pputP f k0 a0 rk rl ra rr  -- R subtree BF<>0, H:h->h, parent BF:-1->-1+                                       in r' `seq` N k l a r'+pputNR f k0 a0 k l a (Z rk rl ra rr) = case compareInt# k0 rk of  -- determine if RR or RL+                                       LT -> pputNRL f k0 a0 k l a rk rl ra rr   -- RL (never returns P)+                                       EQ -> let ra' = f ra in ra' `seq` N k l a (Z k0 rl ra' rr)  -- new ra+                                       GT -> pputNRR f k0 a0 k l a rk rl ra rr   -- RR (never returns P)++-- (pputPL k l a r): Put in L subtree of (P k l a r), BF=+1 , (never returns N)+{-# INLINE pputPL #-}+pputPL :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+pputPL _ _  _  _  E              _ _ = error urk      -- impossible if BF=+1+pputPL f k0 a0 k (N lk ll la lr) a r = let l' = pputN f k0 a0 lk ll la lr  -- L subtree BF<>0, H:h->h, parent BF:+1->+1+                                       in l' `seq` P k l' a r+pputPL f k0 a0 k (P lk ll la lr) a r = let l' = pputP f k0 a0 lk ll la lr  -- L subtree BF<>0, H:h->h, parent BF:+1->+1+                                       in l' `seq` P k l' a r+pputPL f k0 a0 k (Z lk ll la lr) a r = case compareInt# k0 lk of  -- determine if LL or LR+                                       LT -> pputPLL f k0 a0 k lk ll la lr a r -- LL (never returns N)+                                       EQ -> let la' = f la in la' `seq` P k (Z k0 ll la' lr) a r -- new la+                                       GT -> pputPLR f k0 a0 k lk ll la lr a r -- LR (never returns N)++----------------------------- LEVEL 3 ---------------------------------+--                        pputNRR, pputPLL                           --+--                        pputNRL, pputPLR                           --+-----------------------------------------------------------------------++-- (pputNRR k l a rk rl ra rr): Put in RR subtree of (N k l a (Z rk rl ra rr)) , (never returns P)+{-# INLINE pputNRR #-}+pputNRR :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+pputNRR _ k0 a0 k l a rk rl ra  E                  = Z rk (Z k l a rl) ra (Z k0 E a0 E)     -- l and rl must also be E, special CASE RR!!+pputNRR f k0 a0 k l a rk rl ra (N rrk rrl rra rrr) = let rr' = pputN f k0 a0 rrk rrl rra rrr -- RR subtree BF<>0, H:h->h, so no change+                                                     in rr' `seq` N k l a (Z rk rl ra rr')+pputNRR f k0 a0 k l a rk rl ra (P rrk rrl rra rrr) = let rr' = pputP f k0 a0 rrk rrl rra rrr -- RR subtree BF<>0, H:h->h, so no change+                                                     in rr' `seq` N k l a (Z rk rl ra rr')+pputNRR f k0 a0 k l a rk rl ra (Z rrk rrl rra rrr) = let rr' = pputZ f k0 a0 rrk rrl rra rrr -- RR subtree BF= 0, so need to look for changes+                                                     in case rr' of+                                                     E         -> error urk -- impossible+                                                     Z _ _ _ _ -> N k l a (Z rk rl ra rr') -- RR subtree BF: 0-> 0, H:h->h, so no change+                                                     _         -> Z rk (Z k l a rl) ra rr' -- RR subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE RR !!++-- (pputPLL k lk ll la lr a r): Put in LL subtree of (P k (Z lk ll la lr) a r) , (never returns N)+{-# INLINE pputPLL #-}+pputPLL :: (a -> a) -> Key -> a -> Key -> Key -> IntMap a -> a -> IntMap a -> a -> IntMap a -> IntMap a+pputPLL _ k0 a0 k lk  E                  la lr a r = Z lk (Z k0 E a0 E) la (Z k lr a r)     -- r and lr must also be E, special CASE LL!!+pputPLL f k0 a0 k lk (N llk lll lla llr) la lr a r = let ll' = pputN f k0 a0 llk lll lla llr -- LL subtree BF<>0, H:h->h, so no change+                                                     in ll' `seq` P k (Z lk ll' la lr) a r+pputPLL f k0 a0 k lk (P llk lll lla llr) la lr a r = let ll' = pputP f k0 a0 llk lll lla llr -- LL subtree BF<>0, H:h->h, so no change+                                                     in ll' `seq` P k (Z lk ll' la lr) a r+pputPLL f k0 a0 k lk (Z llk lll lla llr) la lr a r = let ll' = pputZ f k0 a0 llk lll lla llr -- LL subtree BF= 0, so need to look for changes+                                                     in case ll' of+                                                     E         -> error urk -- impossible+                                                     Z _ _ _ _ -> P k (Z lk ll' la lr) a r -- LL subtree BF: 0-> 0, H:h->h, so no change+                                                     _         -> Z lk ll' la (Z k lr a r) -- LL subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE LL !!++-- (pputNRL k l a rk rl ra rr): Put in RL subtree of (N k l a (Z rk rl ra rr)) , (never returns P)+{-# INLINE pputNRL #-}+pputNRL :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+pputNRL _ k0 a0 k l a rk  E                  ra rr = Z k0 (Z k l a E) a0 (Z rk E ra rr)     -- l and rr must also be E, special CASE LR !!+pputNRL f k0 a0 k l a rk (N rlk rll rla rlr) ra rr = let rl' = pputN f k0 a0 rlk rll rla rlr -- RL subtree BF<>0, H:h->h, so no change+                                                     in rl' `seq` N k l a (Z rk rl' ra rr)+pputNRL f k0 a0 k l a rk (P rlk rll rla rlr) ra rr = let rl' = pputP f k0 a0 rlk rll rla rlr -- RL subtree BF<>0, H:h->h, so no change+                                                     in rl' `seq` N k l a (Z rk rl' ra rr)+pputNRL f k0 a0 k l a rk (Z rlk rll rla rlr) ra rr = let rl' = pputZ f k0 a0 rlk rll rla rlr -- RL subtree BF= 0, so need to look for changes+                                                     in case rl' of+                                                     E                     -> error urk -- impossible+                                                     Z _    _    _    _    -> N k l a (Z rk rl' ra rr)                     -- RL subtree BF: 0-> 0, H:h->h, so no change+                                                     N rlk' rll' rla' rlr' -> Z rlk' (P k l a rll') rla' (Z rk rlr' ra rr) -- RL subtree BF: 0->-1, SO.. CASE RL(1) !!+                                                     P rlk' rll' rla' rlr' -> Z rlk' (Z k l a rll') rla' (N rk rlr' ra rr) -- RL subtree BF: 0->+1, SO.. CASE RL(2) !!++-- (pputPLR k lk ll la lr a r): Put in LR subtree of (P k (Z lk ll la lr) a r) , (never returns N)+{-# INLINE pputPLR #-}+pputPLR :: (a -> a) -> Key -> a -> Key -> Key -> IntMap a -> a -> IntMap a -> a -> IntMap a -> IntMap a+pputPLR _ k0 a0 k lk ll la  E                  a r = Z k0 (Z lk ll la E) a0 (Z k E a r)      -- r and ll must also be E, special CASE LR !!+pputPLR f k0 a0 k lk ll la (N lrk lrl lra lrr) a r = let lr' = pputN f k0 a0 lrk lrl lra lrr  -- LR subtree BF<>0, H:h->h, so no change+                                                     in lr' `seq` P k (Z lk ll la lr') a r+pputPLR f k0 a0 k lk ll la (P lrk lrl lra lrr) a r = let lr' = pputP f k0 a0 lrk lrl lra lrr  -- LR subtree BF<>0, H:h->h, so no change+                                                     in lr' `seq` P k (Z lk ll la lr') a r+pputPLR f k0 a0 k lk ll la (Z lrk lrl lra lrr) a r = let lr' = pputZ f k0 a0 lrk lrl lra lrr  -- LR subtree BF= 0, so need to look for changes+                                                     in case lr' of+                                                     E                     -> error urk -- impossible+                                                     Z _    _    _    _    -> P k (Z lk ll la lr') a r                     -- LR subtree BF: 0-> 0, H:h->h, so no change+                                                     N lrk' lrl' lra' lrr' -> Z lrk' (P lk ll la lrl') lra' (Z k lrr' a r) -- LR subtree BF: 0->-1, SO.. CASE LR(2) !!+                                                     P lrk' lrl' lra' lrr' -> Z lrk' (Z lk ll la lrl') lra' (N k lrr' a r) -- LR subtree BF: 0->+1, SO.. CASE LR(1) !!+-----------------------------------------------------------------------+-------------------- insertWithIntMap'/pushH' Ends Here --------------------+-----------------------------------------------------------------------++-- | See 'Map' class method 'insert'.+insertWithIntMap' -- cpp madness+             :: (a -> a) -> Key -> a -> IntMap a -> IntMap a+insertWithIntMap' _ k0 a0  E          = a0 `seq` Z k0 E a0 E+insertWithIntMap' f k0 a0 (N k l a r) = ppputN f k0 a0 k l a r+insertWithIntMap' f k0 a0 (Z k l a r) = ppputZ f k0 a0 k l a r+insertWithIntMap' f k0 a0 (P k l a r) = ppputP f k0 a0 k l a r++{- Not used currently -+-- | Same as 'insertWithIntMap', but takes the (relative) tree height as an extra argument and+-- returns the updated (relative) tree height.+pushH'' -- cpp madness+        :: (a -> a) -> Key -> a -> Int# -> IntMap a -> (# IntMap a, Int# #)+pushH'' _ k0 a0 h E           = -- cpp madness+                                a0 `seq` (# Z k0 E a0 E, ((h)+#1#) #)+pushH'' f k0 a0 h (N k l a r) = let t_ = ppputN f k0 a0 k l a r in t_ `seq`+                                (# t_,h #) -- Height can't change+pushH'' f k0 a0 h (Z k l a r) = let t_ = ppputZ f k0 a0 k l a r in+                                case t_ of+                                E         -> error urk -- impossible+                                Z _ _ _ _ -> (# t_,        h  #)+                                _         -> (# t_,((h)+#1#) #)+pushH'' f k0 a0 h (P k l a r) = let t_ = ppputP f k0 a0 k l a r in t_ `seq`+                                (# t_,h #) -- Height can't change+- Not used currently -}++----------------------------- LEVEL 1 ---------------------------------+--                       ppputN, ppputZ, ppputP                      --+-----------------------------------------------------------------------++-- Put in (N k l a r), BF=-1  , (never returns P)+ppputN :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+ppputN f k0 a0 k l a r = case compareInt# k0 k of+                         LT -> ppputNL f k0 a0 k l a r+                         EQ -> let a' = f a in a' `seq` N k0 l a' r+                         GT -> ppputNR f k0 a0 k l a r++-- Put in (Z k l a r), BF= 0+ppputZ :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+ppputZ f k0 a0 k l a r = case compareInt# k0 k of+                         LT -> ppputZL f k0 a0 k l a r+                         EQ -> let a' = f a in a' `seq` Z k0 l a' r+                         GT -> ppputZR f k0 a0 k l a r++-- Put in (P k l a r), BF=+1 , (never returns N)+ppputP :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+ppputP f k0 a0 k l a r = case compareInt# k0 k of+                         LT -> ppputPL f k0 a0 k l a r+                         EQ -> let a' = f a in a' `seq` P k0 l a' r+                         GT -> ppputPR f k0 a0 k l a r++----------------------------- LEVEL 2 ---------------------------------+--                      ppputNL, ppputZL, ppputPL                    --+--                      ppputNR, ppputZR, ppputPR                    --+-----------------------------------------------------------------------++-- (ppputNL k l a r): Put in L subtree of (N k l a r), BF=-1 (Never requires rebalancing) , (never returns P)+{-# INLINE ppputNL #-}+ppputNL :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+ppputNL _ k0 a0 k  E              a r = a0 `seq` Z k (Z k0 E a0 E) a r       -- L subtree empty, H:0->1, parent BF:-1-> 0+ppputNL f k0 a0 k (N lk ll la lr) a r = let l' = ppputN f k0 a0 lk ll la lr  -- L subtree BF<>0, H:h->h, parent BF:-1->-1+                                        in l' `seq` N k l' a r+ppputNL f k0 a0 k (P lk ll la lr) a r = let l' = ppputP f k0 a0 lk ll la lr  -- L subtree BF<>0, H:h->h, parent BF:-1->-1+                                        in l' `seq` N k l' a r+ppputNL f k0 a0 k (Z lk ll la lr) a r = let l' = ppputZ f k0 a0 lk ll la lr  -- L subtree BF= 0, so need to look for changes+                                        in case l' of+                                        E         -> error urk -- impossible+                                        Z _ _ _ _ -> N k l' a r -- L subtree BF:0-> 0, H:h->h  , parent BF:-1->-1+                                        _         -> Z k l' a r -- L subtree BF:0->+/-1, H:h->h+1, parent BF:-1-> 0++-- (ppputZL k l a r): Put in L subtree of (Z k l a r), BF= 0  (Never requires rebalancing) , (never returns N)+{-# INLINE ppputZL #-}+ppputZL :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+ppputZL _ k0 a0 k  E              a r = a0 `seq` P k (Z k0 E a0 E) a r       -- L subtree        H:0->1, parent BF: 0->+1+ppputZL f k0 a0 k (N lk ll la lr) a r = let l' = ppputN f k0 a0 lk ll la lr  -- L subtree BF<>0, H:h->h, parent BF: 0-> 0+                                        in l' `seq` Z k l' a r+ppputZL f k0 a0 k (P lk ll la lr) a r = let l' = ppputP f k0 a0 lk ll la lr  -- L subtree BF<>0, H:h->h, parent BF: 0-> 0+                                        in l' `seq` Z k l' a r+ppputZL f k0 a0 k (Z lk ll la lr) a r = let l' = ppputZ f k0 a0 lk ll la lr  -- L subtree BF= 0, so need to look for changes+                                        in case l' of+                                        E         -> error urk -- impossible+                                        Z _ _ _ _ -> Z k l' a r -- L subtree BF: 0-> 0, H:h->h  , parent BF: 0-> 0+                                        _         -> P k l' a r -- L subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->+1++-- (ppputZR k l a r): Put in R subtree of (Z k l a r), BF= 0 (Never requires rebalancing) , (never returns P)+{-# INLINE ppputZR #-}+ppputZR :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+ppputZR _ k0 a0 k l a  E              = a0 `seq` N k l a (Z k0 E a0 E)       -- R subtree        H:0->1, parent BF: 0->-1+ppputZR f k0 a0 k l a (N rk rl ra rr) = let r' = ppputN f k0 a0 rk rl ra rr  -- R subtree BF<>0, H:h->h, parent BF: 0-> 0+                                        in r' `seq` Z k l a r'+ppputZR f k0 a0 k l a (P rk rl ra rr) = let r' = ppputP f k0 a0 rk rl ra rr  -- R subtree BF<>0, H:h->h, parent BF: 0-> 0+                                        in r' `seq` Z k l a r'+ppputZR f k0 a0 k l a (Z rk rl ra rr) = let r' = ppputZ f k0 a0 rk rl ra rr  -- R subtree BF= 0, so need to look for changes+                                        in case r' of+                                        E         -> error urk -- impossible+                                        Z _ _ _ _ -> Z k l a r' -- R subtree BF: 0-> 0, H:h->h  , parent BF: 0-> 0+                                        _         -> N k l a r' -- R subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->-1++-- (ppputPR k l a r): Put in R subtree of (P k l a r), BF=+1 (Never requires rebalancing) , (never returns N)+{-# INLINE ppputPR #-}+ppputPR :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+ppputPR _ k0 a0 k l a  E              = a0 `seq` Z k l a (Z k0 E a0 E)       -- R subtree empty, H:0->1,     parent BF:+1-> 0+ppputPR f k0 a0 k l a (N rk rl ra rr) = let r' = ppputN f k0 a0 rk rl ra rr  -- R subtree BF<>0, H:h->h,     parent BF:+1->+1+                                        in r' `seq` P k l a r'+ppputPR f k0 a0 k l a (P rk rl ra rr) = let r' = ppputP f k0 a0 rk rl ra rr  -- R subtree BF<>0, H:h->h,     parent BF:+1->+1+                                        in r' `seq` P k l a r'+ppputPR f k0 a0 k l a (Z rk rl ra rr) = let r' = ppputZ f k0 a0 rk rl ra rr  -- R subtree BF= 0, so need to look for changes+                                        in case r' of+                                        E         -> error urk -- impossible+                                        Z _ _ _ _ -> P k l a r' -- R subtree BF:0-> 0, H:h->h  , parent BF:+1->+1+                                        _         -> Z k l a r' -- R subtree BF:0->+/-1, H:h->h+1, parent BF:+1-> 0++     -------- These 2 cases (NR and PL) may need rebalancing if they go to LEVEL 3 ---------++-- (ppputNR k l a r): Put in R subtree of (N k l a r), BF=-1 , (never returns P)+{-# INLINE ppputNR #-}+ppputNR :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+ppputNR _ _  _  _ _ _  E              = error urk      -- impossible if BF=-1+ppputNR f k0 a0 k l a (N rk rl ra rr) = let r' = ppputN f k0 a0 rk rl ra rr  -- R subtree BF<>0, H:h->h, parent BF:-1->-1+                                        in r' `seq` N k l a r'+ppputNR f k0 a0 k l a (P rk rl ra rr) = let r' = ppputP f k0 a0 rk rl ra rr  -- R subtree BF<>0, H:h->h, parent BF:-1->-1+                                        in r' `seq` N k l a r'+ppputNR f k0 a0 k l a (Z rk rl ra rr) = case compareInt# k0 rk of  -- determine if RR or RL+                                        LT -> ppputNRL f k0 a0 k l a rk rl ra rr   -- RL (never returns P)+                                        EQ -> let ra' = f ra in ra' `seq` N k l a (Z k0 rl ra' rr)  -- new ra+                                        GT -> ppputNRR f k0 a0 k l a rk rl ra rr   -- RR (never returns P)++-- (ppputPL k l a r): Put in L subtree of (P k l a r), BF=+1 , (never returns N)+{-# INLINE ppputPL #-}+ppputPL :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+ppputPL _ _  _  _  E              _ _ = error urk      -- impossible if BF=+1+ppputPL f k0 a0 k (N lk ll la lr) a r = let l' = ppputN f k0 a0 lk ll la lr  -- L subtree BF<>0, H:h->h, parent BF:+1->+1+                                        in l' `seq` P k l' a r+ppputPL f k0 a0 k (P lk ll la lr) a r = let l' = ppputP f k0 a0 lk ll la lr  -- L subtree BF<>0, H:h->h, parent BF:+1->+1+                                        in l' `seq` P k l' a r+ppputPL f k0 a0 k (Z lk ll la lr) a r = case compareInt# k0 lk of  -- determine if LL or LR+                                        LT -> ppputPLL f k0 a0 k lk ll la lr a r -- LL (never returns N)+                                        EQ -> let la' = f la in la' `seq` P k (Z k0 ll la' lr) a r -- new la+                                        GT -> ppputPLR f k0 a0 k lk ll la lr a r -- LR (never returns N)++----------------------------- LEVEL 3 ---------------------------------+--                        ppputNRR, ppputPLL                         --+--                        ppputNRL, ppputPLR                         --+-----------------------------------------------------------------------++-- (ppputNRR k l a rk rl ra rr): Put in RR subtree of (N k l a (Z rk rl ra rr)) , (never returns P)+{-# INLINE ppputNRR #-}+ppputNRR :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+ppputNRR _ k0 a0 k l a rk rl ra  E                  = a0 `seq` Z rk (Z k l a rl) ra (Z k0 E a0 E) -- l and rl must also be E, special CASE RR!!+ppputNRR f k0 a0 k l a rk rl ra (N rrk rrl rra rrr) = let rr' = ppputN f k0 a0 rrk rrl rra rrr -- RR subtree BF<>0, H:h->h, so no change+                                                      in rr' `seq` N k l a (Z rk rl ra rr')+ppputNRR f k0 a0 k l a rk rl ra (P rrk rrl rra rrr) = let rr' = ppputP f k0 a0 rrk rrl rra rrr -- RR subtree BF<>0, H:h->h, so no change+                                                      in rr' `seq` N k l a (Z rk rl ra rr')+ppputNRR f k0 a0 k l a rk rl ra (Z rrk rrl rra rrr) = let rr' = ppputZ f k0 a0 rrk rrl rra rrr -- RR subtree BF= 0, so need to look for changes+                                                      in case rr' of+                                                      E         -> error urk -- impossible+                                                      Z _ _ _ _ -> N k l a (Z rk rl ra rr') -- RR subtree BF: 0-> 0, H:h->h, so no change+                                                      _         -> Z rk (Z k l a rl) ra rr' -- RR subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE RR !!++-- (ppputPLL k lk ll la lr a r): Put in LL subtree of (P k (Z lk ll la lr) a r) , (never returns N)+{-# INLINE ppputPLL #-}+ppputPLL :: (a -> a) -> Key -> a -> Key -> Key -> IntMap a -> a -> IntMap a -> a -> IntMap a -> IntMap a+ppputPLL _ k0 a0 k lk  E                  la lr a r = a0 `seq` Z lk (Z k0 E a0 E) la (Z k lr a r) -- r and lr must also be E, special CASE LL!!+ppputPLL f k0 a0 k lk (N llk lll lla llr) la lr a r = let ll' = ppputN f k0 a0 llk lll lla llr -- LL subtree BF<>0, H:h->h, so no change+                                                      in ll' `seq` P k (Z lk ll' la lr) a r+ppputPLL f k0 a0 k lk (P llk lll lla llr) la lr a r = let ll' = ppputP f k0 a0 llk lll lla llr -- LL subtree BF<>0, H:h->h, so no change+                                                      in ll' `seq` P k (Z lk ll' la lr) a r+ppputPLL f k0 a0 k lk (Z llk lll lla llr) la lr a r = let ll' = ppputZ f k0 a0 llk lll lla llr -- LL subtree BF= 0, so need to look for changes+                                                      in case ll' of+                                                      E         -> error urk -- impossible+                                                      Z _ _ _ _ -> P k (Z lk ll' la lr) a r -- LL subtree BF: 0-> 0, H:h->h, so no change+                                                      _         -> Z lk ll' la (Z k lr a r) -- LL subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE LL !!++-- (ppputNRL k l a rk rl ra rr): Put in RL subtree of (N k l a (Z rk rl ra rr)) , (never returns P)+{-# INLINE ppputNRL #-}+ppputNRL :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+ppputNRL _ k0 a0 k l a rk  E                  ra rr = a0 `seq` Z k0 (Z k l a E) a0 (Z rk E ra rr) -- l and rr must also be E, special CASE LR !!+ppputNRL f k0 a0 k l a rk (N rlk rll rla rlr) ra rr = let rl' = ppputN f k0 a0 rlk rll rla rlr -- RL subtree BF<>0, H:h->h, so no change+                                                      in rl' `seq` N k l a (Z rk rl' ra rr)+ppputNRL f k0 a0 k l a rk (P rlk rll rla rlr) ra rr = let rl' = ppputP f k0 a0 rlk rll rla rlr -- RL subtree BF<>0, H:h->h, so no change+                                                      in rl' `seq` N k l a (Z rk rl' ra rr)+ppputNRL f k0 a0 k l a rk (Z rlk rll rla rlr) ra rr = let rl' = ppputZ f k0 a0 rlk rll rla rlr -- RL subtree BF= 0, so need to look for changes+                                                      in case rl' of+                                                      E                     -> error urk -- impossible+                                                      Z _    _    _    _    -> N k l a (Z rk rl' ra rr)                     -- RL subtree BF: 0-> 0, H:h->h, so no change+                                                      N rlk' rll' rla' rlr' -> Z rlk' (P k l a rll') rla' (Z rk rlr' ra rr) -- RL subtree BF: 0->-1, SO.. CASE RL(1) !!+                                                      P rlk' rll' rla' rlr' -> Z rlk' (Z k l a rll') rla' (N rk rlr' ra rr) -- RL subtree BF: 0->+1, SO.. CASE RL(2) !!++-- (ppputPLR k lk ll la lr a r): Put in LR subtree of (P k (Z lk ll la lr) a r) , (never returns N)+{-# INLINE ppputPLR #-}+ppputPLR :: (a -> a) -> Key -> a -> Key -> Key -> IntMap a -> a -> IntMap a -> a -> IntMap a -> IntMap a+ppputPLR _ k0 a0 k lk ll la  E                  a r = a0 `seq` Z k0 (Z lk ll la E) a0 (Z k E a r) -- r and ll must also be E, special CASE LR !!+ppputPLR f k0 a0 k lk ll la (N lrk lrl lra lrr) a r = let lr' = ppputN f k0 a0 lrk lrl lra lrr  -- LR subtree BF<>0, H:h->h, so no change+                                                      in lr' `seq` P k (Z lk ll la lr') a r+ppputPLR f k0 a0 k lk ll la (P lrk lrl lra lrr) a r = let lr' = ppputP f k0 a0 lrk lrl lra lrr  -- LR subtree BF<>0, H:h->h, so no change+                                                      in lr' `seq` P k (Z lk ll la lr') a r+ppputPLR f k0 a0 k lk ll la (Z lrk lrl lra lrr) a r = let lr' = ppputZ f k0 a0 lrk lrl lra lrr  -- LR subtree BF= 0, so need to look for changes+                                                      in case lr' of+                                                      E                     -> error urk -- impossible+                                                      Z _    _    _    _    -> P k (Z lk ll la lr') a r                     -- LR subtree BF: 0-> 0, H:h->h, so no change+                                                      N lrk' lrl' lra' lrr' -> Z lrk' (P lk ll la lrl') lra' (Z k lrr' a r) -- LR subtree BF: 0->-1, SO.. CASE LR(2) !!+                                                      P lrk' lrl' lra' lrr' -> Z lrk' (Z lk ll la lrl') lra' (N k lrr' a r) -- LR subtree BF: 0->+1, SO.. CASE LR(1) !!+-----------------------------------------------------------------------+------------------ insertWithIntMap'/pushH'' Ends Here --------------------+-----------------------------------------------------------------------++-- | Local insertion facility which just overwrites any existing entry.+ins :: Key -> a -> IntMap a -> IntMap a+ins k0 a0  E          = Z k0 E a0 E+ins k0 a0 (N k l a r) = insN k0 a0 k l a r+ins k0 a0 (Z k l a r) = insZ k0 a0 k l a r+ins k0 a0 (P k l a r) = insP k0 a0 k l a r++-- | Same as 'ins', but takes the (relative) tree height as an extra argument and+-- returns the updated (relative) tree height.+insH :: Key -> a -> Int# -> IntMap a -> (# IntMap a, Int# #)+insH k0 a0 h E           = (# Z k0 E a0 E, ((h)+#1#) #)+insH k0 a0 h (N k l a r) = let t_ = insN k0 a0 k l a r in t_ `seq` (# t_,h #) -- Height can't change+insH k0 a0 h (Z k l a r) = let t_ = insZ k0 a0 k l a r in+                           case t_ of+                           N _ _ _ _ -> (# t_,((h)+#1#) #)+                           P _ _ _ _ -> (# t_,((h)+#1#) #)+                           _         -> (# t_,        h  #)+insH k0 a0 h (P k l a r) = let t_ = insP k0 a0 k l a r in t_ `seq` (# t_,h #) -- Height can't change++----------------------------- LEVEL 1 ---------------------------------+--                       insN, insZ, insP                            --+-----------------------------------------------------------------------++-- Put in (N k l a r), BF=-1  , (never returns P)+insN :: Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+insN k0 a0 k l a r = case compareInt# k0 k of+                     LT -> insNL k0 a0 k l a r+                     EQ -> N k l a0 r+                     GT -> insNR k0 a0 k l a r++-- Put in (Z k l a r), BF= 0+insZ :: Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+insZ k0 a0 k l a r = case compareInt# k0 k of+                     LT -> insZL k0 a0 k l a r+                     EQ -> Z k l a0 r+                     GT -> insZR k0 a0 k l a r++-- Put in (P k l a r), BF=+1 , (never returns N)+insP :: Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+insP k0 a0 k l a r = case compareInt# k0 k of+                     LT -> insPL k0 a0 k l a r+                     EQ -> P k l a0 r+                     GT -> insPR k0 a0 k l a r++----------------------------- LEVEL 2 ---------------------------------+--                      insNL, insZL, insPL                          --+--                      insNR, insZR, insPR                          --+-----------------------------------------------------------------------++-- (insNL k l a r): Put in L subtree of (N k l a r), BF=-1 (Never requires rebalancing) , (never returns P)+{-# INLINE insNL #-}+insNL :: Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+insNL k0 a0 k  E              a r = Z k (Z k0 E a0 E) a r            -- L subtree empty, H:0->1, parent BF:-1-> 0+insNL k0 a0 k (N lk ll la lr) a r = let l' = insN k0 a0 lk ll la lr  -- L subtree BF<>0, H:h->h, parent BF:-1->-1+                                    in l' `seq` N k l' a r+insNL k0 a0 k (P lk ll la lr) a r = let l' = insP k0 a0 lk ll la lr  -- L subtree BF<>0, H:h->h, parent BF:-1->-1+                                    in l' `seq` N k l' a r+insNL k0 a0 k (Z lk ll la lr) a r = let l' = insZ k0 a0 lk ll la lr  -- L subtree BF= 0, so need to look for changes+                                    in case l' of+                                    E         -> error urk -- impossible+                                    Z _ _ _ _ -> N k l' a r -- L subtree BF:0-> 0, H:h->h  , parent BF:-1->-1+                                    _         -> Z k l' a r -- L subtree BF:0->+/-1, H:h->h+1, parent BF:-1-> 0++-- (insZL k l a r): Put in L subtree of (Z k l a r), BF= 0  (Never requires rebalancing) , (never returns N)+{-# INLINE insZL #-}+insZL :: Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+insZL k0 a0 k  E              a r = P k (Z k0 E a0 E) a r            -- L subtree        H:0->1, parent BF: 0->+1+insZL k0 a0 k (N lk ll la lr) a r = let l' = insN k0 a0 lk ll la lr  -- L subtree BF<>0, H:h->h, parent BF: 0-> 0+                                    in l' `seq` Z k l' a r+insZL k0 a0 k (P lk ll la lr) a r = let l' = insP k0 a0 lk ll la lr  -- L subtree BF<>0, H:h->h, parent BF: 0-> 0+                                    in l' `seq` Z k l' a r+insZL k0 a0 k (Z lk ll la lr) a r = let l' = insZ k0 a0 lk ll la lr  -- L subtree BF= 0, so need to look for changes+                                    in case l' of+                                    E         -> error urk -- impossible+                                    Z _ _ _ _ -> Z k l' a r -- L subtree BF: 0-> 0, H:h->h  , parent BF: 0-> 0+                                    _         -> P k l' a r -- L subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->+1++-- (insZR k l a r): Put in R subtree of (Z k l a r), BF= 0 (Never requires rebalancing) , (never returns P)+{-# INLINE insZR #-}+insZR :: Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+insZR k0 a0 k l a  E              = N k l a (Z k0 E a0 E)            -- R subtree        H:0->1, parent BF: 0->-1+insZR k0 a0 k l a (N rk rl ra rr) = let r' = insN k0 a0 rk rl ra rr  -- R subtree BF<>0, H:h->h, parent BF: 0-> 0+                                    in r' `seq` Z k l a r'+insZR k0 a0 k l a (P rk rl ra rr) = let r' = insP k0 a0 rk rl ra rr  -- R subtree BF<>0, H:h->h, parent BF: 0-> 0+                                    in r' `seq` Z k l a r'+insZR k0 a0 k l a (Z rk rl ra rr) = let r' = insZ k0 a0 rk rl ra rr  -- R subtree BF= 0, so need to look for changes+                                    in case r' of+                                    E         -> error urk -- impossible+                                    Z _ _ _ _ -> Z k l a r' -- R subtree BF: 0-> 0, H:h->h  , parent BF: 0-> 0+                                    _         -> N k l a r' -- R subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->-1++-- (insPR k l a r): Put in R subtree of (P k l a r), BF=+1 (Never requires rebalancing) , (never returns N)+{-# INLINE insPR #-}+insPR :: Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+insPR k0 a0 k l a  E              = Z k l a (Z k0 E a0 E)            -- R subtree empty, H:0->1,     parent BF:+1-> 0+insPR k0 a0 k l a (N rk rl ra rr) = let r' = insN k0 a0 rk rl ra rr  -- R subtree BF<>0, H:h->h,     parent BF:+1->+1+                                    in r' `seq` P k l a r'+insPR k0 a0 k l a (P rk rl ra rr) = let r' = insP k0 a0 rk rl ra rr  -- R subtree BF<>0, H:h->h,     parent BF:+1->+1+                                    in r' `seq` P k l a r'+insPR k0 a0 k l a (Z rk rl ra rr) = let r' = insZ k0 a0 rk rl ra rr  -- R subtree BF= 0, so need to look for changes+                                    in case r' of+                                    E         -> error urk -- impossible+                                    Z _ _ _ _ -> P k l a r' -- R subtree BF:0-> 0, H:h->h  , parent BF:+1->+1+                                    _         -> Z k l a r' -- R subtree BF:0->+/-1, H:h->h+1, parent BF:+1-> 0++     -------- These 2 cases (NR and PL) may need rebalancing if they go to LEVEL 3 ---------++-- (insNR k l a r): Put in R subtree of (N k l a r), BF=-1 , (never returns P)+{-# INLINE insNR #-}+insNR :: Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+insNR _  _  _ _ _  E              = error urk            -- impossible if BF=-1+insNR k0 a0 k l a (N rk rl ra rr) = let r' = insN k0 a0 rk rl ra rr  -- R subtree BF<>0, H:h->h, parent BF:-1->-1+                                    in r' `seq` N k l a r'+insNR k0 a0 k l a (P rk rl ra rr) = let r' = insP k0 a0 rk rl ra rr  -- R subtree BF<>0, H:h->h, parent BF:-1->-1+                                    in r' `seq` N k l a r'+insNR k0 a0 k l a (Z rk rl ra rr) = case compareInt# k0 rk of  -- determine if RR or RL+                                    LT -> insNRL k0 a0 k l a rk rl ra  rr   -- RL (never returns P)+                                    EQ -> N k l a (Z rk rl a0 rr)+                                    GT -> insNRR k0 a0 k l a rk rl ra  rr   -- RR (never returns P)++-- (insPL k l a r): Put in L subtree of (P k l a r), BF=+1 , (never returns N)+{-# INLINE insPL #-}+insPL :: Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+insPL _  _  _  E              _ _ = error urk            -- impossible if BF=+1+insPL k0 a0 k (N lk ll la lr) a r = let l' = insN k0 a0 lk ll la lr  -- L subtree BF<>0, H:h->h, parent BF:+1->+1+                                    in l' `seq` P k l' a r+insPL k0 a0 k (P lk ll la lr) a r = let l' = insP k0 a0 lk ll la lr  -- L subtree BF<>0, H:h->h, parent BF:+1->+1+                                    in l' `seq` P k l' a r+insPL k0 a0 k (Z lk ll la lr) a r = case compareInt# k0 lk of        -- determine if LL or LR+                                    LT -> insPLL k0 a0 k lk ll la  lr  a r -- LL (never returns N)+                                    EQ -> P k (Z lk ll a0 lr) a r+                                    GT -> insPLR k0 a0 k lk ll la  lr  a r -- LR (never returns N)++----------------------------- LEVEL 3 ---------------------------------+--                        insNRR, insPLL                             --+--                        insNRL, insPLR                             --+-----------------------------------------------------------------------++-- (insNRR k l a rk rl ra rr): Put in RR subtree of (N k l a (Z rk rl ra rr)) , (never returns P)+{-# INLINE insNRR #-}+insNRR :: Key -> a -> Key -> IntMap a -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+insNRR k0 a0 k l a rk rl ra  E                  = Z rk (Z k l a rl) ra (Z k0 E a0 E)    -- l and rl must also be E, special CASE RR!!+insNRR k0 a0 k l a rk rl ra (N rrk rrl rra rrr) = let rr' = insN k0 a0 rrk rrl rra rrr  -- RR subtree BF<>0, H:h->h, so no change+                                                  in rr' `seq` N k l a (Z rk rl ra rr')+insNRR k0 a0 k l a rk rl ra (P rrk rrl rra rrr) = let rr' = insP k0 a0 rrk rrl rra rrr  -- RR subtree BF<>0, H:h->h, so no change+                                                  in rr' `seq` N k l a (Z rk rl ra rr')+insNRR k0 a0 k l a rk rl ra (Z rrk rrl rra rrr) = let rr' = insZ k0 a0 rrk rrl rra rrr  -- RR subtree BF= 0, so need to look for changes+                                                  in case rr' of+                                                  E         -> error urk    -- impossible+                                                  Z _ _ _ _ -> N k l a (Z rk rl ra rr') -- RR subtree BF: 0-> 0, H:h->h, so no change+                                                  _         -> Z rk (Z k l a rl) ra rr' -- RR subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE RR !!++-- (insPLL k lk ll la lr a r): Put in LL subtree of (P k (Z lk ll la lr) a r) , (never returns N)+{-# INLINE insPLL #-}+insPLL :: Key -> a -> Key -> Key -> IntMap a -> a -> IntMap a -> a -> IntMap a -> IntMap a+insPLL k0 a0 k lk  E                  la lr a r = Z lk (Z k0 E a0 E) la (Z k lr a r)    -- r and lr must also be E, special CASE LL!!+insPLL k0 a0 k lk (N llk lll lla llr) la lr a r = let ll' = insN k0 a0 llk lll lla llr  -- LL subtree BF<>0, H:h->h, so no change+                                                  in ll' `seq` P k (Z lk ll' la lr) a r+insPLL k0 a0 k lk (P llk lll lla llr) la lr a r = let ll' = insP k0 a0 llk lll lla llr  -- LL subtree BF<>0, H:h->h, so no change+                                                  in ll' `seq` P k (Z lk ll' la lr) a r+insPLL k0 a0 k lk (Z llk lll lla llr) la lr a r = let ll' = insZ k0 a0 llk lll lla llr  -- LL subtree BF= 0, so need to look for changes+                                                  in case ll' of+                                                  E         -> error urk    -- impossible+                                                  Z _ _ _ _ -> P k (Z lk ll' la lr) a r -- LL subtree BF: 0-> 0, H:h->h, so no change+                                                  _         -> Z lk ll' la (Z k lr a r) -- LL subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE LL !!++-- (insNRL k l a rk rl ra rr): Put in RL subtree of (N k l a (Z rk rl ra rr)) , (never returns P)+{-# INLINE insNRL #-}+insNRL :: Key -> a -> Key -> IntMap a -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a+insNRL k0 a0 k l a rk  E                  ra rr = Z k0 (Z k l a E) a0 (Z rk E ra rr)    -- l and rr must also be E, special CASE LR !!+insNRL k0 a0 k l a rk (N rlk rll rla rlr) ra rr = let rl' = insN k0 a0 rlk rll rla rlr  -- RL subtree BF<>0, H:h->h, so no change+                                                  in rl' `seq` N k l a (Z rk rl' ra rr)+insNRL k0 a0 k l a rk (P rlk rll rla rlr) ra rr = let rl' = insP k0 a0 rlk rll rla rlr  -- RL subtree BF<>0, H:h->h, so no change+                                                  in rl' `seq` N k l a (Z rk rl' ra rr)+insNRL k0 a0 k l a rk (Z rlk rll rla rlr) ra rr = let rl' = insZ k0 a0 rlk rll rla rlr  -- RL subtree BF= 0, so need to look for changes+                                                  in case rl' of+                                                  E                     -> error urk -- impossible+                                                  Z _    _    _    _    -> N k l a (Z rk rl' ra rr)                     -- RL subtree BF: 0-> 0, H:h->h, so no change+                                                  N rlk' rll' rla' rlr' -> Z rlk' (P k l a rll') rla' (Z rk rlr' ra rr) -- RL subtree BF: 0->-1, SO.. CASE RL(1) !!+                                                  P rlk' rll' rla' rlr' -> Z rlk' (Z k l a rll') rla' (N rk rlr' ra rr) -- RL subtree BF: 0->+1, SO.. CASE RL(2) !!++-- (insPLR k lk ll la lr a r): Put in LR subtree of (P k (Z lk ll la lr) a r) , (never returns N)+{-# INLINE insPLR #-}+insPLR :: Key -> a -> Key -> Key -> IntMap a -> a -> IntMap a -> a -> IntMap a -> IntMap a+insPLR k0 a0 k lk ll la  E                  a r = Z k0 (Z lk ll la E) a0 (Z k E a r)     -- r and ll must also be E, special CASE LR !!+insPLR k0 a0 k lk ll la (N lrk lrl lra lrr) a r = let lr' = insN k0 a0 lrk lrl lra lrr   -- LR subtree BF<>0, H:h->h, so no change+                                                  in lr' `seq` P k (Z lk ll la lr') a r+insPLR k0 a0 k lk ll la (P lrk lrl lra lrr) a r = let lr' = insP k0 a0 lrk lrl lra lrr   -- LR subtree BF<>0, H:h->h, so no change+                                                  in lr' `seq` P k (Z lk ll la lr') a r+insPLR k0 a0 k lk ll la (Z lrk lrl lra lrr) a r = let lr' = insZ k0 a0 lrk lrl lra lrr   -- LR subtree BF= 0, so need to look for changes+                                                  in case lr' of+                                                  E                     -> error urk -- impossible+                                                  Z _    _    _    _    -> P k (Z lk ll la lr') a r                     -- LR subtree BF: 0-> 0, H:h->h, so no change+                                                  N lrk' lrl' lra' lrr' -> Z lrk' (P lk ll la lrl') lra' (Z k lrr' a r) -- LR subtree BF: 0->-1, SO.. CASE LR(2) !!+                                                  P lrk' lrl' lra' lrr' -> Z lrk' (Z lk ll la lrl') lra' (N k lrr' a r) -- LR subtree BF: 0->+1, SO.. CASE LR(1) !!+-----------------------------------------------------------------------+-------------------------- ins/insH End Here --------------------------+-----------------------------------------------------------------------++-- | See 'Map' class method 'union'.+unionIntMap :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a+unionIntMap f t0_ t1_ = u0 t0_ t1_ where+ u0     E            t1               = t1+ u0 t0                   E            = t0+ u0 t0@(N _ l0 _ _ ) t1@(N _ l1 _ _ ) = uH (addHeight 2# l0) t0 (addHeight 2# l1) t1+ u0 t0@(N _ l0 _ _ ) t1@(Z _ l1 _ _ ) = uH (addHeight 2# l0) t0 (addHeight 1# l1) t1+ u0 t0@(N _ l0 _ _ ) t1@(P _ _  _ r1) = uH (addHeight 2# l0) t0 (addHeight 2# r1) t1+ u0 t0@(Z _ l0 _ _ ) t1@(N _ l1 _ _ ) = uH (addHeight 1# l0) t0 (addHeight 2# l1) t1+ u0 t0@(Z _ l0 _ _ ) t1@(Z _ l1 _ _ ) = uH (addHeight 1# l0) t0 (addHeight 1# l1) t1+ u0 t0@(Z _ l0 _ _ ) t1@(P _ _  _ r1) = uH (addHeight 1# l0) t0 (addHeight 2# r1) t1+ u0 t0@(P _ _  _ r0) t1@(N _ l1 _ _ ) = uH (addHeight 2# r0) t0 (addHeight 2# l1) t1+ u0 t0@(P _ _  _ r0) t1@(Z _ l1 _ _ ) = uH (addHeight 2# r0) t0 (addHeight 1# l1) t1+ u0 t0@(P _ _  _ r0) t1@(P _ _  _ r1) = uH (addHeight 2# r0) t0 (addHeight 2# r1) t1+ -- uH :: Int# -> IntMap a ->   -- 1st IntMap with height+ --       Int# -> IntMap a ->   -- 2nd IntMap with height+ --       IntMap a+ uH h0 t0 h1 t1 = case u h0 t0 h1 t1 of (# t,_ #) -> t+ -- u :: Int# -> IntMap a  ->    -- 1st IntMap with height+ --      Int# -> IntMap a  ->    -- 2nd IntMap with height+ --      (# Int#,IntMap a #)     -- Output IntMap with height+ ------------------------------------------------+ u 0# _    h1              t1              = (# t1,h1 #)+ u h0   t0   0#            _               = (# t0,h0 #)+ ------------------------------------------------+ u 1# (Z k0 _  a0 _ ) 1# t1@(Z k1 _  a1 _ ) = case compareInt# k0 k1 of+                                                  LT -> (# N k0  E  a0        t1, 2# #)+                                                  EQ -> (# Z k0  E  (f a0 a1) E , 1# #)+                                                  GT -> (# P k0  t1 a0        E , 2# #)+ u 1# (Z k0 _  a0 _ ) ht1  t1              = pushAB k0 a0 ht1 t1+ u ht0  t0              1# (Z k1 _  a1 _ ) = pushBA k1 a1 ht0 t0+ ------------------------------------------------+ u 2# (N k0 _ a0 (Z k0_ _ a0_ _)) ht1 t1 = pushAB2 k0 a0 k0_ a0_ ht1 t1+ u 2# (P k0_ (Z k0 _ a0 _) a0_ _) ht1 t1 = pushAB2 k0 a0 k0_ a0_ ht1 t1+ u ht0 t0 2# (N k1 _ a1 (Z k1_ _ a1_ _)) = pushBA2 k1 a1 k1_ a1_ ht0 t0+ u ht0 t0 2# (P k1_ (Z k1 _ a1 _) a1_ _) = pushBA2 k1 a1 k1_ a1_ ht0 t0+ u 2# (Z k0_ (Z k0 _ a0 _) a0_ (Z k0__ _ a0__ _)) ht1 t1 = pushAB3 k0 a0 k0_ a0_ k0__ a0__ ht1 t1+ u ht0 t0 2# (Z k1_ (Z k1 _ a1 _) a1_ (Z k1__ _ a1__ _)) = pushBA3 k1 a1 k1_ a1_ k1__ a1__ ht0 t0+ ------------------------------------------------+ u h0 (N k0 l0 a0 r0) h1 (N k1 l1 a1 r1) = u_ k0 ((h0)-#2#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#2#) l1 a1 ((h1)-#1#) r1+ u h0 (N k0 l0 a0 r0) h1 (Z k1 l1 a1 r1) = u_ k0 ((h0)-#2#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#1#) r1+ u h0 (N k0 l0 a0 r0) h1 (P k1 l1 a1 r1) = u_ k0 ((h0)-#2#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#2#) r1+ u h0 (Z k0 l0 a0 r0) h1 (N k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#2#) l1 a1 ((h1)-#1#) r1+ u h0 (Z k0 l0 a0 r0) h1 (Z k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#1#) r1+ u h0 (Z k0 l0 a0 r0) h1 (P k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#2#) r1+ u h0 (P k0 l0 a0 r0) h1 (N k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#2#) r0 k1 ((h1)-#2#) l1 a1 ((h1)-#1#) r1+ u h0 (P k0 l0 a0 r0) h1 (Z k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#2#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#1#) r1+ u h0 (P k0 l0 a0 r0) h1 (P k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#2#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#2#) r1+ u _  _               _  _               = error (mErr ++ "unionIntMap: Bad IntMap.")+ u_ k0 hl0 l0 a0 hr0 r0 k1 hl1 l1 a1 hr1 r1 =+  case compareInt# k0 k1 of+  -- k0 < k1, so (l0 < k0 < k1) & (k0 < k1 < r1)+  LT ->                                 case forkR hr0 r0 k1 a1 of+        (# hrl0,rl0,a1_,hrr0,rr0 #)  -> case forkL k0 a0 hl1 l1 of -- (k0  < rl0 < k1) & (k0 < k1  < rr0)+         (# hll1,ll1,a0_,hlr1,lr1 #) ->                            -- (ll1 < k0  < k1) & (k0 < lr1 < k1)+          -- (l0 + ll1) < k0 < (rl0 + lr1) < k1 < (rr0 + r1)+                                        case u  hl0  l0 hll1 ll1 of+          (# l,hl #)                 -> case u hrl0 rl0 hlr1 lr1 of+           (# m,hm #)                -> case u hrr0 rr0  hr1  r1 of+            (# r,hr #)               -> case spliceH k1 m hm a1_ r hr of+             (# t,ht #)              -> spliceH k0 l hl a0_ t ht+  -- k0 = k1+  EQ ->                case u hl0 l0 hl1 l1 of+        (# l,hl #)  -> case u hr0 r0 hr1 r1 of+         (# r,hr #) -> spliceH k0 l hl (f a0 a1) r hr+  -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)+  GT ->                                 case forkL k0 a0 hr1 r1 of+        (# hrl1,rl1,a0_,hrr1,rr1 #)  -> case forkR hl0 l0 k1 a1 of -- (k1  < rl1 < k0) & (k1 < k0  < rr1)+         (# hll0,ll0,a1_,hlr0,lr0 #) ->                            -- (ll0 < k1  < k0) & (k1 < lr0 < k0)+          -- (ll0 + l1) < e1 < (lr0  + rl1) < e0 < (r0 + rr1)+                                        case u hll0 ll0  hl1  l1 of+          (# l,hl #)                 -> case u hlr0 lr0 hrl1 rl1 of+           (# m,hm #)                -> case u  hr0  r0 hrr1 rr1 of+            (# r,hr #)               -> case spliceH k1 l hl a1_ m hm of+             (# t,ht #)              -> spliceH k0 t ht a0_ r hr+ -- We need 2 different versions of fork (L & R) to ensure that values are combined in+ -- the right order (f a0 a1)+ ------------------------------------------------+ -- forkL :: Key -> a -> Int# -> IntMap a -> (# Int#,IntMap a,a,Int#,IntMap a #)+ forkL k0 a0 ht1 t1 = forkL_ ht1 t1 where+  forkL_ h  E          = (# h,E,a0,h,E #)+  forkL_ h (N k l a r) = forkL__ k ((h)-#2#) l a ((h)-#1#) r+  forkL_ h (Z k l a r) = forkL__ k ((h)-#1#) l a ((h)-#1#) r+  forkL_ h (P k l a r) = forkL__ k ((h)-#1#) l a ((h)-#2#) r+  forkL__ k hl l a hr r = case compareInt# k0 k of+                          LT ->                            case forkL_ hl l of+                                (# hl0,l0,a0_,hl1,l1 #) -> case spliceH k l1 hl1 a r hr of+                                 (# l1_,hl1_ #)         -> (# hl0,l0,a0_,hl1_,l1_ #)+                          EQ ->                            (# hl,l,f a0 a,hr,r #)+                          GT ->                            case forkL_ hr r of+                                (# hl0,l0,a0_,hl1,l1 #) -> case spliceH k l hl a l0 hl0 of+                                 (# l0_,hl0_ #)         -> (# hl0_,l0_,a0_,hl1,l1 #)+ ------------------------------------------------+ -- forkL :: Int# -> IntMap a -> Key -> a -> (# Int#,IntMap a,a,Int#,IntMap a #)+ forkR ht0 t0 k1 a1 = forkR_ ht0 t0 where+  forkR_ h  E          = (# h,E,a1,h,E #)+  forkR_ h (N k l a r) = forkR__ k ((h)-#2#) l a ((h)-#1#) r+  forkR_ h (Z k l a r) = forkR__ k ((h)-#1#) l a ((h)-#1#) r+  forkR_ h (P k l a r) = forkR__ k ((h)-#1#) l a ((h)-#2#) r+  forkR__ k hl l a hr r = case compareInt# k k1 of+                          LT ->                            case forkR_ hr r of+                                (# hl0,l0,a1_,hl1,l1 #) -> case spliceH k l hl a l0 hl0 of+                                 (# l0_,hl0_ #)         -> (# hl0_,l0_,a1_,hl1,l1 #)+                          EQ ->                            (# hl,l,f a a1,hr,r #)+                          GT ->                            case forkR_ hl l of+                                (# hl0,l0,a1_,hl1,l1 #) -> case spliceH k l1 hl1 a r hr of+                                 (# l1_,hl1_ #)         -> (# hl0,l0,a1_,hl1_,l1_ #)+ ------------------------------------------------+ -- pushAB :: Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #)+ pushAB k0 a0 ht1 t1 = pushH (\a1 -> f a0 a1) k0 a0 ht1 t1+ ------------------------------------------------+ -- pushBA :: Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #)+ pushBA k1 a1 ht0 t0 = pushH (\a0 -> f a0 a1) k1 a1 ht0 t0+ ------------------------------------------------+ -- pushAB2 :: Key -> a -> Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #)+ pushAB2 k0 a0 k0_ a0_ ht1 t1 = case pushAB k0_ a0_ ht1 t1 of+                                (# t,h #) -> pushAB k0 a0 h t+ ------------------------------------------------+ -- pushBA2 :: Key -> a -> Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #)+ pushBA2 k1 a1 k1_ a1_ ht0 t0 = case pushBA k1_ a1_ ht0 t0 of+                                (# t,h #) -> pushBA k1 a1 h t+ ------------------------------------------------+ -- pushAB3 :: Key -> a -> Key -> a -> Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #)+ pushAB3 k0 a0 k0_ a0_ k0__ a0__ ht1 t1 = case pushAB k0__ a0__ ht1 t1 of+                                          (# t,h #) -> pushAB2 k0 a0 k0_ a0_ h t+ ------------------------------------------------+ -- pushBA3 :: Key -> a -> Key -> a -> Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #)+ pushBA3 k1 a1 k1_ a1_ k1__ a1__ ht0 t0 = case pushBA k1__ a1__ ht0 t0 of+                                          (# t,h #) -> pushBA2 k1 a1 k1_ a1_ h t+-----------------------------------------------------------------------+----------------------- unionIntMap Ends Here --------------------------+-----------------------------------------------------------------------++-- | See 'Map' class method 'union''.+unionIntMap' :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a+unionIntMap' f t0_ t1_ = u0 t0_ t1_ where+ u0     E            t1               = t1+ u0 t0                   E            = t0+ u0 t0@(N _ l0 _ _ ) t1@(N _ l1 _ _ ) = uH (addHeight 2# l0) t0 (addHeight 2# l1) t1+ u0 t0@(N _ l0 _ _ ) t1@(Z _ l1 _ _ ) = uH (addHeight 2# l0) t0 (addHeight 1# l1) t1+ u0 t0@(N _ l0 _ _ ) t1@(P _ _  _ r1) = uH (addHeight 2# l0) t0 (addHeight 2# r1) t1+ u0 t0@(Z _ l0 _ _ ) t1@(N _ l1 _ _ ) = uH (addHeight 1# l0) t0 (addHeight 2# l1) t1+ u0 t0@(Z _ l0 _ _ ) t1@(Z _ l1 _ _ ) = uH (addHeight 1# l0) t0 (addHeight 1# l1) t1+ u0 t0@(Z _ l0 _ _ ) t1@(P _ _  _ r1) = uH (addHeight 1# l0) t0 (addHeight 2# r1) t1+ u0 t0@(P _ _  _ r0) t1@(N _ l1 _ _ ) = uH (addHeight 2# r0) t0 (addHeight 2# l1) t1+ u0 t0@(P _ _  _ r0) t1@(Z _ l1 _ _ ) = uH (addHeight 2# r0) t0 (addHeight 1# l1) t1+ u0 t0@(P _ _  _ r0) t1@(P _ _  _ r1) = uH (addHeight 2# r0) t0 (addHeight 2# r1) t1+ -- uH :: Int# -> IntMap a ->   -- 1st IntMap with height+ --       Int# -> IntMap a ->   -- 2nd IntMap with height+ --       IntMap a+ uH h0 t0 h1 t1 = case u h0 t0 h1 t1 of (# t,_ #) -> t+ -- u :: Int# -> IntMap a  ->    -- 1st IntMap with height+ --      Int# -> IntMap a  ->    -- 2nd IntMap with height+ --      (# Int#,IntMap a #)     -- Output IntMap with height+ ------------------------------------------------+ u 0# _    h1              t1              = (# t1,h1 #)+ u h0   t0   0#            _               = (# t0,h0 #)+ ------------------------------------------------+ u 1# (Z k0 _  a0 _ ) 1# t1@(Z k1 _  a1 _ ) = case compareInt# k0 k1 of+                                                  LT -> (# N k0 E  a0 t1, 2# #)+                                                  EQ -> let a_ = f a0 a1 in a_ `seq`+                                                        (# Z k0 E a_ E , 1# #)+                                                  GT -> (# P k0 t1 a0 E , 2# #)+ u 1# (Z k0 _  a0 _ ) ht1  t1              = pushAB k0 a0 ht1 t1+ u ht0  t0              1# (Z k1 _  a1 _ ) = pushBA k1 a1 ht0 t0+ ------------------------------------------------+ u 2# (N k0 _ a0 (Z k0_ _ a0_ _)) ht1 t1 = pushAB2 k0 a0 k0_ a0_ ht1 t1+ u 2# (P k0_ (Z k0 _ a0 _) a0_ _) ht1 t1 = pushAB2 k0 a0 k0_ a0_ ht1 t1+ u ht0 t0 2# (N k1 _ a1 (Z k1_ _ a1_ _)) = pushBA2 k1 a1 k1_ a1_ ht0 t0+ u ht0 t0 2# (P k1_ (Z k1 _ a1 _) a1_ _) = pushBA2 k1 a1 k1_ a1_ ht0 t0+ u 2# (Z k0_ (Z k0 _ a0 _) a0_ (Z k0__ _ a0__ _)) ht1 t1 = pushAB3 k0 a0 k0_ a0_ k0__ a0__ ht1 t1+ u ht0 t0 2# (Z k1_ (Z k1 _ a1 _) a1_ (Z k1__ _ a1__ _)) = pushBA3 k1 a1 k1_ a1_ k1__ a1__ ht0 t0+ ------------------------------------------------+ u h0 (N k0 l0 a0 r0) h1 (N k1 l1 a1 r1) = u_ k0 ((h0)-#2#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#2#) l1 a1 ((h1)-#1#) r1+ u h0 (N k0 l0 a0 r0) h1 (Z k1 l1 a1 r1) = u_ k0 ((h0)-#2#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#1#) r1+ u h0 (N k0 l0 a0 r0) h1 (P k1 l1 a1 r1) = u_ k0 ((h0)-#2#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#2#) r1+ u h0 (Z k0 l0 a0 r0) h1 (N k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#2#) l1 a1 ((h1)-#1#) r1+ u h0 (Z k0 l0 a0 r0) h1 (Z k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#1#) r1+ u h0 (Z k0 l0 a0 r0) h1 (P k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#2#) r1+ u h0 (P k0 l0 a0 r0) h1 (N k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#2#) r0 k1 ((h1)-#2#) l1 a1 ((h1)-#1#) r1+ u h0 (P k0 l0 a0 r0) h1 (Z k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#2#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#1#) r1+ u h0 (P k0 l0 a0 r0) h1 (P k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#2#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#2#) r1+ u _  _               _  _               = error (mErr ++ "unionIntMap: Bad IntMap.")+ u_ k0 hl0 l0 a0 hr0 r0 k1 hl1 l1 a1 hr1 r1 =+  case compareInt# k0 k1 of+  -- k0 < k1, so (l0 < k0 < k1) & (k0 < k1 < r1)+  LT ->                                 case forkR hr0 r0 k1 a1 of+        (# hrl0,rl0,a1_,hrr0,rr0 #)  -> case forkL k0 a0 hl1 l1 of -- (k0  < rl0 < k1) & (k0 < k1  < rr0)+         (# hll1,ll1,a0_,hlr1,lr1 #) ->                            -- (ll1 < k0  < k1) & (k0 < lr1 < k1)+          -- (l0 + ll1) < k0 < (rl0 + lr1) < k1 < (rr0 + r1)+                                        case u  hl0  l0 hll1 ll1 of+          (# l,hl #)                 -> case u hrl0 rl0 hlr1 lr1 of+           (# m,hm #)                -> case u hrr0 rr0  hr1  r1 of+            (# r,hr #)               -> case spliceH k1 m hm a1_ r hr of+             (# t,ht #)              -> spliceH k0 l hl a0_ t ht+  -- k0 = k1+  EQ ->                case u hl0 l0 hl1 l1 of+        (# l,hl #)  -> case u hr0 r0 hr1 r1 of+         (# r,hr #) -> let a_ = f a0 a1 in a_ `seq` spliceH k0 l hl a_ r hr+  -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)+  GT ->                                 case forkL k0 a0 hr1 r1 of+        (# hrl1,rl1,a0_,hrr1,rr1 #)  -> case forkR hl0 l0 k1 a1 of -- (k1  < rl1 < k0) & (k1 < k0  < rr1)+         (# hll0,ll0,a1_,hlr0,lr0 #) ->                            -- (ll0 < k1  < k0) & (k1 < lr0 < k0)+          -- (ll0 + l1) < e1 < (lr0  + rl1) < e0 < (r0 + rr1)+                                        case u hll0 ll0  hl1  l1 of+          (# l,hl #)                 -> case u hlr0 lr0 hrl1 rl1 of+           (# m,hm #)                -> case u  hr0  r0 hrr1 rr1 of+            (# r,hr #)               -> case spliceH k1 l hl a1_ m hm of+             (# t,ht #)              -> spliceH k0 t ht a0_ r hr+ -- We need 2 different versions of fork (L & R) to ensure that values are combined in+ -- the right order (f a0 a1)+ ------------------------------------------------+ -- forkL :: Key -> a -> Int# -> IntMap a -> (# Int#,IntMap a,a,Int#,IntMap a #)+ forkL k0 a0 ht1 t1 = forkL_ ht1 t1 where+  forkL_ h  E          = (# h,E,a0,h,E #)+  forkL_ h (N k l a r) = forkL__ k ((h)-#2#) l a ((h)-#1#) r+  forkL_ h (Z k l a r) = forkL__ k ((h)-#1#) l a ((h)-#1#) r+  forkL_ h (P k l a r) = forkL__ k ((h)-#1#) l a ((h)-#2#) r+  forkL__ k hl l a hr r = case compareInt# k0 k of+                          LT ->                            case forkL_ hl l of+                                (# hl0,l0,a0_,hl1,l1 #) -> case spliceH k l1 hl1 a r hr of+                                 (# l1_,hl1_ #)         -> (# hl0,l0,a0_,hl1_,l1_ #)+                          EQ ->                            let a_ = f a0 a in a_ `seq`+                                                           (# hl,l,a_,hr,r #)+                          GT ->                            case forkL_ hr r of+                                (# hl0,l0,a0_,hl1,l1 #) -> case spliceH k l hl a l0 hl0 of+                                 (# l0_,hl0_ #)         -> (# hl0_,l0_,a0_,hl1,l1 #)+ ------------------------------------------------+ -- forkL :: Int# -> IntMap a -> Key -> a -> (# Int#,IntMap a,a,Int#,IntMap a #)+ forkR ht0 t0 k1 a1 = forkR_ ht0 t0 where+  forkR_ h  E          = (# h,E,a1,h,E #)+  forkR_ h (N k l a r) = forkR__ k ((h)-#2#) l a ((h)-#1#) r+  forkR_ h (Z k l a r) = forkR__ k ((h)-#1#) l a ((h)-#1#) r+  forkR_ h (P k l a r) = forkR__ k ((h)-#1#) l a ((h)-#2#) r+  forkR__ k hl l a hr r = case compareInt# k k1 of+                          LT ->                            case forkR_ hr r of+                                (# hl0,l0,a1_,hl1,l1 #) -> case spliceH k l hl a l0 hl0 of+                                 (# l0_,hl0_ #)         -> (# hl0_,l0_,a1_,hl1,l1 #)+                          EQ ->                            let a_ = f a a1 in a_ `seq`+                                                           (# hl,l,a_,hr,r #)+                          GT ->                            case forkR_ hl l of+                                (# hl0,l0,a1_,hl1,l1 #) -> case spliceH k l1 hl1 a r hr of+                                 (# l1_,hl1_ #)         -> (# hl0,l0,a1_,hl1_,l1_ #)+ ------------------------------------------------+ -- pushAB :: Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #)+ pushAB k0 a0 ht1 t1 = pushH' (\a1 -> f a0 a1) k0 a0 ht1 t1+ ------------------------------------------------+ -- pushBA :: Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #)+ pushBA k1 a1 ht0 t0 = pushH' (\a0 -> f a0 a1) k1 a1 ht0 t0+ ------------------------------------------------+ -- pushAB2 :: Key -> a -> Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #)+ pushAB2 k0 a0 k0_ a0_ ht1 t1 = case pushAB k0_ a0_ ht1 t1 of+                                (# t,h #) -> pushAB k0 a0 h t+ ------------------------------------------------+ -- pushBA2 :: Key -> a -> Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #)+ pushBA2 k1 a1 k1_ a1_ ht0 t0 = case pushBA k1_ a1_ ht0 t0 of+                                (# t,h #) -> pushBA k1 a1 h t+ ------------------------------------------------+ -- pushAB3 :: Key -> a -> Key -> a -> Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #)+ pushAB3 k0 a0 k0_ a0_ k0__ a0__ ht1 t1 = case pushAB k0__ a0__ ht1 t1 of+                                          (# t,h #) -> pushAB2 k0 a0 k0_ a0_ h t+ ------------------------------------------------+ -- pushBA3 :: Key -> a -> Key -> a -> Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #)+ pushBA3 k1 a1 k1_ a1_ k1__ a1__ ht0 t0 = case pushBA k1__ a1__ ht0 t0 of+                                          (# t,h #) -> pushBA2 k1 a1 k1_ a1_ h t+-----------------------------------------------------------------------+----------------------- unionIntMap' Ends Here --------------------------+-----------------------------------------------------------------------++-- | See 'Map' class method 'unionMaybe'.+unionMaybeIntMap :: (a -> a -> Maybe a) -> IntMap a -> IntMap a -> IntMap a+unionMaybeIntMap f t0_ t1_ = u0 t0_ t1_ where+ u0     E            t1               = t1+ u0 t0                   E            = t0+ u0 t0@(N _ l0 _ _ ) t1@(N _ l1 _ _ ) = uH (addHeight 2# l0) t0 (addHeight 2# l1) t1+ u0 t0@(N _ l0 _ _ ) t1@(Z _ l1 _ _ ) = uH (addHeight 2# l0) t0 (addHeight 1# l1) t1+ u0 t0@(N _ l0 _ _ ) t1@(P _ _  _ r1) = uH (addHeight 2# l0) t0 (addHeight 2# r1) t1+ u0 t0@(Z _ l0 _ _ ) t1@(N _ l1 _ _ ) = uH (addHeight 1# l0) t0 (addHeight 2# l1) t1+ u0 t0@(Z _ l0 _ _ ) t1@(Z _ l1 _ _ ) = uH (addHeight 1# l0) t0 (addHeight 1# l1) t1+ u0 t0@(Z _ l0 _ _ ) t1@(P _ _  _ r1) = uH (addHeight 1# l0) t0 (addHeight 2# r1) t1+ u0 t0@(P _ _  _ r0) t1@(N _ l1 _ _ ) = uH (addHeight 2# r0) t0 (addHeight 2# l1) t1+ u0 t0@(P _ _  _ r0) t1@(Z _ l1 _ _ ) = uH (addHeight 2# r0) t0 (addHeight 1# l1) t1+ u0 t0@(P _ _  _ r0) t1@(P _ _  _ r1) = uH (addHeight 2# r0) t0 (addHeight 2# r1) t1+ -- uH :: Int# -> IntMap a ->   -- 1st IntMap with height+ --       Int# -> IntMap a ->   -- 2nd IntMap with height+ --       IntMap a+ uH h0 t0 h1 t1 = case u h0 t0 h1 t1 of (# t,_ #) -> t+ -- u :: Int# -> IntMap a  ->    -- 1st IntMap with height+ --      Int# -> IntMap a  ->    -- 2nd IntMap with height+ --      (# Int#,IntMap a #)     -- Output IntMap with height+ ------------------------------------------------+ u 0# _    h1              t1              = (# t1,h1 #)+ u h0   t0   0#            _               = (# t0,h0 #)+ ------------------------------------------------+ u 1# (Z k0 _  a0 _ ) 1# t1@(Z k1 _  a1 _ ) = case compareInt# k0 k1 of+                                                  LT -> (# N k0  E  a0 t1, 2# #)+                                                  EQ ->  case f a0 a1 of+                                                         Just a  -> (# Z k0 E a E , 1# #)+                                                         Nothing -> (# E          , 0# #)+                                                  GT -> (# P k0  t1 a0 E , 2# #)+ u 1# (Z k0 _  a0 _ ) ht1  t1              = pushAB k0 a0 ht1 t1+ u ht0  t0              1# (Z k1 _  a1 _ ) = pushBA k1 a1 ht0 t0+ ------------------------------------------------+ u 2# (N k0 _ a0 (Z k0_ _ a0_ _)) ht1 t1 = pushAB2 k0 a0 k0_ a0_ ht1 t1+ u 2# (P k0_ (Z k0 _ a0 _) a0_ _) ht1 t1 = pushAB2 k0 a0 k0_ a0_ ht1 t1+ u ht0 t0 2# (N k1 _ a1 (Z k1_ _ a1_ _)) = pushBA2 k1 a1 k1_ a1_ ht0 t0+ u ht0 t0 2# (P k1_ (Z k1 _ a1 _) a1_ _) = pushBA2 k1 a1 k1_ a1_ ht0 t0+ u 2# (Z k0_ (Z k0 _ a0 _) a0_ (Z k0__ _ a0__ _)) ht1 t1 = pushAB3 k0 a0 k0_ a0_ k0__ a0__ ht1 t1+ u ht0 t0 2# (Z k1_ (Z k1 _ a1 _) a1_ (Z k1__ _ a1__ _)) = pushBA3 k1 a1 k1_ a1_ k1__ a1__ ht0 t0+ ------------------------------------------------+ u h0 (N k0 l0 a0 r0) h1 (N k1 l1 a1 r1) = u_ k0 ((h0)-#2#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#2#) l1 a1 ((h1)-#1#) r1+ u h0 (N k0 l0 a0 r0) h1 (Z k1 l1 a1 r1) = u_ k0 ((h0)-#2#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#1#) r1+ u h0 (N k0 l0 a0 r0) h1 (P k1 l1 a1 r1) = u_ k0 ((h0)-#2#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#2#) r1+ u h0 (Z k0 l0 a0 r0) h1 (N k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#2#) l1 a1 ((h1)-#1#) r1+ u h0 (Z k0 l0 a0 r0) h1 (Z k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#1#) r1+ u h0 (Z k0 l0 a0 r0) h1 (P k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#2#) r1+ u h0 (P k0 l0 a0 r0) h1 (N k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#2#) r0 k1 ((h1)-#2#) l1 a1 ((h1)-#1#) r1+ u h0 (P k0 l0 a0 r0) h1 (Z k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#2#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#1#) r1+ u h0 (P k0 l0 a0 r0) h1 (P k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#2#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#2#) r1+ u _  _               _  _               = error (mErr ++ "unionMaybeIntMap: Bad IntMap.")+ u_ k0 hl0 l0 a0 hr0 r0 k1 hl1 l1 a1 hr1 r1 =+  case compareInt# k0 k1 of+  -- k0 < k1, so (l0 < k0 < k1) & (k0 < k1 < r1)+  LT ->                                  case forkR hr0 r0 k1 a1 of+        (# hrl0,rl0,mba1,hrr0,rr0 #)  -> case forkL k0 a0 hl1 l1 of -- (k0  < rl0 < k1) & (k0 < k1  < rr0)+         (# hll1,ll1,mba0,hlr1,lr1 #) ->                            -- (ll1 < k0  < k1) & (k0 < lr1 < k1)+          -- (l0 + ll1) < k0 < (rl0 + lr1) < k1 < (rr0 + r1)+                                         case u  hl0  l0 hll1 ll1 of+          (# l,hl #)                  -> case u hrl0 rl0 hlr1 lr1 of+           (# m,hm #)                 -> case u hrr0 rr0  hr1  r1 of+            (# r,hr #)                -> case (case mba1 of Just a  -> spliceH k1 m hm a r hr+                                                            Nothing -> joinH      m hm   r hr+                                              ) of+             (# t,ht #)               -> case mba0 of Just a  -> spliceH k0 l hl a t ht+                                                      Nothing -> joinH      l hl   t ht+  -- k0 = k1+  EQ ->                case u hl0 l0 hl1 l1 of+        (# l,hl #)  -> case u hr0 r0 hr1 r1 of+         (# r,hr #) -> case f a0 a1 of Just a  -> spliceH k0 l hl a r hr+                                       Nothing -> joinH      l hl   r hr+  -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)+  GT ->                                  case forkL k0 a0 hr1 r1 of+        (# hrl1,rl1,mba0,hrr1,rr1 #)  -> case forkR hl0 l0 k1 a1 of -- (k1  < rl1 < k0) & (k1 < k0  < rr1)+         (# hll0,ll0,mba1,hlr0,lr0 #) ->                            -- (ll0 < k1  < k0) & (k1 < lr0 < k0)+          -- (ll0 + l1) < e1 < (lr0  + rl1) < e0 < (r0 + rr1)+                                         case u hll0 ll0  hl1  l1 of+          (# l,hl #)                  -> case u hlr0 lr0 hrl1 rl1 of+           (# m,hm #)                 -> case u  hr0  r0 hrr1 rr1 of+            (# r,hr #)                -> case (case mba1 of Just a  -> spliceH k1 l hl a m hm+                                                            Nothing -> joinH      l hl   m hm+                                              ) of+             (# t,ht #)               -> case mba0 of Just a  -> spliceH k0 t ht a r hr+                                                      Nothing -> joinH      t ht   r hr+ -- We need 2 different versions of fork (L & R) to ensure that values are combined in+ -- the right order (f a0 a1)+ ------------------------------------------------+ -- forkL :: Key -> a -> Int# -> IntMap a -> (# Int#,IntMap a,Maybe a,Int#,IntMap a #)+ forkL k0 a0 ht1 t1 = forkL_ ht1 t1 where+  forkL_ h  E          = (# h,E,Just a0,h,E #)+  forkL_ h (N k l a r) = forkL__ k ((h)-#2#) l a ((h)-#1#) r+  forkL_ h (Z k l a r) = forkL__ k ((h)-#1#) l a ((h)-#1#) r+  forkL_ h (P k l a r) = forkL__ k ((h)-#1#) l a ((h)-#2#) r+  forkL__ k hl l a hr r = case compareInt# k0 k of+                          LT ->                            case forkL_ hl l of+                                (# hl0,l0,a0_,hl1,l1 #) -> case spliceH k l1 hl1 a r hr of+                                 (# l1_,hl1_ #)         -> (# hl0,l0,a0_,hl1_,l1_ #)+                          EQ -> let mba = f a0 a in mba `seq` (# hl,l,mba,hr,r #)+                          GT ->                            case forkL_ hr r of+                                (# hl0,l0,a0_,hl1,l1 #) -> case spliceH k l hl a l0 hl0 of+                                 (# l0_,hl0_ #)         -> (# hl0_,l0_,a0_,hl1,l1 #)+ ------------------------------------------------+ -- forkL :: Int# -> IntMap a -> Key -> a -> (# Int#,IntMap a,Maybe a,Int#,IntMap a #)+ forkR ht0 t0 k1 a1 = forkR_ ht0 t0 where+  forkR_ h  E          = (# h,E,Just a1,h,E #)+  forkR_ h (N k l a r) = forkR__ k ((h)-#2#) l a ((h)-#1#) r+  forkR_ h (Z k l a r) = forkR__ k ((h)-#1#) l a ((h)-#1#) r+  forkR_ h (P k l a r) = forkR__ k ((h)-#1#) l a ((h)-#2#) r+  forkR__ k hl l a hr r = case compareInt# k k1 of+                          LT ->                            case forkR_ hr r of+                                (# hl0,l0,a1_,hl1,l1 #) -> case spliceH k l hl a l0 hl0 of+                                 (# l0_,hl0_ #)         -> (# hl0_,l0_,a1_,hl1,l1 #)+                          EQ -> let mba = f a a1 in mba `seq` (# hl,l,mba,hr,r #)+                          GT ->                            case forkR_ hl l of+                                (# hl0,l0,a1_,hl1,l1 #) -> case spliceH k l1 hl1 a r hr of+                                 (# l1_,hl1_ #)         -> (# hl0,l0,a1_,hl1_,l1_ #)+ ------------------------------------------------+ -- pushAB :: Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #)+ pushAB k0 a0 ht1 t1 = pushMaybeH (\a1 -> f a0 a1) k0 a0 ht1 t1+ ------------------------------------------------+ -- pushBA :: Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #)+ pushBA k1 a1 ht0 t0 = pushMaybeH (\a0 -> f a0 a1) k1 a1 ht0 t0+ ------------------------------------------------+ -- pushAB2 :: Key -> a -> Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #)+ pushAB2 k0 a0 k0_ a0_ ht1 t1 = case pushAB k0_ a0_ ht1 t1 of+                                (# t,h #) -> pushAB k0 a0 h t+ ------------------------------------------------+ -- pushBA2 :: Key -> a -> Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #)+ pushBA2 k1 a1 k1_ a1_ ht0 t0 = case pushBA k1_ a1_ ht0 t0 of+                                (# t,h #) -> pushBA k1 a1 h t+ ------------------------------------------------+ -- pushAB3 :: Key -> a -> Key -> a -> Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #)+ pushAB3 k0 a0 k0_ a0_ k0__ a0__ ht1 t1 = case pushAB k0__ a0__ ht1 t1 of+                                          (# t,h #) -> pushAB2 k0 a0 k0_ a0_ h t+ ------------------------------------------------+ -- pushBA3 :: Key -> a -> Key -> a -> Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #)+ pushBA3 k1 a1 k1_ a1_ k1__ a1__ ht0 t0 = case pushBA k1__ a1__ ht0 t0 of+                                          (# t,h #) -> pushBA2 k1 a1 k1_ a1_ h t+-----------------------------------------------------------------------+-------------------- unionMaybeIntMap Ends Here ------------------------+-----------------------------------------------------------------------++-- Utility used by unionMaybeIntMap+pushMaybeH :: (a -> Maybe a) -> Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #)+pushMaybeH f k0 a0 ht1 t1 = case lookupIntMap k0 t1 of+                            Nothing -> insH k0 a0 ht1 t1+                            Just a  -> case f a of+                                       Nothing -> delH k0 ht1 t1+                                       Just a_ -> let t_ = assertWriteIntMap k0 a_ t1 in t_ `seq`+                                                  (# t_,ht1 #) -- No height change++-- -- Utility used by unionMaybeIntMap+-- pushMaybeH' :: (a -> Maybe a) -> Key -> a -> Int# -> IntMap a -> (# IntMap a, Int# #)+-- pushMaybeH' f k0 a0 ht1 t1 = case lookupIntMap k0 t1 of+--                             Nothing -> insH k0 a0 ht1 t1+--                             Just a  -> case f a of+--                                        Nothing -> delH k0 ht1 t1+--                                        Just a_ -> a_ `seq` let t_ = assertWriteIntMap k0 a_ t1 in t_ `seq`+--                                                   (# t_,ht1 #) -- No height change++-- | Specialised association list.+data IAList a = Empt+              | Cons {-# UNPACK #-} !Int# a (IAList a)+              deriving(Eq,Ord)++-- | Convert an 'IntMap' to an 'IAList' (in ascending order).+asIAList :: IntMap a -> IAList a+asIAList imp = f imp Empt where+ f  E          ial = ial+ f (N k l a r) ial = f' k l a r ial+ f (Z k l a r) ial = f' k l a r ial+ f (P k l a r) ial = f' k l a r ial+ f' k l a r ial = let ial'  = f r ial+                      ial'' = ial' `seq` Cons k a ial'+                  in ial'' `seq` f l ial''++-- | See 'Map' class method 'intersection'.+intersectionIntMap :: (a -> b -> c) -> IntMap a -> IntMap b -> IntMap c+intersectionIntMap f ta0 tb0 = i0 ta0 tb0 where+ -- i0 :: IntMap a -> IntMap b -> IntMap c+ i0     E            _                = E+ i0 _                    E            = E+ i0 ta@(N _ la _ _ ) tb@(N _ lb _ _ ) = iH (addHeight 2# la) ta (addHeight 2# lb) tb+ i0 ta@(N _ la _ _ ) tb@(Z _ lb _ _ ) = iH (addHeight 2# la) ta (addHeight 1# lb) tb+ i0 ta@(N _ la _ _ ) tb@(P _ _  _ rb) = iH (addHeight 2# la) ta (addHeight 2# rb) tb+ i0 ta@(Z _ la _ _ ) tb@(N _ lb _ _ ) = iH (addHeight 1# la) ta (addHeight 2# lb) tb+ i0 ta@(Z _ la _ _ ) tb@(Z _ lb _ _ ) = iH (addHeight 1# la) ta (addHeight 1# lb) tb+ i0 ta@(Z _ la _ _ ) tb@(P _ _  _ rb) = iH (addHeight 1# la) ta (addHeight 2# rb) tb+ i0 ta@(P _ _  _ ra) tb@(N _ lb _ _ ) = iH (addHeight 2# ra) ta (addHeight 2# lb) tb+ i0 ta@(P _ _  _ ra) tb@(Z _ lb _ _ ) = iH (addHeight 2# ra) ta (addHeight 1# lb) tb+ i0 ta@(P _ _  _ ra) tb@(P _ _  _ rb) = iH (addHeight 2# ra) ta (addHeight 2# rb) tb++ -- iH :: Int# -> IntMap a ->   -- 1st IntMap with height+ --       Int# -> IntMap b ->   -- 2nd IntMap with height+ --       IntMap c+ iH hta ta htb tb  = case i hta ta htb tb Empt 0# of+                     (# ial,n #)   -> case subst (rep (I# (n))) ial of+                      (# imp,rm #) -> case rm of+                                      Empt -> imp+                                      _    -> error (mErr ++ "intersectionIntMap: Bad IAList.")++ -- i :: Int# -> IntMap a  ->    -- 1st IntMap with height+ --      Int# -> IntMap b  ->    -- 2nd IntMap with height+ --      IAList c -> Int# ->    -- Input IAList with length+ --      (# IAList c, Int# #)   -- Output IAList with length+ ------------------------------------------------+ i 0# _ _    _ cs n = (# cs,n #)+ i _    _ 0# _ cs n = (# cs,n #)+ ------------------------------------------------+ i 1# (Z ka _  ea _ ) 1# (Z kb _  eb _ ) cs n = if ka ==# kb then (# Cons ka (f ea eb) cs, ((n)+#1#) #)+                                                                 else (# cs,n #)+ i 1# (Z ka _  ea _ ) _    tb              cs n = lookAB ka ea tb cs n+ i _    ta              1# (Z kb _  eb _ ) cs n = lookBA kb eb ta cs n+ ------------------------------------------------+ i 2# (N ka0 _               ea0 (Z ka1 _ ea1 _)) _ tb cs n = lookAB2 ka0 ea0 ka1 ea1 tb cs n+ i 2# (P ka1 (Z ka0 _ ea0 _) ea1 _              ) _ tb cs n = lookAB2 ka0 ea0 ka1 ea1 tb cs n+ i _ ta 2# (N kb0 _               eb0 (Z kb1 _ eb1 _)) cs n = lookBA2 kb0 eb0 kb1 eb1 ta cs n+ i _ ta 2# (P kb1 (Z kb0 _ eb0 _) eb1 _              ) cs n = lookBA2 kb0 eb0 kb1 eb1 ta cs n+ i 2# (Z ka1 (Z ka0 _ ea0 _) ea1 (Z ka2 _ ea2 _)) _ tb cs n = lookAB3 ka0 ea0 ka1 ea1 ka2 ea2 tb cs n+ i _ ta 2# (Z kb1 (Z kb0 _ eb0 _) eb1 (Z kb2 _ eb2 _)) cs n = lookBA3 kb0 eb0 kb1 eb1 kb2 eb2 ta cs n+ ------------------------------------------------+ -- Both tree heights are known to be >= 3 at this point, so sub-tree heights >= 1+ i ha (N ka la ea ra) hb (N kb lb eb rb) cs n = i_ ka ((ha)-#2#) la ea ((ha)-#1#) ra kb ((hb)-#2#) lb eb ((hb)-#1#) rb cs n+ i ha (N ka la ea ra) hb (Z kb lb eb rb) cs n = i_ ka ((ha)-#2#) la ea ((ha)-#1#) ra kb ((hb)-#1#) lb eb ((hb)-#1#) rb cs n+ i ha (N ka la ea ra) hb (P kb lb eb rb) cs n = i_ ka ((ha)-#2#) la ea ((ha)-#1#) ra kb ((hb)-#1#) lb eb ((hb)-#2#) rb cs n+ i ha (Z ka la ea ra) hb (N kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#1#) ra kb ((hb)-#2#) lb eb ((hb)-#1#) rb cs n+ i ha (Z ka la ea ra) hb (Z kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#1#) ra kb ((hb)-#1#) lb eb ((hb)-#1#) rb cs n+ i ha (Z ka la ea ra) hb (P kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#1#) ra kb ((hb)-#1#) lb eb ((hb)-#2#) rb cs n+ i ha (P ka la ea ra) hb (N kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#2#) ra kb ((hb)-#2#) lb eb ((hb)-#1#) rb cs n+ i ha (P ka la ea ra) hb (Z kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#2#) ra kb ((hb)-#1#) lb eb ((hb)-#1#) rb cs n+ i ha (P ka la ea ra) hb (P kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#2#) ra kb ((hb)-#1#) lb eb ((hb)-#2#) rb cs n+ i _  _               _  _               _  _ = error (mErr ++ "intersectionIntMap: Bad IntMap.")+ ------------------------------------------------+ i_ ka hla la ea hra ra kb hlb lb eb hrb rb cs n = case compareInt# ka kb of+  -- ka < kb, so (la < ka < kb) & (ka < kb < rb)+  LT                            -> case fork kb hra ra of+   (# hrla,rla,mba,hrra,rra #)  -> case fork ka hlb lb of         -- (ka  < rla < kb) & (ka < kb  < rra)+    (# hllb,llb,mbb,hlrb,lrb #) -> case i hrra rra hrb rb cs n of -- (llb < ka  < kb) & (ka < lrb < kb)+     -- (la + llb) < ka < (rla + lrb) < kb < (rra + rb)+     (# cs_,n_ #)               -> case (case mbb of+                                         Nothing -> i hrla rla hlrb lrb cs_                    n_+                                         Just b  -> i hrla rla hlrb lrb (Cons ka (f ea b) cs_) ((n_)+#1#)+                                        ) of+      (# cs__,n__ #)            -> case mba of+                                   Nothing -> i hla la hllb llb cs__                    n__+                                   Just a  -> i hla la hllb llb (Cons kb (f a eb) cs__) ((n__)+#1#)+  -- ka = kb+  EQ                            -> case i hra ra hrb rb cs n of+   (# cs_,n_ #)                 -> i hla la hlb lb (Cons ka (f ea eb) cs_) ((n_)+#1#)+  -- kb < ka, so (lb < kb < ka) & (kb < ka < ra)+  GT                            -> case fork ka hrb rb of+   (# hrlb,rlb,mbb,hrrb,rrb #)  -> case fork kb hla la of         -- (kb  < rlb < ka) & (kb < ka  < rrb)+    (# hlla,lla,mba,hlra,lra #) -> case i hra ra hrrb rrb cs n of -- (lla < kb  < ka) & (kb < lra < ka)+     -- (lla + lb) < kb < (lra + rlb) < ka < (ra + rrb)+     (# cs_,n_ #)               -> case (case mba of+                                         Nothing -> i hlra lra hrlb rlb cs_                    n_+                                         Just a  -> i hlra lra hrlb rlb (Cons kb (f a eb) cs_) ((n_)+#1#)+                                        ) of+      (# cs__,n__ #)           -> case mbb of+                                  Nothing -> i hlla lla hlb lb cs__                    n__+                                  Just b  -> i hlla lla hlb lb (Cons ka (f ea b) cs__) ((n__)+#1#)+ ------------------------------------------------+ -- fork :: Key -> Int# -> IntMap x -> (# Int#,IntMap x,Maybe x,Int#,IntMap x #)+ -- Tree height (ht) is known to be >= 1, can we exploit this ??+ fork k0 ht t = fork_ ht t where+  fork_ h  E          = (# h,E,Nothing,h,E #)+  fork_ h (N k l x r) = fork__ k ((h)-#2#) l x ((h)-#1#) r+  fork_ h (Z k l x r) = fork__ k ((h)-#1#) l x ((h)-#1#) r+  fork_ h (P k l x r) = fork__ k ((h)-#1#) l x ((h)-#2#) r+  fork__ k hl l x hr r = case compareInt# k0 k of+                         LT ->                            case fork_ hl l of+                               (# hl0,l0,mbx,hl1,l1 #) -> case spliceH k l1 hl1 x r hr of+                                (# l1_,hl1_ #)         -> (# hl0,l0,mbx,hl1_,l1_ #)+                         EQ -> (# hl,l,Just x,hr,r #)+                         GT ->                            case fork_ hr r of+                               (# hl0,l0,mbx,hl1,l1 #) -> case spliceH k l hl x l0 hl0 of+                                (# l0_,hl0_ #)         -> (# hl0_,l0_,mbx,hl1,l1 #)+ ------------------------------------------------+ -- lookAB :: Key -> a -> IntMap b -> IAList c -> Int# -> (# IAList c,Int# #)+ lookAB ka ea tb cs n = rd tb where+  rd  E          = (# cs,n #)+  rd (N k l b r) = rd_ k l b r+  rd (Z k l b r) = rd_ k l b r+  rd (P k l b r) = rd_ k l b r+  rd_   k l b r  = case compareInt# ka k of+                   LT -> rd l+                   EQ -> (# Cons ka (f ea b) cs, ((n)+#1#) #)+                   GT -> rd r+ ------------------------------------------------+ -- lookBA :: Key -> b -> IntMap a -> IAList c -> Int# -> (# IAList c,Int# #)+ lookBA kb eb ta cs n = rd ta where+  rd  E          = (# cs,n #)+  rd (N k l a r) = rd_ k l a r+  rd (Z k l a r) = rd_ k l a r+  rd (P k l a r) = rd_ k l a r+  rd_   k l a r  = case compareInt# kb k of+                   LT -> rd l+                   EQ -> (# Cons kb (f a eb) cs, ((n)+#1#) #)+                   GT -> rd r+ ------------------------------------------------+ -- lookAB2 :: Key -> a -> Key -> a -> IntMap b -> IAList c -> Int# -> (# IAList c,Int# #)+ lookAB2 ka0 ea0 ka1 ea1 tb cs n = case lookAB ka1 ea1 tb cs n of+                                   (# cs_,n_ #) -> lookAB ka0 ea0 tb cs_ n_+ ------------------------------------------------+ -- lookBA2 :: Key -> b -> Key -> b -> IntMap a -> IAList c -> Int# -> (# IAList c,Int# #)+ lookBA2 kb0 eb0 kb1 eb1 ta cs n = case lookBA kb1 eb1 ta cs n of+                                   (# cs_,n_ #) -> lookBA kb0 eb0 ta cs_ n_+ ------------------------------------------------+ -- lookAB3 :: Key -> a -> Key -> a -> Key -> a -> IntMap b -> IAList c -> Int# -> (# IAList c,Int# #)+ lookAB3 ka0 ea0 ka1 ea1 ka2 ea2 tb cs n = case lookAB ka2 ea2 tb cs n of+                                           (# cs_,n_ #) -> lookAB2 ka0 ea0 ka1 ea1 tb cs_ n_+ ------------------------------------------------+ -- lookAB3 :: Key -> b -> Key -> b -> Key -> b -> IntMap a -> IAList c -> Int# -> (# IAList c,Int# #)+ lookBA3 kb0 eb0 kb1 eb1 kb2 eb2 ta cs n = case lookBA kb2 eb2 ta cs n of+                                           (# cs_,n_ #) -> lookBA2 kb0 eb0 kb1 eb1 ta cs_ n_+-----------------------------------------------------------------------+-------------------- intersectionIntMap Ends Here ----------------------+-----------------------------------------------------------------------+++-- | See 'Map' class method 'intersection''.+intersectionIntMap' :: (a -> b -> c) -> IntMap a -> IntMap b -> IntMap c+intersectionIntMap' f ta0 tb0 = i0 ta0 tb0 where+ -- i0 :: IntMap a -> IntMap b -> IntMap c+ i0     E            _                = E+ i0 _                    E            = E+ i0 ta@(N _ la _ _ ) tb@(N _ lb _ _ ) = iH (addHeight 2# la) ta (addHeight 2# lb) tb+ i0 ta@(N _ la _ _ ) tb@(Z _ lb _ _ ) = iH (addHeight 2# la) ta (addHeight 1# lb) tb+ i0 ta@(N _ la _ _ ) tb@(P _ _  _ rb) = iH (addHeight 2# la) ta (addHeight 2# rb) tb+ i0 ta@(Z _ la _ _ ) tb@(N _ lb _ _ ) = iH (addHeight 1# la) ta (addHeight 2# lb) tb+ i0 ta@(Z _ la _ _ ) tb@(Z _ lb _ _ ) = iH (addHeight 1# la) ta (addHeight 1# lb) tb+ i0 ta@(Z _ la _ _ ) tb@(P _ _  _ rb) = iH (addHeight 1# la) ta (addHeight 2# rb) tb+ i0 ta@(P _ _  _ ra) tb@(N _ lb _ _ ) = iH (addHeight 2# ra) ta (addHeight 2# lb) tb+ i0 ta@(P _ _  _ ra) tb@(Z _ lb _ _ ) = iH (addHeight 2# ra) ta (addHeight 1# lb) tb+ i0 ta@(P _ _  _ ra) tb@(P _ _  _ rb) = iH (addHeight 2# ra) ta (addHeight 2# rb) tb++ -- iH :: Int# -> IntMap a ->   -- 1st IntMap with height+ --       Int# -> IntMap b ->   -- 2nd IntMap with height+ --       IntMap c+ iH hta ta htb tb  = case i hta ta htb tb Empt 0# of+                     (# ial,n #)   -> case subst (rep (I# (n))) ial of+                      (# imp,rm #) -> case rm of+                                      Empt -> imp+                                      _    -> error (mErr ++ "intersectionIntMap': Bad IAList.")++ -- i :: Int# -> IntMap a  ->    -- 1st IntMap with height+ --      Int# -> IntMap b  ->    -- 2nd IntMap with height+ --      IAList c -> Int# ->    -- Input IAList with length+ --      (# IAList c, Int# #)   -- Output IAList with length+ ------------------------------------------------+ i 0# _ _    _ cs n = (# cs,n #)+ i _    _ 0# _ cs n = (# cs,n #)+ ------------------------------------------------+ i 1# (Z ka _  ea _ ) 1# (Z kb _  eb _ ) cs n = if ka ==# kb then let c = f ea eb in c `seq`+                                                                      (# Cons ka c cs, ((n)+#1#) #)+                                                                 else (# cs,n #)+ i 1# (Z ka _  ea _ ) _    tb              cs n = lookAB ka ea tb cs n+ i _    ta              1# (Z kb _  eb _ ) cs n = lookBA kb eb ta cs n+ ------------------------------------------------+ i 2# (N ka0 _               ea0 (Z ka1 _ ea1 _)) _ tb cs n = lookAB2 ka0 ea0 ka1 ea1 tb cs n+ i 2# (P ka1 (Z ka0 _ ea0 _) ea1 _              ) _ tb cs n = lookAB2 ka0 ea0 ka1 ea1 tb cs n+ i _ ta 2# (N kb0 _               eb0 (Z kb1 _ eb1 _)) cs n = lookBA2 kb0 eb0 kb1 eb1 ta cs n+ i _ ta 2# (P kb1 (Z kb0 _ eb0 _) eb1 _              ) cs n = lookBA2 kb0 eb0 kb1 eb1 ta cs n+ i 2# (Z ka1 (Z ka0 _ ea0 _) ea1 (Z ka2 _ ea2 _)) _ tb cs n = lookAB3 ka0 ea0 ka1 ea1 ka2 ea2 tb cs n+ i _ ta 2# (Z kb1 (Z kb0 _ eb0 _) eb1 (Z kb2 _ eb2 _)) cs n = lookBA3 kb0 eb0 kb1 eb1 kb2 eb2 ta cs n+ ------------------------------------------------+ -- Both tree heights are known to be >= 3 at this point, so sub-tree heights >= 1+ i ha (N ka la ea ra) hb (N kb lb eb rb) cs n = i_ ka ((ha)-#2#) la ea ((ha)-#1#) ra kb ((hb)-#2#) lb eb ((hb)-#1#) rb cs n+ i ha (N ka la ea ra) hb (Z kb lb eb rb) cs n = i_ ka ((ha)-#2#) la ea ((ha)-#1#) ra kb ((hb)-#1#) lb eb ((hb)-#1#) rb cs n+ i ha (N ka la ea ra) hb (P kb lb eb rb) cs n = i_ ka ((ha)-#2#) la ea ((ha)-#1#) ra kb ((hb)-#1#) lb eb ((hb)-#2#) rb cs n+ i ha (Z ka la ea ra) hb (N kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#1#) ra kb ((hb)-#2#) lb eb ((hb)-#1#) rb cs n+ i ha (Z ka la ea ra) hb (Z kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#1#) ra kb ((hb)-#1#) lb eb ((hb)-#1#) rb cs n+ i ha (Z ka la ea ra) hb (P kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#1#) ra kb ((hb)-#1#) lb eb ((hb)-#2#) rb cs n+ i ha (P ka la ea ra) hb (N kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#2#) ra kb ((hb)-#2#) lb eb ((hb)-#1#) rb cs n+ i ha (P ka la ea ra) hb (Z kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#2#) ra kb ((hb)-#1#) lb eb ((hb)-#1#) rb cs n+ i ha (P ka la ea ra) hb (P kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#2#) ra kb ((hb)-#1#) lb eb ((hb)-#2#) rb cs n+ i _  _               _  _               _  _ = error (mErr ++ "intersectionIntMap': Bad IntMap.")+ ------------------------------------------------+ i_ ka hla la ea hra ra kb hlb lb eb hrb rb cs n = case compareInt# ka kb of+  -- ka < kb, so (la < ka < kb) & (ka < kb < rb)+  LT                            -> case fork kb hra ra of+   (# hrla,rla,mba,hrra,rra #)  -> case fork ka hlb lb of         -- (ka  < rla < kb) & (ka < kb  < rra)+    (# hllb,llb,mbb,hlrb,lrb #) -> case i hrra rra hrb rb cs n of -- (llb < ka  < kb) & (ka < lrb < kb)+     -- (la + llb) < ka < (rla + lrb) < kb < (rra + rb)+     (# cs_,n_ #)               -> case (case mbb of+                                         Nothing -> i hrla rla hlrb lrb cs_             n_+                                         Just b  -> let c = f ea b in c `seq`+                                                    i hrla rla hlrb lrb (Cons ka c cs_) ((n_)+#1#)+                                        ) of+      (# cs__,n__ #)            -> case mba of+                                   Nothing -> i hla la hllb llb cs__             n__+                                   Just a  -> let c = f a eb in c `seq`+                                              i hla la hllb llb (Cons kb c cs__) ((n__)+#1#)+  -- ka = kb+  EQ                            -> case i hra ra hrb rb cs n of+   (# cs_,n_ #)                 -> let c = f ea eb in c `seq`+                                   i hla la hlb lb (Cons ka c cs_) ((n_)+#1#)+  -- kb < ka, so (lb < kb < ka) & (kb < ka < ra)+  GT                            -> case fork ka hrb rb of+   (# hrlb,rlb,mbb,hrrb,rrb #)  -> case fork kb hla la of         -- (kb  < rlb < ka) & (kb < ka  < rrb)+    (# hlla,lla,mba,hlra,lra #) -> case i hra ra hrrb rrb cs n of -- (lla < kb  < ka) & (kb < lra < ka)+     -- (lla + lb) < kb < (lra + rlb) < ka < (ra + rrb)+     (# cs_,n_ #)               -> case (case mba of+                                         Nothing -> i hlra lra hrlb rlb cs_             n_+                                         Just a  -> let c = f a eb in c `seq`+                                                    i hlra lra hrlb rlb (Cons kb c cs_) ((n_)+#1#)+                                        ) of+      (# cs__,n__ #)           -> case mbb of+                                  Nothing -> i hlla lla hlb lb cs__             n__+                                  Just b  -> let c = f ea b in c `seq`+                                             i hlla lla hlb lb (Cons ka c cs__) ((n__)+#1#)+ ------------------------------------------------+ -- fork :: Key -> Int# -> IntMap x -> (# Int#,IntMap x,Maybe x,Int#,IntMap x #)+ -- Tree height (ht) is known to be >= 1, can we exploit this ??+ fork k0 ht t = fork_ ht t where+  fork_ h  E          = (# h,E,Nothing,h,E #)+  fork_ h (N k l x r) = fork__ k ((h)-#2#) l x ((h)-#1#) r+  fork_ h (Z k l x r) = fork__ k ((h)-#1#) l x ((h)-#1#) r+  fork_ h (P k l x r) = fork__ k ((h)-#1#) l x ((h)-#2#) r+  fork__ k hl l x hr r = case compareInt# k0 k of+                         LT ->                            case fork_ hl l of+                               (# hl0,l0,mbx,hl1,l1 #) -> case spliceH k l1 hl1 x r hr of+                                (# l1_,hl1_ #)         -> (# hl0,l0,mbx,hl1_,l1_ #)+                         EQ -> (# hl,l,Just x,hr,r #)+                         GT ->                            case fork_ hr r of+                               (# hl0,l0,mbx,hl1,l1 #) -> case spliceH k l hl x l0 hl0 of+                                (# l0_,hl0_ #)         -> (# hl0_,l0_,mbx,hl1,l1 #)+ ------------------------------------------------+ -- lookAB :: Key -> a -> IntMap b -> IAList c -> Int# -> (# IAList c,Int# #)+ lookAB ka ea tb cs n = rd tb where+  rd  E          = (# cs,n #)+  rd (N k l b r) = rd_ k l b r+  rd (Z k l b r) = rd_ k l b r+  rd (P k l b r) = rd_ k l b r+  rd_   k l b r  = case compareInt# ka k of+                   LT -> rd l+                   EQ -> let c = f ea b in c `seq` (# Cons ka c cs, ((n)+#1#) #)+                   GT -> rd r+ ------------------------------------------------+ -- lookBA :: Key -> b -> IntMap a -> IAList c -> Int# -> (# IAList c,Int# #)+ lookBA kb eb ta cs n = rd ta where+  rd  E          = (# cs,n #)+  rd (N k l a r) = rd_ k l a r+  rd (Z k l a r) = rd_ k l a r+  rd (P k l a r) = rd_ k l a r+  rd_   k l a r  = case compareInt# kb k of+                   LT -> rd l+                   EQ -> let c = f a eb in c `seq` (# Cons kb c cs, ((n)+#1#) #)+                   GT -> rd r+ ------------------------------------------------+ -- lookAB2 :: Key -> a -> Key -> a -> IntMap b -> IAList c -> Int# -> (# IAList c,Int# #)+ lookAB2 ka0 ea0 ka1 ea1 tb cs n = case lookAB ka1 ea1 tb cs n of+                                   (# cs_,n_ #) -> lookAB ka0 ea0 tb cs_ n_+ ------------------------------------------------+ -- lookBA2 :: Key -> b -> Key -> b -> IntMap a -> IAList c -> Int# -> (# IAList c,Int# #)+ lookBA2 kb0 eb0 kb1 eb1 ta cs n = case lookBA kb1 eb1 ta cs n of+                                   (# cs_,n_ #) -> lookBA kb0 eb0 ta cs_ n_+ ------------------------------------------------+ -- lookAB3 :: Key -> a -> Key -> a -> Key -> a -> IntMap b -> IAList c -> Int# -> (# IAList c,Int# #)+ lookAB3 ka0 ea0 ka1 ea1 ka2 ea2 tb cs n = case lookAB ka2 ea2 tb cs n of+                                           (# cs_,n_ #) -> lookAB2 ka0 ea0 ka1 ea1 tb cs_ n_+ ------------------------------------------------+ -- lookAB3 :: Key -> b -> Key -> b -> Key -> b -> IntMap a -> IAList c -> Int# -> (# IAList c,Int# #)+ lookBA3 kb0 eb0 kb1 eb1 kb2 eb2 ta cs n = case lookBA kb2 eb2 ta cs n of+                                           (# cs_,n_ #) -> lookBA2 kb0 eb0 kb1 eb1 ta cs_ n_+-----------------------------------------------------------------------+-------------------- intersectionIntMap' Ends Here ---------------------+-----------------------------------------------------------------------+++-- | See 'Map' class method 'intersectionMaybe'.+intersectionMaybeIntMap :: (a -> b -> Maybe c) -> IntMap a -> IntMap b -> IntMap c+intersectionMaybeIntMap f ta0 tb0 = i0 ta0 tb0 where+ -- i0 :: IntMap a -> IntMap b -> IntMap c+ i0     E            _                = E+ i0 _                    E            = E+ i0 ta@(N _ la _ _ ) tb@(N _ lb _ _ ) = iH (addHeight 2# la) ta (addHeight 2# lb) tb+ i0 ta@(N _ la _ _ ) tb@(Z _ lb _ _ ) = iH (addHeight 2# la) ta (addHeight 1# lb) tb+ i0 ta@(N _ la _ _ ) tb@(P _ _  _ rb) = iH (addHeight 2# la) ta (addHeight 2# rb) tb+ i0 ta@(Z _ la _ _ ) tb@(N _ lb _ _ ) = iH (addHeight 1# la) ta (addHeight 2# lb) tb+ i0 ta@(Z _ la _ _ ) tb@(Z _ lb _ _ ) = iH (addHeight 1# la) ta (addHeight 1# lb) tb+ i0 ta@(Z _ la _ _ ) tb@(P _ _  _ rb) = iH (addHeight 1# la) ta (addHeight 2# rb) tb+ i0 ta@(P _ _  _ ra) tb@(N _ lb _ _ ) = iH (addHeight 2# ra) ta (addHeight 2# lb) tb+ i0 ta@(P _ _  _ ra) tb@(Z _ lb _ _ ) = iH (addHeight 2# ra) ta (addHeight 1# lb) tb+ i0 ta@(P _ _  _ ra) tb@(P _ _  _ rb) = iH (addHeight 2# ra) ta (addHeight 2# rb) tb++ -- iH :: Int# -> IntMap a ->   -- 1st IntMap with height+ --       Int# -> IntMap b ->   -- 2nd IntMap with height+ --       IntMap c+ iH hta ta htb tb  = case i hta ta htb tb Empt 0# of+                     (# ial,n #)   -> case subst (rep (I# (n))) ial of+                      (# imp,rm #) -> case rm of+                                      Empt -> imp+                                      _    -> error (mErr ++ "intersectionMaybeIntMap: Bad IAList.")++ -- i :: Int# -> IntMap a  ->    -- 1st IntMap with height+ --      Int# -> IntMap b  ->    -- 2nd IntMap with height+ --      IAList c -> Int# ->    -- Input IAList with length+ --      (# IAList c, Int# #)   -- Output IAList with length+ ------------------------------------------------+ i 0# _ _    _ cs n = (# cs,n #)+ i _    _ 0# _ cs n = (# cs,n #)+ ------------------------------------------------+ i 1# (Z ka _  ea _ ) 1# (Z kb _  eb _ ) cs n = if ka ==# kb then case f ea eb of+                                                                      Just c  -> (# Cons ka c cs, ((n)+#1#) #)+                                                                      Nothing -> (# cs,n #)+                                                                 else (# cs,n #)+ i 1# (Z ka _  ea _ ) _    tb              cs n = lookAB ka ea tb cs n+ i _    ta              1# (Z kb _  eb _ ) cs n = lookBA kb eb ta cs n+ ------------------------------------------------+ i 2# (N ka0 _               ea0 (Z ka1 _ ea1 _)) _ tb cs n = lookAB2 ka0 ea0 ka1 ea1 tb cs n+ i 2# (P ka1 (Z ka0 _ ea0 _) ea1 _              ) _ tb cs n = lookAB2 ka0 ea0 ka1 ea1 tb cs n+ i _ ta 2# (N kb0 _               eb0 (Z kb1 _ eb1 _)) cs n = lookBA2 kb0 eb0 kb1 eb1 ta cs n+ i _ ta 2# (P kb1 (Z kb0 _ eb0 _) eb1 _              ) cs n = lookBA2 kb0 eb0 kb1 eb1 ta cs n+ i 2# (Z ka1 (Z ka0 _ ea0 _) ea1 (Z ka2 _ ea2 _)) _ tb cs n = lookAB3 ka0 ea0 ka1 ea1 ka2 ea2 tb cs n+ i _ ta 2# (Z kb1 (Z kb0 _ eb0 _) eb1 (Z kb2 _ eb2 _)) cs n = lookBA3 kb0 eb0 kb1 eb1 kb2 eb2 ta cs n+ ------------------------------------------------+ -- Both tree heights are known to be >= 3 at this point, so sub-tree heights >= 1+ i ha (N ka la ea ra) hb (N kb lb eb rb) cs n = i_ ka ((ha)-#2#) la ea ((ha)-#1#) ra kb ((hb)-#2#) lb eb ((hb)-#1#) rb cs n+ i ha (N ka la ea ra) hb (Z kb lb eb rb) cs n = i_ ka ((ha)-#2#) la ea ((ha)-#1#) ra kb ((hb)-#1#) lb eb ((hb)-#1#) rb cs n+ i ha (N ka la ea ra) hb (P kb lb eb rb) cs n = i_ ka ((ha)-#2#) la ea ((ha)-#1#) ra kb ((hb)-#1#) lb eb ((hb)-#2#) rb cs n+ i ha (Z ka la ea ra) hb (N kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#1#) ra kb ((hb)-#2#) lb eb ((hb)-#1#) rb cs n+ i ha (Z ka la ea ra) hb (Z kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#1#) ra kb ((hb)-#1#) lb eb ((hb)-#1#) rb cs n+ i ha (Z ka la ea ra) hb (P kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#1#) ra kb ((hb)-#1#) lb eb ((hb)-#2#) rb cs n+ i ha (P ka la ea ra) hb (N kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#2#) ra kb ((hb)-#2#) lb eb ((hb)-#1#) rb cs n+ i ha (P ka la ea ra) hb (Z kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#2#) ra kb ((hb)-#1#) lb eb ((hb)-#1#) rb cs n+ i ha (P ka la ea ra) hb (P kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#2#) ra kb ((hb)-#1#) lb eb ((hb)-#2#) rb cs n+ i _  _               _  _               _  _ = error (mErr ++ "intersectionMaybeIntMap: Bad IntMap.")+ ------------------------------------------------+ i_ ka hla la ea hra ra kb hlb lb eb hrb rb cs n = case compareInt# ka kb of+  -- ka < kb, so (la < ka < kb) & (ka < kb < rb)+  LT                            -> case fork kb hra ra of+   (# hrla,rla,mba,hrra,rra #)  -> case fork ka hlb lb of         -- (ka  < rla < kb) & (ka < kb  < rra)+    (# hllb,llb,mbb,hlrb,lrb #) -> case i hrra rra hrb rb cs n of -- (llb < ka  < kb) & (ka < lrb < kb)+     -- (la + llb) < ka < (rla + lrb) < kb < (rra + rb)+     (# cs_,n_ #)               -> case (case mbb of+                                         Nothing ->            i hrla rla hlrb lrb cs_             n_+                                         Just b  -> case f ea b of+                                                    Just c  -> i hrla rla hlrb lrb (Cons ka c cs_) ((n_)+#1#)+                                                    Nothing -> i hrla rla hlrb lrb cs_             n_+                                        ) of+      (# cs__,n__ #)            -> case mba of+                                   Nothing ->            i hla la hllb llb cs__             n__+                                   Just a  -> case f a eb of+                                              Just c  -> i hla la hllb llb (Cons kb c cs__) ((n__)+#1#)+                                              Nothing -> i hla la hllb llb cs__             n__+  -- ka = kb+  EQ                            -> case i hra ra hrb rb cs n of+   (# cs_,n_ #)                 -> case f ea eb of+                                   Just c  -> i hla la hlb lb (Cons ka c cs_) ((n_)+#1#)+                                   Nothing -> i hla la hlb lb cs_             n_+  -- kb < ka, so (lb < kb < ka) & (kb < ka < ra)+  GT                            -> case fork ka hrb rb of+   (# hrlb,rlb,mbb,hrrb,rrb #)  -> case fork kb hla la of         -- (kb  < rlb < ka) & (kb < ka  < rrb)+    (# hlla,lla,mba,hlra,lra #) -> case i hra ra hrrb rrb cs n of -- (lla < kb  < ka) & (kb < lra < ka)+     -- (lla + lb) < kb < (lra + rlb) < ka < (ra + rrb)+     (# cs_,n_ #)               -> case (case mba of+                                         Nothing ->            i hlra lra hrlb rlb cs_             n_+                                         Just a  -> case f a eb of+                                                    Just c  -> i hlra lra hrlb rlb (Cons kb c cs_) ((n_)+#1#)+                                                    Nothing -> i hlra lra hrlb rlb cs_             n_+                                        ) of+      (# cs__,n__ #)           -> case mbb of+                                  Nothing ->            i hlla lla hlb lb cs__             n__+                                  Just b  -> case f ea b of+                                             Just c  -> i hlla lla hlb lb (Cons ka c cs__) ((n__)+#1#)+                                             Nothing -> i hlla lla hlb lb cs__             n__+------------------------------------------------+ -- fork :: Key -> Int# -> IntMap x -> (# Int#,IntMap x,Maybe x,Int#,IntMap x #)+ -- Tree height (ht) is known to be >= 1, can we exploit this ??+ fork k0 ht t = fork_ ht t where+  fork_ h  E          = (# h,E,Nothing,h,E #)+  fork_ h (N k l x r) = fork__ k ((h)-#2#) l x ((h)-#1#) r+  fork_ h (Z k l x r) = fork__ k ((h)-#1#) l x ((h)-#1#) r+  fork_ h (P k l x r) = fork__ k ((h)-#1#) l x ((h)-#2#) r+  fork__ k hl l x hr r = case compareInt# k0 k of+                         LT ->                            case fork_ hl l of+                               (# hl0,l0,mbx,hl1,l1 #) -> case spliceH k l1 hl1 x r hr of+                                (# l1_,hl1_ #)         -> (# hl0,l0,mbx,hl1_,l1_ #)+                         EQ -> (# hl,l,Just x,hr,r #)+                         GT ->                            case fork_ hr r of+                               (# hl0,l0,mbx,hl1,l1 #) -> case spliceH k l hl x l0 hl0 of+                                (# l0_,hl0_ #)         -> (# hl0_,l0_,mbx,hl1,l1 #)+ ------------------------------------------------+ -- lookAB :: Key -> a -> IntMap b -> IAList c -> Int# -> (# IAList c,Int# #)+ lookAB ka ea tb cs n = rd tb where+  rd  E          = (# cs,n #)+  rd (N k l b r) = rd_ k l b r+  rd (Z k l b r) = rd_ k l b r+  rd (P k l b r) = rd_ k l b r+  rd_   k l b r  = case compareInt# ka k of+                   LT -> rd l+                   EQ -> case f ea b of+                         Just c  -> (# Cons ka c cs, ((n)+#1#) #)+                         Nothing -> (# cs,n #)+                   GT -> rd r+ ------------------------------------------------+ -- lookBA :: Key -> b -> IntMap a -> IAList c -> Int# -> (# IAList c,Int# #)+ lookBA kb eb ta cs n = rd ta where+  rd  E          = (# cs,n #)+  rd (N k l a r) = rd_ k l a r+  rd (Z k l a r) = rd_ k l a r+  rd (P k l a r) = rd_ k l a r+  rd_   k l a r  = case compareInt# kb k of+                   LT -> rd l+                   EQ -> case f a eb of+                         Just c  -> (# Cons kb c cs, ((n)+#1#) #)+                         Nothing -> (# cs,n #)+                   GT -> rd r+ ------------------------------------------------+ -- lookAB2 :: Key -> a -> Key -> a -> IntMap b -> IAList c -> Int# -> (# IAList c,Int# #)+ lookAB2 ka0 ea0 ka1 ea1 tb cs n = case lookAB ka1 ea1 tb cs n of+                                   (# cs_,n_ #) -> lookAB ka0 ea0 tb cs_ n_+ ------------------------------------------------+ -- lookBA2 :: Key -> b -> Key -> b -> IntMap a -> IAList c -> Int# -> (# IAList c,Int# #)+ lookBA2 kb0 eb0 kb1 eb1 ta cs n = case lookBA kb1 eb1 ta cs n of+                                   (# cs_,n_ #) -> lookBA kb0 eb0 ta cs_ n_+ ------------------------------------------------+ -- lookAB3 :: Key -> a -> Key -> a -> Key -> a -> IntMap b -> IAList c -> Int# -> (# IAList c,Int# #)+ lookAB3 ka0 ea0 ka1 ea1 ka2 ea2 tb cs n = case lookAB ka2 ea2 tb cs n of+                                           (# cs_,n_ #) -> lookAB2 ka0 ea0 ka1 ea1 tb cs_ n_+ ------------------------------------------------+ -- lookAB3 :: Key -> b -> Key -> b -> Key -> b -> IntMap a -> IAList c -> Int# -> (# IAList c,Int# #)+ lookBA3 kb0 eb0 kb1 eb1 kb2 eb2 ta cs n = case lookBA kb2 eb2 ta cs n of+                                           (# cs_,n_ #) -> lookBA2 kb0 eb0 kb1 eb1 ta cs_ n_+-----------------------------------------------------------------------+----------------- intersectionMaybeIntMap Ends Here --------------------+-----------------------------------------------------------------------++-- AVL template, output of rep+data Tmp = ET | NT Tmp Tmp | ZT Tmp Tmp | PT Tmp Tmp+-- Construct a template of size n (n>=0). This is for internal use only.+-- N.B. Uses regular (boxed) Ints. Optimising for unboxed Ints is just too painful in this case.+-- Hopefully the compiler will do a decent job for us...???+rep :: Int -> Tmp+rep n | odd n = repOdd n -- n is odd , >=1+rep n         = repEvn n -- n is even, >=0+-- n is known to be odd (>=1), so left and right sub-trees are identical+repOdd :: Int -> Tmp+repOdd n      = let sub = rep (n `shiftR` 1) in ZT sub sub+-- n is known to be even (>=0)+repEvn :: Int -> Tmp+repEvn n | n .&. (n-1) == 0 = repP2 n -- treat exact powers of 2 specially, traps n=0 too+repEvn n      = let nl = n `shiftR` 1 -- size of left subtree  (odd or even)+                    nr = nl - 1       -- size of right subtree (even or odd)+                in if odd nr+                   then let l = repEvn nl           -- right sub-tree is odd , so left is even (>=2)+                            r = repOdd nr+                        in l `seq` r `seq` ZT l r+                   else let l = repOdd nl           -- right sub-tree is even, so left is odd (>=2)+                            r = repEvn nr+                        in l `seq` r `seq` ZT l r+-- n is an exact power of 2 (or 0), I.E. 0,1,2,4,8,16..+repP2 :: Int -> Tmp+repP2 0       = ET+repP2 1       = ZT ET ET+repP2 n       = let nl = n `shiftR` 1 -- nl is also an exact power of 2+                    nr = nl - 1       -- nr is one less that an exact power of 2+                    l  = repP2 nl+                    r  = repP2M1 nr+                in  l `seq` r `seq` PT l r -- BF=+1+-- n is one less than an exact power of 2, I.E. 0,1,3,7,15..+repP2M1 :: Int -> Tmp+repP2M1 0     = ET+repP2M1 n     = let sub = repP2M1 (n `shiftR` 1) in sub `seq` ZT sub sub+++-- Substitute template values for real values taken from the IAList. This is for internal use only.+-- Length of IAList should match Template size+subst :: Tmp -> IAList a -> (# IntMap a, IAList a #)+subst  ET      as = (# E,as #)+subst (NT l r) as = subst_ N l r as+subst (ZT l r) as = subst_ Z l r as+subst (PT l r) as = subst_ P l r as+subst_ :: (Key -> IntMap a -> a -> IntMap a  -> IntMap a) -> Tmp -> Tmp -> IAList a -> (# IntMap a, IAList a #)+{-# INLINE subst_ #-}+subst_ c l r as = case subst l as of+                  (# l_,as_ #) -> case as_ of+                                  Cons ka a as__ -> case subst r as__ of+                                                    (# r_,as___ #) -> let t = c ka l_ a r_+                                                                      in t `seq` (# t,as___ #)+                                  Empt    -> error (mErr ++ "subst: List too short.")++-- | See 'Map' class method 'difference'.+differenceIntMap :: IntMap a -> IntMap b -> IntMap a+differenceIntMap ta0 tb0 = d0 ta0 tb0 where+ d0  E            _ = E+ d0  _            E = ta0+ d0 (N _ la _ _ ) _ = dH (addHeight 2# la) -- ?? As things are, we could use relative heights here!+ d0 (Z _ la _ _ ) _ = dH (addHeight 1# la)+ d0 (P _ _  _ ra) _ = dH (addHeight 2# ra)+ dH hta0 = case d hta0 ta0 tb0 of (# t,_ #) -> t+ -- d :: Int# -> IntMap a  ->    -- 1st IntMap with height+ --              IntMap b  ->    -- 2nd IntMap (without height)+ --      (# Int#,IntMap a #)     -- Output IntMap with height+ ------------------------------------------------+ d ha  E              _             = (# E ,ha #) -- Relative heights!!+ d ha ta              E             = (# ta,ha #)+ d ha (N ka la a ra) (N kb lb _ rb) = d_ ka ((ha)-#2#) la a ((ha)-#1#) ra kb lb rb+ d ha (N ka la a ra) (Z kb lb _ rb) = d_ ka ((ha)-#2#) la a ((ha)-#1#) ra kb lb rb+ d ha (N ka la a ra) (P kb lb _ rb) = d_ ka ((ha)-#2#) la a ((ha)-#1#) ra kb lb rb+ d ha (Z ka la a ra) (N kb lb _ rb) = d_ ka ((ha)-#1#) la a ((ha)-#1#) ra kb lb rb+ d ha (Z ka la a ra) (Z kb lb _ rb) = d_ ka ((ha)-#1#) la a ((ha)-#1#) ra kb lb rb+ d ha (Z ka la a ra) (P kb lb _ rb) = d_ ka ((ha)-#1#) la a ((ha)-#1#) ra kb lb rb+ d ha (P ka la a ra) (N kb lb _ rb) = d_ ka ((ha)-#1#) la a ((ha)-#2#) ra kb lb rb+ d ha (P ka la a ra) (Z kb lb _ rb) = d_ ka ((ha)-#1#) la a ((ha)-#2#) ra kb lb rb+ d ha (P ka la a ra) (P kb lb _ rb) = d_ ka ((ha)-#1#) la a ((ha)-#2#) ra kb lb rb+ d_ ka hla la a hra ra kb lb rb =+  case compareInt# ka kb of+  -- ka < kb, so (la < ka < kb) & (ka < kb < rb)+  LT ->                            case fork hra ra kb of+        (# hrla,rla,hrra,rra #) -> case spliceH ka la hla a rla hrla of+         (# la_,hla_ #)         -> case d hla_ la_ lb of+          (# l,hl #)            -> case d hrra rra rb of+           (# r,hr #)           -> joinH l hl r hr+  -- ka = kb+  EQ ->                case d hra ra rb of -- right+        (# r,hr #)  -> case d hla la lb of -- left+         (# l,hl #) -> joinH l hl r hr+  -- kb < ka, so (lb < kb < ka) & (kb < ka < ra)+  GT ->                            case fork hla la kb of+        (# hlla,lla,hlra,lra #) -> case spliceH ka lra hlra a ra hra of+         (# ra_,hra_ #)         -> case d hra_ ra_ rb of+          (# r,hr #)            -> case d hlla lla lb of+           (# l,hl #)           -> joinH l hl r hr+ -- fork :: Int# -> IntMap a -> Key -> (# Int#, IntMap a, Int#, IntMap a #)+ fork hta ta kb = fork_ hta ta where+  fork_ h  E          = (# h,E,h,E #) -- Relative heights!!+  fork_ h (N k l a r) = fork__ k ((h)-#2#) l a ((h)-#1#) r+  fork_ h (Z k l a r) = fork__ k ((h)-#1#) l a ((h)-#1#) r+  fork_ h (P k l a r) = fork__ k ((h)-#1#) l a ((h)-#2#) r+  fork__ k hl l a hr r = case compareInt# k kb of+                         LT ->                        case fork_ hr r of+                               (# hx0,x0,hx1,x1 #) -> case spliceH k l hl a x0 hx0 of+                                (# x0_,hx0_ #)     -> (# hx0_,x0_,hx1,x1 #)+                         EQ -> (# hl,l,hr,r #)  -- (k,a) is dropped.+                         GT ->                        case fork_ hl l of+                               (# hx0,x0,hx1,x1 #) -> case spliceH k x1 hx1 a r hr of+                                (# x1_,hx1_ #)     -> (# hx0,x0,hx1_,x1_ #)+-----------------------------------------------------------------------+--------------------- differenceIntMap Ends Here -----------------------+-----------------------------------------------------------------------++-- | See 'Map' class method 'differenceMaybe'.+differenceMaybeIntMap :: (a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a+differenceMaybeIntMap f ta0 tb0 = d0 ta0 tb0 where+ d0  E            _ = E+ d0  _            E = ta0+ d0 (N _ la _ _ ) _ = dH (addHeight 2# la) -- ?? As things are, we could use relative heights here!+ d0 (Z _ la _ _ ) _ = dH (addHeight 1# la)+ d0 (P _ _  _ ra) _ = dH (addHeight 2# ra)+ dH hta0 = case d hta0 ta0 tb0 of (# t,_ #) -> t+ -- d :: Int# -> IntMap a  ->    -- 1st IntMap with height+ --              IntMap b  ->    -- 2nd IntMap (without height)+ --      (# Int#,IntMap a #)     -- Output IntMap with height+ ------------------------------------------------+ d ha  E              _             = (# E ,ha #) -- Relative heights!!+ d ha ta              E             = (# ta,ha #)+ d ha (N ka la a ra) (N kb lb b rb) = d_ ka ((ha)-#2#) la a ((ha)-#1#) ra kb lb b rb+ d ha (N ka la a ra) (Z kb lb b rb) = d_ ka ((ha)-#2#) la a ((ha)-#1#) ra kb lb b rb+ d ha (N ka la a ra) (P kb lb b rb) = d_ ka ((ha)-#2#) la a ((ha)-#1#) ra kb lb b rb+ d ha (Z ka la a ra) (N kb lb b rb) = d_ ka ((ha)-#1#) la a ((ha)-#1#) ra kb lb b rb+ d ha (Z ka la a ra) (Z kb lb b rb) = d_ ka ((ha)-#1#) la a ((ha)-#1#) ra kb lb b rb+ d ha (Z ka la a ra) (P kb lb b rb) = d_ ka ((ha)-#1#) la a ((ha)-#1#) ra kb lb b rb+ d ha (P ka la a ra) (N kb lb b rb) = d_ ka ((ha)-#1#) la a ((ha)-#2#) ra kb lb b rb+ d ha (P ka la a ra) (Z kb lb b rb) = d_ ka ((ha)-#1#) la a ((ha)-#2#) ra kb lb b rb+ d ha (P ka la a ra) (P kb lb b rb) = d_ ka ((ha)-#1#) la a ((ha)-#2#) ra kb lb b rb+ d_ ka hla la a hra ra kb lb b rb =+  case compareInt# ka kb of+  -- ka < kb, so (la < ka < kb) & (ka < kb < rb)+  LT ->                                case fork hra ra kb b of+        (# hrla,rla,mba,hrra,rra #) -> case spliceH ka la hla a rla hrla of+         (# la_,hla_ #)             -> case d hla_ la_ lb of+          (# l,hl #)                -> case d hrra rra rb of+           (# r,hr #)               -> case mba of+                                       Nothing -> joinH      l hl    r hr+                                       Just a' -> spliceH kb l hl a' r hr+  -- ka = kb+  EQ ->                case d hra ra rb of -- right+        (# r,hr #)  -> case d hla la lb of -- left+         (# l,hl #) -> case f a b of+                       Nothing -> joinH      l hl    r hr+                       Just a' -> spliceH kb l hl a' r hr+  -- kb < ka, so (lb < kb < ka) & (kb < ka < ra)+  GT ->                                case fork hla la kb b of+        (# hlla,lla,mba,hlra,lra #) -> case spliceH ka lra hlra a ra hra of+         (# ra_,hra_ #)             -> case d hra_ ra_ rb of+          (# r,hr #)                -> case d hlla lla lb of+           (# l,hl #)               -> case mba of+                                       Nothing -> joinH      l hl    r hr+                                       Just a' -> spliceH kb l hl a' r hr+ -- fork :: Int# -> IntMap a -> Key -> b -> (# Int#, IntMap a, Maybe a, Int#, IntMap a #)+ fork hta ta kb b = fork_ hta ta where+  fork_ h  E          = (# h,E,Nothing,h,E #) -- Relative heights!!+  fork_ h (N k l a r) = fork__ k ((h)-#2#) l a ((h)-#1#) r+  fork_ h (Z k l a r) = fork__ k ((h)-#1#) l a ((h)-#1#) r+  fork_ h (P k l a r) = fork__ k ((h)-#1#) l a ((h)-#2#) r+  fork__ k hl l a hr r = case compareInt# k kb of+                         LT ->                            case fork_ hr r of+                               (# hx0,x0,mba,hx1,x1 #) -> case spliceH k l hl a x0 hx0 of+                                (# x0_,hx0_ #)         -> (# hx0_,x0_,mba,hx1,x1 #)+                         EQ -> let mba = f a b in mba `seq` (# hl,l,mba,hr,r #)+                         GT ->                            case fork_ hl l of+                               (# hx0,x0,mba,hx1,x1 #) -> case spliceH k x1 hx1 a r hr of+                                (# x1_,hx1_ #)         -> (# hx0,x0,mba,hx1_,x1_ #)+-----------------------------------------------------------------------+------------------ differenceMaybeIntMap Ends Here ---------------------+-----------------------------------------------------------------------++-- | Join two IntMaps of known height, returning an IntMap of known height.+-- It_s OK if heights are relative (I.E. if they share same fixed offset).+--+-- Complexity: O(d), where d is the absolute difference in tree heights.+joinH :: IntMap a -> Int# -> IntMap a -> Int# -> (# IntMap a,Int# #)+joinH l hl r hr =+ case compareInt# hl hr of+ -- hr > hl+ LT -> case l of+       E             -> (# r,hr #)+       N li ll la lr -> case popRN li ll la lr of+                        (# l_,iv,v #) -> case l_ of+                                         Z _ _ _ _ -> spliceHL iv l_ ((hl)-#1#) v r hr -- dH=-1+                                         _         -> spliceHL iv l_         hl  v r hr -- dH= 0+       Z li ll la lr -> case popRZ li ll la lr of+                        (# l_,iv,v #) -> case l_ of+                                         E         -> pushHL l r hr                     -- l had only 1 element+                                         _         -> spliceHL iv l_         hl  v r hr -- dH=0+       P li ll la lr -> case popRP li ll la lr of+                        (# l_,iv,v #) -> case l_ of+                                         Z _ _ _ _ -> spliceHL iv l_ ((hl)-#1#) v r hr -- dH=-1+                                         _         -> spliceHL iv l_         hl  v r hr -- dH= 0+ -- hr = hl+ EQ -> case l of+       E             -> (# l,hl #)              -- r must be empty too+       N li ll la lr -> case popRN li ll la lr of+                        (# l_,iv,v #) -> case l_ of+                                         Z _ _ _ _ -> spliceHL iv l_ ((hl)-#1#) v r hr -- dH=-1+                                         _         -> (# Z iv l_ v r, ((hr)+#1#) #)    -- dH= 0+       Z li ll la lr -> case popRZ li ll la lr of+                        (# l_,iv,v #) -> case l_ of+                                         E         -> pushHL l r hr                     -- l had only 1 element+                                         _         -> (# Z iv l_ v r, ((hr)+#1#) #)    -- dH= 0+       P li ll la lr -> case popRP li ll la lr of+                        (# l_,iv,v #) -> case l_ of+                                         Z _ _ _ _ -> spliceHL iv l_ ((hl)-#1#) v r hr -- dH=-1+                                         _         -> (# Z iv l_ v r, ((hr)+#1#) #)    -- dH= 0+ -- hl > hr+ GT -> case r of+       E             -> (# l,hl #)+       N ri rl ra rr -> case popLN ri rl ra rr of+                        (# iv,v,r_ #) -> case r_ of+                                         Z _ _ _ _ -> spliceHR iv l hl v r_ ((hr)-#1#) -- dH=-1+                                         _         -> spliceHR iv l hl v r_         hr  -- dH= 0+       Z ri rl ra rr -> case popLZ ri rl ra rr of+                        (# iv,v,r_ #) -> case r_ of+                                         E         -> pushHR l hl r                     -- r had only 1 element+                                         _         -> spliceHR iv l hl v r_ hr          -- dH=0+       P ri rl ra rr -> case popLP ri rl ra rr of+                        (# iv,v,r_ #) -> case r_ of+                                         Z _ _ _ _ -> spliceHR iv l hl v r_ ((hr)-#1#) -- dH=-1+                                         _         -> spliceHR iv l hl v r_         hr  -- dH= 0+++-- | Splice two IntMaps of known height using the supplied bridging association pair.+-- That is, the bridging pair appears \"in the middle\" of the resulting IntMap.+-- The pairs of the first tree argument are to the left of the bridging pair and+-- the pairs of the second tree are to the right of the bridging pair.+--+-- This function does not require that the IntMap heights are absolutely correct, only that+-- the difference in supplied heights is equal to the difference in actual heights. So it_s+-- OK if the input heights both have the same unknown constant offset. (The output height+-- will also have the same constant offset in this case.)+--+-- Complexity: O(d), where d is the absolute difference in tree heights.+spliceH :: Key -> IntMap a -> Int# -> a -> IntMap a -> Int# -> (# IntMap a,Int# #)+-- You_d think inlining this function would make a significant difference to many functions+-- (such as set operations), but it doesn_t. It makes them marginally slower!!+spliceH ib l hl b r hr =+ case compareInt# hl hr of+ LT -> spliceHL ib l hl b r hr+ EQ -> (# Z ib l b r, ((hl)+#1#) #)+ GT -> spliceHR ib l hl b r hr++-----------------------------------------------------------------------+----------------------------- spliceHL --------------------------------+-----------------------------------------------------------------------+-- Splice tree s into the left edge of tree t (where ht>hs) using the supplied bridging pair (ib,b),+-- returning another tree of known relative height.+spliceHL :: Key -> IntMap a -> Int# -> a -> IntMap a -> Int# -> (# IntMap a,Int# #)+spliceHL ib s hs b t ht = let d = ((ht)-#(hs))+                          in if d ==# 1# then (# N ib s b t, ((ht)+#1#) #)+                                           else sHL ht d t+ where -- s, ib and b are free++ -- Splice two trees of known relative height where hr>hl+1, using the supplied bridging element,+ -- returning another tree of known relative height. d >= 2+ {-# INLINE sHL #-}+ sHL _  _  E              = error "spliceHL_: Bug0"          -- impossible if hr>hl+ sHL hr d (N ri rl ra rr) = let r_ = sLN ((d)-#2#) ri rl ra rr+                            in  r_ `seq` (# r_,hr #)+ sHL hr d (Z ri rl ra rr) = let r_ = sLZ ((d)-#1#) ri rl ra rr+                            in case r_ of+                               E         -> error "spliceHL: Bug1"+                               Z _ _ _ _ -> (# r_,        hr  #)+                               _         -> (# r_,((hr)+#1#) #)+ sHL hr d (P ri rl ra rr) = let r_ = sLP ((d)-#1#) ri rl ra rr+                            in  r_ `seq` (# r_,hr #)++ -- Splice into left subtree of (N i l a r), height cannot change as a result of this+ sLN 0# i  l              a r = Z i (Z ib s b l) a r                                       -- dH=0+ sLN 1# i  l              a r = Z i (N ib s b l) a r                                       -- dH=0+ sLN d    i (N li ll la lr) a r = let l_ = sLN ((d)-#2#) li ll la lr in l_ `seq` N i l_ a r+ sLN d    i (Z li ll la lr) a r = let l_ = sLZ ((d)-#1#) li ll la lr+                                  in case l_ of+                                     Z _ _ _ _ -> N i l_ a r                                 -- dH=0+                                     P _ _ _ _ -> Z i l_ a r                                 -- dH=0+                                     _         -> error "spliceHL: Bug2"                     -- impossible+ sLN d    i (P li ll la lr) a r = let l_ = sLP ((d)-#1#) li ll la lr in l_ `seq` N i l_ a r+ sLN _    _  E              _ _ = error "spliceHL: Bug3"                                     -- impossible++ -- Splice into left subtree of (Z i l a r), Z->P if dH=1, Z->Z if dH=0+ sLZ 1# i  l              a r = P i (N ib s b l) a r                                       -- Z->P, dH=1+ sLZ d    i (N li ll la lr) a r = let l_ = sLN ((d)-#2#) li ll la lr in l_ `seq` Z i l_ a r -- Z->Z, dH=0+ sLZ d    i (Z li ll la lr) a r = let l_ = sLZ ((d)-#1#) li ll la lr+                                  in case l_ of+                                     Z _ _ _ _ -> Z i l_ a r                                 -- Z->Z, dH=0+                                     P _ _ _ _ -> P i l_ a r                                 -- Z->P, dH=1+                                     _         -> error "spliceHL: Bug4"                     -- impossible+ sLZ d    i (P li ll la lr) a r = let l_ = sLP ((d)-#1#) li ll la lr in l_ `seq` Z i l_ a r -- Z->Z, dH=0+ sLZ _    _  E              _ _ = error "spliceHL: Bug5"                                     -- impossible++ -- Splice into left subtree of (P i l a r), height cannot change as a result of this+ sLP 1# i (N li ll la lr) a r = Z li (P ib s b ll) la (Z i lr a r)                         -- dH=0+ sLP 1# i (Z li ll la lr) a r = Z li (Z ib s b ll) la (Z i lr a r)                         -- dH=0+ sLP 1# i (P li ll la lr) a r = Z li (Z ib s b ll) la (N i lr a r)                         -- dH=0+ sLP d    i (N li ll la lr) a r = let l_ = sLN ((d)-#2#) li ll la lr in l_ `seq` P i l_ a r -- dH=0+ sLP d    i (Z li ll la lr) a r = sLPZ ((d)-#1#) i li ll la lr a r                          -- dH=0+ sLP d    i (P li ll la lr) a r = let l_ = sLP ((d)-#1#) li ll la lr in l_ `seq` P i l_ a r -- dH=0+ sLP _    _  E              _ _ = error "spliceHL: Bug6"++ -- Splice into left subtree of (P i (Z li ll la lr) a r)+ {-# INLINE sLPZ #-}+ sLPZ 1# i li ll                  la lr a r = Z li (N ib s b ll) la (Z i lr a r)         -- dH=0+ sLPZ d    i li (N lli lll lle llr) la lr a r = let ll_ = sLN ((d)-#2#) lli lll lle llr   -- dH=0+                                                in  ll_ `seq` P i (Z li ll_ la lr) a r+ sLPZ d    i li (Z lli lll lle llr) la lr a r = let ll_ = sLZ ((d)-#1#) lli lll lle llr   -- dH=0+                                                in case ll_ of+                                                   Z _ _ _ _ -> P i (Z li ll_ la lr) a r   -- dH=0+                                                   P _ _ _ _ -> Z li ll_ la (Z i lr a r)   -- dH=0+                                                   _         -> error "spliceHL: Bug7"     -- impossible+ sLPZ d    i li (P lli lll lle llr) la lr a r = let ll_ = sLP ((d)-#1#) lli lll lle llr   -- dH=0+                                                in  ll_ `seq` P i (Z li ll_ la lr) a r+ sLPZ _    _ _   E                  _  _  _ _ = error "spliceHL: Bug8"+-----------------------------------------------------------------------+------------------------- spliceHL Ends Here --------------------------+-----------------------------------------------------------------------++-----------------------------------------------------------------------+----------------------------- spliceHR --------------------------------+-----------------------------------------------------------------------+-- Splice tree t into the right edge of tree s (where hs>ht) using the supplied bridging pair (ib,b),+-- returning another tree of known relative height.+spliceHR :: Key -> IntMap a -> Int# -> a -> IntMap a -> Int# -> (# IntMap a,Int# #)+spliceHR ib s hs b t ht = let d = ((hs)-#(ht))+                          in if d ==# 1# then (# P ib s b t, ((hs)+#1#) #)+                                           else sHR hs d s+ where -- t, ib and b are free++ {-# INLINE sHR #-}+ sHR _  _  E           = error "spliceHL: Bug0"          -- impossible if hl>hr+ sHR hl d (N li ll la lr) = let l_ = sRN ((d)-#1#) li ll la lr+                            in  l_ `seq` (# l_,hl #)+ sHR hl d (Z li ll la lr) = let l_ = sRZ ((d)-#1#) li ll la lr+                            in case l_ of+                               E         -> error "spliceHL: Bug1"+                               Z _ _ _ _ -> (# l_,        hl  #)+                               _         -> (# l_,((hl)+#1#) #)+ sHR hl d (P li ll la lr) = let l_ = sRP ((d)-#2#) li ll la lr+                            in  l_ `seq` (# l_,hl #)++ -- Splice into right subtree of (P i l a r), height cannot change as a result of this+ sRP 0# i l a  r              = Z i l a (Z ib r b t)                                       -- dH=0+ sRP 1# i l a  r              = Z i l a (P ib r b t)                                       -- dH=0+ sRP d    i l a (N ri rl ra rr) = let r_ = sRN ((d)-#1#) ri rl ra rr in r_ `seq` P i l a r_+ sRP d    i l a (Z ri rl ra rr) = let r_ = sRZ ((d)-#1#) ri rl ra rr+                                  in case r_ of+                                     Z _ _ _ _ -> P i l a r_                                 -- dH=0+                                     N _ _ _ _ -> Z i l a r_                                 -- dH=0+                                     _         -> error "spliceHL: Bug2"                     -- impossible+ sRP d    i l a (P ri rl ra rr) = let r_ = sRP ((d)-#2#) ri rl ra rr in r_ `seq` P i l a r_+ sRP _    _ _ _  E              = error "spliceHL: Bug3"                                     -- impossible++ -- Splice into right subtree of (Z i l a r), Z->N if dH=1, Z->Z if dH=0+ sRZ 1# i l a  r           = N i l a (P ib r b t)                                          -- Z->N, dH=1+ sRZ d    i l a (N ri rl ra rr) = let r_ = sRN ((d)-#1#) ri rl ra rr in r_ `seq` Z i l a r_ -- Z->Z, dH=0+ sRZ d    i l a (Z ri rl ra rr) = let r_ = sRZ ((d)-#1#) ri rl ra rr+                                  in case r_ of+                                     Z _ _ _ _ -> Z i l a r_                                 -- Z->Z, dH=0+                                     N _ _ _ _ -> N i l a r_                                 -- Z->N, dH=1+                                     _         -> error "spliceHL: Bug4"                     -- impossible+ sRZ d    i l a (P ri rl ra rr) = let r_ = sRP ((d)-#2#) ri rl ra rr in r_ `seq` Z i l a r_ -- Z->Z, dH=0+ sRZ _    _ _ _  E              = error "spliceHL: Bug5"                                     -- impossible++ -- Splice into right subtree of (N i l a r), height cannot change as a result of this+ sRN 1# i l a (N ri rl ra rr) = Z ri (P i l a rl) ra (Z ib rr b t)                         -- dH=0+ sRN 1# i l a (Z ri rl ra rr) = Z ri (Z i l a rl) ra (Z ib rr b t)                         -- dH=0+ sRN 1# i l a (P ri rl ra rr) = Z ri (Z i l a rl) ra (N ib rr b t)                         -- dH=0+ sRN d    i l a (N ri rl ra rr) = let r_ = sRN ((d)-#1#) ri rl ra rr in r_ `seq` N i l a r_ -- dH=0+ sRN d    i l a (Z ri rl ra rr) = sRNZ ((d)-#1#) i l a ri rl ra rr                          -- dH=0+ sRN d    i l a (P ri rl ra rr) = let r_ = sRP ((d)-#2#) ri rl ra rr in r_ `seq` N i l a r_ -- dH=0+ sRN _    _ _ _  E              = error "spliceHL: Bug6"++ -- Splice into right subtree of (N i l a (Z ri rl ra rr))+ {-# INLINE sRNZ #-}+ sRNZ 1# i l a ri rl ra rr                  = Z ri (Z i l a rl) ra (P ib rr b t)           -- dH=0+ sRNZ d    i l a ri rl ra (N rri rrl rre rrr) = let rr_ = sRN ((d)-#1#) rri rrl rre rrr+                                                in  rr_ `seq` N i l a (Z ri rl ra rr_)       -- dH=0+ sRNZ d    i l a ri rl ra (Z rri rrl rre rrr) = let rr_ = sRZ ((d)-#1#) rri rrl rre rrr     -- dH=0+                                                in case rr_ of+                                                   Z _ _ _ _ -> N i l a (Z ri rl ra rr_)     -- dH=0+                                                   N _ _ _ _ -> Z ri (Z i l a rl) ra rr_     -- dH=0+                                                   _         -> error "spliceHL: Bug7"       -- impossible+ sRNZ d    i l a ri rl ra (P rri rrl rre rrr) = let rr_ = sRP ((d)-#2#) rri rrl rre rrr     -- dH=0+                                                in rr_ `seq` N i l a (Z ri rl ra rr_)+ sRNZ _    _ _ _ _  _  _   E                  = error "spliceHL: Bug8"+-----------------------------------------------------------------------+------------------------- spliceHR Ends Here --------------------------+-----------------------------------------------------------------------+++-- | Push a singleton IntMap to the leftmost position of an IntMap of known height.+-- Returns an IntMap of known height.+-- It_s OK if height is relative, with fixed offset. In this case the height of the result+-- will have the same fixed offset.+pushHL :: IntMap a -> IntMap a -> Int# -> (# IntMap a,Int# #)+pushHL t0 t h = case t of+                E         -> (# t0, ((h)+#1#) #) -- Relative Heights+                N i l a r -> let t_ = potNL i l a r in t_ `seq` (# t_,h #)+                P i l a r -> let t_ = potPL i l a r in t_ `seq` (# t_,h #)+                Z i l a r -> let t_ = potZL i l a r+                             in case t_ of+                                Z _ _ _ _ -> (# t_,         h  #)+                                P _ _ _ _ -> (# t_, ((h)+#1#) #)+                                _         -> error "pushHL: Bug0" -- impossible+ where+ ----------------------------- LEVEL 2 ---------------------------------+ --                      potNL, potZL, potPL                          --+ -----------------------------------------------------------------------++ -- (potNL i l a r): Put t0 in L subtree of (N i l a r), BF=-1 (Never requires rebalancing) , (never returns P)+ potNL i  E              a r = Z i t0 a r                        -- L subtree empty, H:0->1, parent BF:-1-> 0+ potNL i (N li ll la lr) a r = let l_ = potNL li ll la lr        -- L subtree BF<>0, H:h->h, parent BF:-1->-1+                               in l_ `seq` N i l_ a r+ potNL i (P li ll la lr) a r = let l_ = potPL li ll la lr        -- L subtree BF<>0, H:h->h, parent BF:-1->-1+                               in l_ `seq` N i l_ a r+ potNL i (Z li ll la lr) a r = let l_ = potZL li ll la lr        -- L subtree BF= 0, so need to look for changes+                               in case l_ of+                               Z _ _ _ _ -> N i l_ a r           -- L subtree BF:0-> 0, H:h->h  , parent BF:-1->-1+                               P _ _ _ _ -> Z i l_ a r           -- L subtree BF:0->+1, H:h->h+1, parent BF:-1-> 0+                               _         -> error "pushHL: Bug1" -- impossible++ -- (potZL i l a r): Put t0 in L subtree of (Z i l a r), BF= 0  (Never requires rebalancing) , (never returns N)+ potZL i  E              a r = P i t0 a r                        -- L subtree        H:0->1, parent BF: 0->+1+ potZL i (N li ll la lr) a r = let l_ = potNL li ll la lr        -- L subtree BF<>0, H:h->h, parent BF: 0-> 0+                               in l_ `seq` Z i l_ a r+ potZL i (P li ll la lr) a r = let l_ = potPL li ll la lr        -- L subtree BF<>0, H:h->h, parent BF: 0-> 0+                               in l_ `seq` Z i l_ a r+ potZL i (Z li ll la lr) a r = let l_ = potZL li ll la lr        -- L subtree BF= 0, so need to look for changes+                               in case l_ of+                               Z _ _ _ _ -> Z i l_ a r           -- L subtree BF: 0-> 0, H:h->h  , parent BF: 0-> 0+                               N _ _ _ _ -> error "pushHL: Bug2" -- impossible+                               _         -> P i l_ a r           -- L subtree BF: 0->+1, H:h->h+1, parent BF: 0->+1++      -------- This case (PL) may need rebalancing if it goes to LEVEL 3 ---------++ -- (potPL i l a r): Put t0 in L subtree of (P i l a r), BF=+1 , (never returns N)+ potPL _  E              _ _ = error "pushHL: Bug3"       -- impossible if BF=+1+ potPL i (N li ll la lr) a r = let l_ = potNL li ll la lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1+                               in l_ `seq` P i l_ a r+ potPL i (P li ll la lr) a r = let l_ = potPL li ll la lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1+                               in l_ `seq` P i l_ a r+ potPL i (Z li ll la lr) a r = potPLL i li ll la lr a r   -- LL (never returns N)++ ----------------------------- LEVEL 3 ---------------------------------+ --                            potPLL                                 --+ -----------------------------------------------------------------------++ -- (potPLL i li ll la lr a r): Put t0 in LL subtree of (P i (Z li ll la lr) a r) , (never returns N)+ {-# INLINE potPLL #-}+ potPLL i li  E                  la lr a r = Z li t0 la (Z i lr a r) -- r and lr must also be E, special CASE LL!!+ potPLL i li (N lli lll lla llr) la lr a r = let ll_ = potNL lli lll lla llr          -- LL subtree BF<>0, H:h->h, so no change+                                             in ll_ `seq` P i (Z li ll_ la lr) a r+ potPLL i li (P lli lll lla llr) la lr a r = let ll_ = potPL lli lll lla llr          -- LL subtree BF<>0, H:h->h, so no change+                                             in ll_ `seq` P i (Z li ll_ la lr) a r+ potPLL i li (Z lli lll lla llr) la lr a r = let ll_ = potZL lli lll lla llr          -- LL subtree BF= 0, so need to look for changes+                                            in case ll_ of+                                                Z _ _ _ _ -> P i (Z li ll_ la lr) a r -- LL subtree BF: 0-> 0, H:h->h, so no change+                                                N _ _ _ _ -> error "pushHL: Bug4"     -- impossible+                                                _         -> Z li ll_ la (Z i lr a r) -- LL subtree BF: 0->+1, H:h->h+1, parent BF:-1->-2, CASE LL !!+-----------------------------------------------------------------------+-------------------------- pushHL Ends Here ---------------------------+-----------------------------------------------------------------------+++-- | Push a singleton IntMap to the rightmost position of an IntMap of known height.+-- Returns an IntMap of known height.+-- It_s OK if height is relative, with fixed offset. In this case the height of the result+-- will have the same fixed offset.+pushHR :: IntMap a -> Int# -> IntMap a -> (# IntMap a,Int# #)+pushHR t h t0 = case t of+                E         -> (# t0, ((h)+#1#) #) -- Relative Heights+                N i l a r -> let t_ = potNR i l a r in t_ `seq` (# t_,h #)+                P i l a r -> let t_ = potPR i l a r in t_ `seq` (# t_,h #)+                Z i l a r -> let t_ = potZR i l a r+                             in case t_ of+                                Z _ _ _ _ -> (# t_,         h  #)+                                N _ _ _ _ -> (# t_, ((h)+#1#) #)+                                _         -> error "pushHR: Bug0" -- impossible+ where+ ----------------------------- LEVEL 2 ---------------------------------+ --                      potNR, potZR, potPR                          --+ -----------------------------------------------------------------------++ -- (potZR i l a r): Put t0 in R subtree of (Z i l a r), BF= 0 (Never requires rebalancing) , (never returns P)+ potZR i l a  E              = N i l a t0                       -- R subtree        H:0->1, parent BF: 0->-1+ potZR i l a (N ri rl ra rr) = let r_ = potNR ri rl ra rr       -- R subtree BF<>0, H:h->h, parent BF: 0-> 0+                               in r_ `seq` Z i l a r_+ potZR i l a (P ri rl ra rr) = let r_ = potPR ri rl ra rr       -- R subtree BF<>0, H:h->h, parent BF: 0-> 0+                               in r_ `seq` Z i l a r_+ potZR i l a (Z ri rl ra rr) = let r_ = potZR ri rl ra rr       -- R subtree BF= 0, so need to look for changes+                               in case r_ of+                               Z _ _ _ _ -> Z i l a r_          -- R subtree BF: 0-> 0, H:h->h  , parent BF: 0-> 0+                               N _ _ _ _ -> N i l a r_          -- R subtree BF: 0->-1, H:h->h+1, parent BF: 0->-1+                               _         -> error "pushHR: Bug1" -- impossible++ -- (potPR i l a r): Put t0 in R subtree of (P i l a r), BF=+1 (Never requires rebalancing) , (never returns N)+ potPR i l a  E              = Z i l a t0                       -- R subtree empty, H:0->1,     parent BF:+1-> 0+ potPR i l a (N ri rl ra rr) = let r_ = potNR ri rl ra rr       -- R subtree BF<>0, H:h->h,     parent BF:+1->+1+                               in r_ `seq` P i l a r_+ potPR i l a (P ri rl ra rr) = let r_ = potPR ri rl ra rr       -- R subtree BF<>0, H:h->h,     parent BF:+1->+1+                               in r_ `seq` P i l a r_+ potPR i l a (Z ri rl ra rr) = let r_ = potZR ri rl ra rr       -- R subtree BF= 0, so need to look for changes+                               in case r_ of+                               Z _ _ _ _ -> P i l a r_          -- R subtree BF:0-> 0, H:h->h  , parent BF:+1->+1+                               N _ _ _ _ -> Z i l a r_          -- R subtree BF:0->-1, H:h->h+1, parent BF:+1-> 0+                               _         -> error "pushHR: Bug2" -- impossible++      -------- This case (NR) may need rebalancing if it goes to LEVEL 3 ---------++ -- (potNR i l a r): Put t0 in R subtree of (N i l a r), BF=-1 , (never returns P)+ potNR _ _ _  E              = error "pushHR: Bug3"           -- impossible if BF=-1+ potNR i l a (N ri rl ra rr) = let r_ = potNR ri rl ra rr     -- R subtree BF<>0, H:h->h, parent BF:-1->-1+                               in r_ `seq` N i l a r_+ potNR i l a (P ri rl ra rr) = let r_ = potPR ri rl ra rr     -- R subtree BF<>0, H:h->h, parent BF:-1->-1+                               in r_ `seq` N i l a r_+ potNR i l a (Z ri rl ra rr) = potNRR i l a ri rl ra rr       -- RR (never returns P)++ ----------------------------- LEVEL 3 ---------------------------------+ --                            potNRR                                 --+ -----------------------------------------------------------------------++ -- (potNRR i l a ri rl ra rr): Put t0 in RR subtree of (N i l a (Z ri rl ra rr)) , (never returns P)+ {-# INLINE potNRR #-}+ potNRR i l a ri rl ra  E                  = Z ri (Z i l a rl) ra t0               -- l and rl must also be E, special CASE RR!!+ potNRR i l a ri rl ra (N rri rrl rra rrr) = let rr_ = potNR rri rrl rra rrr       -- RR subtree BF<>0, H:h->h, so no change+                                             in rr_ `seq` N i l a (Z ri rl ra rr_)+ potNRR i l a ri rl ra (P rri rrl rra rrr) = let rr_ = potPR rri rrl rra rrr       -- RR subtree BF<>0, H:h->h, so no change+                                             in rr_ `seq` N i l a (Z ri rl ra rr_)+ potNRR i l a ri rl ra (Z rri rrl rra rrr) = let rr_ = potZR rri rrl rra rrr       -- RR subtree BF= 0, so need to look for changes+                                             in case rr_ of+                                             Z _ _ _ _ -> N i l a (Z ri rl ra rr_) -- RR subtree BF: 0-> 0, H:h->h, so no change+                                             N _ _ _ _ -> Z ri (Z i l a rl) ra rr_ -- RR subtree BF: 0->-1, H:h->h+1, parent BF:-1->-2, CASE RR !!+                                             _         -> error "pushHR: Bug4"     -- impossible+-----------------------------------------------------------------------+-------------------------- pushHR Ends Here ---------------------------+-----------------------------------------------------------------------++-- | Delete the association pair with the supplied Key from an IntMap.+-- For use only if it is already known to contain an entry for the supplied key.+-- This function raises an error if there is no such pair.+del :: Key -> IntMap a -> IntMap a+del _   E          = error "del: Key not found."+del k0 (N k l a r) = delN k0 k l a r+del k0 (Z k l a r) = delZ k0 k l a r+del k0 (P k l a r) = delP k0 k l a r++-- | Same as 'del', but takes the (relative) tree height as an extra argument and+-- returns the updated (relative) tree height.+delH :: Key -> Int# -> IntMap a -> (# IntMap a,Int# #)+delH _  _   E          = error "delH: Key not found."+delH k0 ht (N k l a r) = let t_ = delN k0 k l a r in+                         case t_ of+                         Z _ _ _ _ -> (# t_,((ht)-#1#) #)+                         _         -> (# t_,        ht  #)+delH k0 ht (Z k l a r) = let t_ = delZ k0 k l a r in+                         case t_ of+                         E         -> (# t_,((ht)-#1#) #)+                         _         -> (# t_,        ht  #)+delH k0 ht (P k l a r) = let t_ = delP k0 k l a r in+                         case t_ of+                         Z _ _ _ _ -> (# t_,((ht)-#1#) #)+                         _         -> (# t_,        ht  #)++----------------------------- LEVEL 1 ---------------------------------+--                       delN, delZ, delP                            --+-----------------------------------------------------------------------++-- Delete from (N k l a r)+delN :: Key -> Key -> IntMap a -> a -> IntMap a -> IntMap a+delN k0 k l a r = case compareInt# k0 k of+                  LT -> delNL k0 k l a r+                  EQ -> subN       l   r+                  GT -> delNR k0 k l a r++-- Delete from (Z k l a r)+delZ :: Key -> Key -> IntMap a -> a -> IntMap a -> IntMap a+delZ k0 k l a r = case compareInt# k0 k of+                  LT -> delZL k0 k l a r+                  EQ -> subZR      l   r+                  GT -> delZR k0 k l a r++-- Delete from (P k l a r)+delP :: Key -> Key -> IntMap a -> a -> IntMap a -> IntMap a+delP k0 k l a r = case compareInt# k0 k of+                  LT -> delPL k0 k l a r+                  EQ -> subP       l   r+                  GT -> delPR k0 k l a r++----------------------------- LEVEL 2 ---------------------------------+--                      delNL, delZL, delPL                          --+--                      delNR, delZR, delPR                          --+-----------------------------------------------------------------------++-- Delete from the left subtree of (N k l a r)+delNL :: Key -> Key -> IntMap a -> a -> IntMap a -> IntMap a+delNL _  _  E              _ _ = error "assertDelete: Key not found."     -- Left sub-tree is empty+delNL k0 k (N lk ll la lr) a r = case compareInt# k0 lk of+                                 LT -> chkLN k (delNL k0 lk ll la lr) a r+                                 EQ -> chkLN k (subN        ll    lr) a r+                                 GT -> chkLN k (delNR k0 lk ll la lr) a r+delNL k0 k (Z lk ll la lr) a r = case compareInt# k0 lk of+                                 LT -> let l_ = delZL k0 lk ll la lr in l_ `seq` N k l_ a r  -- height can't change+                                 EQ -> chkLN_ k (subZR      ll    lr) a r                    -- << But it can here+                                 GT -> let l_ = delZR k0 lk ll la lr in l_ `seq` N k l_ a r  -- height can't change+delNL k0 k (P lk ll la lr) a r = case compareInt# k0 lk of+                                 LT -> chkLN k (delPL k0 lk ll la lr) a r+                                 EQ -> chkLN k (subP        ll    lr) a r+                                 GT -> chkLN k (delPR k0 lk ll la lr) a r++-- Delete from the right subtree of (N k l a r)+delNR :: Key -> Key -> IntMap a -> a -> IntMap a -> IntMap a+delNR _  _ _ _  E              = error "delNR: Bug0"             -- Impossible+delNR k0 k l a (N rk rl ra rr) = case compareInt# k0 rk of+                                 LT -> chkRN k l a (delNL k0 rk rl ra rr)+                                 EQ -> chkRN k l a (subN        rl    rr)+                                 GT -> chkRN k l a (delNR k0 rk rl ra rr)+delNR k0 k l a (Z rk rl ra rr) = case compareInt# k0 rk of+                                 LT -> let r_ = delZL k0 rk rl ra rr in r_ `seq` N k l a r_   -- height can't change+                                 EQ -> chkRN_ k l a (subZL  rl    rr)                         -- << But it can here+                                 GT -> let r_ = delZR k0 rk rl ra rr in r_ `seq` N k l a r_   -- height can't change+delNR k0 k l a (P rk rl ra rr) = case compareInt# k0 rk of+                                 LT -> chkRN k l a (delPL k0 rk rl ra rr)+                                 EQ -> chkRN k l a (subP        rl    rr)+                                 GT -> chkRN k l a (delPR k0 rk rl ra rr)++-- Delete from the left subtree of (Z k l a r)+delZL :: Key -> Key -> IntMap a -> a -> IntMap a -> IntMap a+delZL _  _  E              _ _ = error "assertDelete: Key not found."  -- Left sub-tree is empty+delZL k0 k (N lk ll la lr) a r = case compareInt# k0 lk of+                                 LT -> chkLZ k (delNL k0 lk ll la lr) a r+                                 EQ -> chkLZ k (subN        ll    lr) a r+                                 GT -> chkLZ k (delNR k0 lk ll la lr) a r+delZL k0 k (Z lk ll la lr) a r = case compareInt# k0 lk of+                                 LT -> let l_ = delZL k0 lk ll la lr in l_ `seq` Z k l_ a r  -- height can't change+                                 EQ -> chkLZ_ k (subZR      ll    lr) a r                    -- << But it can here+                                 GT -> let l_ = delZR k0 lk ll la lr in l_ `seq` Z k l_ a r  -- height can't change+delZL k0 k (P lk ll la lr) a r = case compareInt# k0 lk of+                                 LT -> chkLZ k (delPL k0 lk ll la lr) a r+                                 EQ -> chkLZ k (subP        ll    lr) a r+                                 GT -> chkLZ k (delPR k0 lk ll la lr) a r++-- Delete from the right subtree of (Z k l a r)+delZR :: Key -> Key -> IntMap a -> a -> IntMap a -> IntMap a+delZR _  _ _ _  E              = error "assertDelete: Key not found."      -- Right sub-tree is empty+delZR k0 k l a (N rk rl ra rr) = case compareInt# k0 rk of+                                 LT -> chkRZ k l a (delNL k0 rk rl ra rr)+                                 EQ -> chkRZ k l a (subN        rl    rr)+                                 GT -> chkRZ k l a (delNR k0 rk rl ra rr)+delZR k0 k l a (Z rk rl ra rr) = case compareInt# k0 rk of+                                 LT -> let r_ = delZL k0 rk rl ra rr in r_ `seq` Z k l a r_  -- height can't change+                                 EQ -> chkRZ_ k l a (subZL  rl    rr)                        -- << But it can here+                                 GT -> let r_ = delZR k0 rk rl ra rr in r_ `seq` Z k l a r_  -- height can't change+delZR k0 k l a (P rk rl ra rr) = case compareInt# k0 rk of+                                 LT -> chkRZ k l a (delPL k0 rk rl ra rr)+                                 EQ -> chkRZ k l a (subP        rl    rr)+                                 GT -> chkRZ k l a (delPR k0 rk rl ra rr)++-- Delete from the left subtree of (P k l a r)+delPL :: Key -> Key -> IntMap a -> a -> IntMap a -> IntMap a+delPL _  _  E              _ _ = error "delPL: Bug0"             -- Impossible+delPL k0 k (N lk ll la lr) a r = case compareInt# k0 lk of+                                 LT -> chkLP k (delNL k0 lk ll la lr) a r+                                 EQ -> chkLP k (subN        ll    lr) a r+                                 GT -> chkLP k (delNR k0 lk ll la lr) a r+delPL k0 k (Z lk ll la lr) a r = case compareInt# k0 lk of+                                 LT -> let l_ = delZL k0 lk ll la lr in l_ `seq` P k l_ a r  -- height can't change+                                 EQ -> chkLP_ k (subZR      ll    lr) a r                    -- << But it can here+                                 GT -> let l_ = delZR k0 lk ll la lr in l_ `seq` P k l_ a r  -- height can't change+delPL k0 k (P lk ll la lr) a r = case compareInt# k0 lk of+                                 LT -> chkLP k (delPL k0 lk ll la lr) a r+                                 EQ -> chkLP k (subP        ll    lr) a r+                                 GT -> chkLP k (delPR k0 lk ll la lr) a r++-- Delete from the right subtree of (P l a r)+delPR :: Key -> Key -> IntMap a -> a -> IntMap a -> IntMap a+delPR _  _ _ _  E              = error "assertDelete: Key not found."       -- Right sub-tree is empty+delPR k0 k l a (N rk rl ra rr) = case compareInt# k0 rk of+                                 LT -> chkRP k l a (delNL k0 rk rl ra rr)+                                 EQ -> chkRP k l a (subN        rl    rr)+                                 GT -> chkRP k l a (delNR k0 rk rl ra rr)+delPR k0 k l a (Z rk rl ra rr) = case compareInt# k0 rk of+                                 LT -> let r_ = delZL k0 rk rl ra rr in r_ `seq` P k l a r_  -- height can't change+                                 EQ -> chkRP_ k l a (subZL  rl    rr)                        -- << But it can here+                                 GT -> let r_ = delZR k0 rk rl ra rr in r_ `seq` P k l a r_  -- height can't change+delPR k0 k l a (P rk rl ra rr) = case compareInt# k0 rk of+                                 LT -> chkRP k l a (delPL k0 rk rl ra rr)+                                 EQ -> chkRP k l a (subP        rl    rr)+                                 GT -> chkRP k l a (delPR k0 rk rl ra rr)+-----------------------------------------------------------------------+------------------------- del/delH End Here ---------------------------+-----------------------------------------------------------------------+++-----------------------------------------------------------------------+------------------------ popL Starts Here -----------------------------+-----------------------------------------------------------------------+-------------------------- popL LEVEL 1 -------------------------------+--                      popLN, popLZ, popLP                          --+-----------------------------------------------------------------------+-- Delete leftmost from (N k l a r)+popLN :: Key -> IntMap a -> a -> IntMap a -> (# Key,a,IntMap a #)+popLN k  E              a r = (# k,a,r #)                  -- Terminal case, r must be of form (Z a ra E)+popLN k (N lk ll la lr) a r = case popLN lk ll la lr of+                              (# iv,v,l #) -> let t = chkLN k l a r in  t `seq` (# iv,v,t #)+popLN k (Z lk ll la lr) a r = popLNZ k lk ll la lr a r+popLN k (P lk ll la lr) a r = case popLP lk ll la lr of+                              (# iv,v,l #) -> let t = chkLN k l a r in  t `seq` (# iv,v,t #)++-- Delete leftmost from (Z k l a r)+popLZ :: Key -> IntMap a -> a -> IntMap a -> (# Key,a,IntMap a #)+popLZ k  E              a _ = (# k,a,E #)                  -- Terminal case, r must be E+popLZ k (N lk ll la lr) a r = popLZN k lk ll la lr a r+popLZ k (Z lk ll la lr) a r = popLZZ k lk ll la lr a r+popLZ k (P lk ll la lr) a r = popLZP k lk ll la lr a r++-- Delete leftmost from (P k l a r)+popLP :: Key -> IntMap a -> a -> IntMap a -> (# Key,a,IntMap a #)+popLP _  E              _ _ = error "popLP: Bug!"        -- Impossible if BF=+1+popLP k (N lk ll la lr) a r = case popLN lk ll la lr of+                              (# iv,v,l #) -> let t = chkLP k l a r in  t `seq` (# iv,v,t #)+popLP k (Z lk ll la lr) a r = popLPZ k lk ll la lr a r+popLP k (P lk ll la lr) a r = case popLP lk ll la lr of+                              (# iv,v,l #) -> let t = chkLP k l a r in  t `seq` (# iv,v,t #)++-------------------------- popL LEVEL 2 -------------------------------+--                     popLNZ, popLZZ, popLPZ                        --+--                        popLZN, popLZP                             --+-----------------------------------------------------------------------++-- Delete leftmost from (N k (Z lk ll la lr) a r), height of left sub-tree can't change in this case+popLNZ :: Key -> Key -> IntMap a -> a -> IntMap a -> a -> IntMap a -> (# Key,a,IntMap a #)+{-# INLINE popLNZ #-}+popLNZ k lk  E                  la _  a r = let t = rebalN k E a r        -- Terminal case, Needs rebalancing+                                            in  t `seq` (# lk,la,t #)+popLNZ k lk (N llk lll lla llr) la lr a r = case popLZN lk llk lll lla llr la lr of+                                            (# iv,v,l #) -> (# iv,v,N k l a r #)+popLNZ k lk (Z llk lll lla llr) la lr a r = case popLZZ lk llk lll lla llr la lr of+                                            (# iv,v,l #) -> (# iv,v,N k l a r #)+popLNZ k lk (P llk lll lla llr) la lr a r = case popLZP lk llk lll lla llr la lr of+                                            (# iv,v,l #) -> (# iv,v,N k l a r #)++-- Delete leftmost from (Z k (Z lk ll la lr) a r), height of left sub-tree can't change in this case+-- Don't INLINE this!+popLZZ :: Key -> Key -> IntMap a -> a -> IntMap a -> a -> IntMap a -> (# Key,a,IntMap a #)+popLZZ k lk  E                  la _  a r = (# lk,la,N k E a r #)                     -- Terminal case+popLZZ k lk (N llk lll lla llr) la lr a r = case popLZN lk llk lll lla llr la lr of+                                            (# iv,v,l #) -> (# iv,v,Z k l a r #)+popLZZ k lk (Z llk lll lla llr) la lr a r = case popLZZ lk llk lll lla llr la lr of+                                            (# iv,v,l #) -> (# iv,v,Z k l a r #)+popLZZ k lk (P llk lll lla llr) la lr a r = case popLZP lk llk lll lla llr la lr of+                                            (# iv,v,l #) -> (# iv,v,Z k l a r #)++-- Delete leftmost from (P k (Z lk ll la lr) a r), height of left sub-tree can't change in this case+popLPZ :: Key -> Key -> IntMap a -> a -> IntMap a -> a -> IntMap a -> (# Key,a,IntMap a #)+{-# INLINE popLPZ #-}+popLPZ k lk  E                  la _  a _ = (# lk,la,Z k E a E #)                     -- Terminal case+popLPZ k lk (N llk lll lla llr) la lr a r = case popLZN lk llk lll lla llr la lr of+                                            (# iv,v,l #) -> (# iv,v,P k l a r #)+popLPZ k lk (Z llk lll lla llr) la lr a r = case popLZZ lk llk lll lla llr la lr of+                                            (# iv,v,l #) -> (# iv,v,P k l a r #)+popLPZ k lk (P llk lll lla llr) la lr a r = case popLZP lk llk lll lla llr la lr of+                                            (# iv,v,l #) -> (# iv,v,P k l a r #)++-- Delete leftmost from (Z k (N lk ll la lr) a r)+-- Don't INLINE this!+popLZN :: Key -> Key -> IntMap a -> a -> IntMap a -> a -> IntMap a -> (# Key,a,IntMap a #)+popLZN k lk ll la lr a r = case popLN lk ll la lr of+                           (# iv,v,l #) -> let t = chkLZ k l a r in  t `seq` (# iv,v,t #)+-- Delete leftmost from (Z k (P lk ll la lr) a r)+-- Don't INLINE this!+popLZP :: Key -> Key -> IntMap a -> a -> IntMap a -> a -> IntMap a -> (# Key,a,IntMap a #)+popLZP k lk ll la lr a r = case popLP lk ll la lr of+                           (# iv,v,l #) -> let t = chkLZ k l a r in t `seq` (# iv,v,t #)+-----------------------------------------------------------------------+-------------------------- popL Ends Here -----------------------------+-----------------------------------------------------------------------++++-----------------------------------------------------------------------+------------------------ popR Starts Here -----------------------------+-----------------------------------------------------------------------+-------------------------- popR LEVEL 1 -------------------------------+--                      popRN, popRZ, popRP                          --+-----------------------------------------------------------------------+-- Delete rightmost from (N k l a r)+popRN :: Key -> IntMap a -> a -> IntMap a -> (# IntMap a, Key, a #)+popRN _ _ _  E              = error "popRN: Bug!"        -- Impossible if BF=-1+popRN k l a (N rk rl ra rr) = case popRN rk rl ra rr of+                              (# r,iv,v #) -> let t = chkRN k l a r in t `seq` (# t,iv,v #)+popRN k l a (Z rk rl ra rr) = popRNZ k l a rk rl ra rr+popRN k l a (P rk rl ra rr) = case popRP rk rl ra rr of+                              (# r,iv,v #) -> let t = chkRN k l a r in t `seq` (# t,iv,v #)++-- Delete rightmost from (Z k l a r)+popRZ :: Key -> IntMap a -> a -> IntMap a -> (# IntMap a, Key, a #)+popRZ k _ a  E              = (# E,k,a #)     -- Terminal case, l must be E+popRZ k l a (N rk rl ra rr) = popRZN k l a rk rl ra rr+popRZ k l a (Z rk rl ra rr) = popRZZ k l a rk rl ra rr+popRZ k l a (P rk rl ra rr) = popRZP k l a rk rl ra rr++-- Delete rightmost from (P k l a r)+popRP :: Key -> IntMap a -> a -> IntMap a -> (# IntMap a, Key, a #)+popRP k l a  E              = (# l,k,a #)      -- Terminal case, l must be of form (Z a la E)+popRP k l a (N rk rl ra rr) = case popRN rk rl ra rr of+                              (# r,iv,v #) -> let t = chkRP k l a r in t `seq` (# t,iv,v #)+popRP k l a (Z rk rl ra rr) = popRPZ k l a rk rl ra rr+popRP k l a (P rk rl ra rr) = case popRP rk rl ra rr of+                              (# r,iv,v #) -> let t = chkRP k l a r in t `seq` (# t,iv,v #)++-------------------------- popR LEVEL 2 -------------------------------+--                     popRNZ, popRZZ, popRPZ                        --+--                        popRZN, popRZP                             --+-----------------------------------------------------------------------++-- Delete rightmost from (N k l a (Z rk rl ra rr)), height of right sub-tree can't change in this case+popRNZ :: Key -> IntMap a -> a -> Key -> IntMap a -> a -> IntMap a -> (# IntMap a, Key, a #)+{-# INLINE popRNZ #-}+popRNZ k _ a rk _  ra  E                  = (# Z k E a E,rk,ra #)    -- Terminal case+popRNZ k l a rk rl ra (N rrk rrl rra rrr) = case popRZN rk rl ra rrk rrl rra rrr of+                                            (# r,iv,v #) -> (# N k l a r,iv,v #)+popRNZ k l a rk rl ra (Z rrk rrl rra rrr) = case popRZZ rk rl ra rrk rrl rra rrr of+                                            (# r,iv,v #) -> (# N k l a r,iv,v #)+popRNZ k l a rk rl ra (P rrk rrl rra rrr) = case popRZP rk rl ra rrk rrl rra rrr of+                                            (# r,iv,v #) -> (# N k l a r,iv,v #)++-- Delete rightmost from (Z k l a (Z rk rl ra rr)), height of right sub-tree can't change in this case+-- Don't INLINE this!+popRZZ :: Key -> IntMap a -> a -> Key -> IntMap a -> a -> IntMap a -> (# IntMap a, Key, a #)+popRZZ k l a rk _  ra  E                  = (# P k l a E,rk,ra #)  -- Terminal case+popRZZ k l a rk rl ra (N rrk rrl rra rrr) = case popRZN rk rl ra rrk rrl rra rrr of+                                            (# r,iv,v #) -> (# Z k l a r,iv,v #)+popRZZ k l a rk rl ra (Z rrk rrl rra rrr) = case popRZZ rk rl ra rrk rrl rra rrr of+                                            (# r,iv,v #) -> (# Z k l a r,iv,v #)+popRZZ k l a rk rl ra (P rrk rrl rra rrr) = case popRZP rk rl ra rrk rrl rra rrr of+                                            (# r,iv,v #) -> (# Z k l a r,iv,v #)++-- Delete rightmost from (P k l a (Z rk rl ra rr)), height of right sub-tree can't change in this case+popRPZ :: Key -> IntMap a -> a -> Key -> IntMap a -> a -> IntMap a -> (# IntMap a, Key, a #)+{-# INLINE popRPZ #-}+popRPZ k l a rk _  ra  E                  = let t = rebalP k l a E    -- Terminal case, Needs rebalancing+                                            in  t `seq` (# t,rk,ra #)+popRPZ k l a rk rl ra (N rrk rrl rra rrr) = case popRZN rk rl ra rrk rrl rra rrr of+                                            (# r,iv,v #) -> (# P k l a r,iv,v #)+popRPZ k l a rk rl ra (Z rrk rrl rra rrr) = case popRZZ rk rl ra rrk rrl rra rrr of+                                            (# r,iv,v #) -> (# P k l a r,iv,v #)+popRPZ k l a rk rl ra (P rrk rrl rra rrr) = case popRZP rk rl ra rrk rrl rra rrr of+                                            (# r,iv,v #) -> (# P k l a r,iv,v #)++-- Delete rightmost from (Z k l a (N rk rl ra rr))+-- Don't INLINE this!+popRZN :: Key -> IntMap a -> a -> Key -> IntMap a -> a -> IntMap a -> (# IntMap a, Key, a #)+popRZN k l a rk rl ra rr = case popRN rk rl ra rr of+                           (# r,iv,v #) -> let t = chkRZ k l a r in  t `seq` (# t,iv,v #)++-- Delete rightmost from (Z k l a (P rk rl ra rr))+-- Don't INLINE this!+popRZP :: Key -> IntMap a -> a -> Key -> IntMap a -> a -> IntMap a -> (# IntMap a, Key, a #)+popRZP k l a rk rl ra rr = case popRP rk rl ra rr of+                           (# r,iv,v #) -> let t = chkRZ k l a r in  t `seq` (# t,iv,v #)+-----------------------------------------------------------------------+-------------------------- popR Ends Here -----------------------------+-----------------------------------------------------------------------++++{-************************** Balancing Utilities Below Here ************************************-}++-- Rebalance a tree of form (N k l a r) which has become unbalanced as+-- a result of the height of the left sub-tree (l) decreasing by 1.+-- N.B Result is never of form (N _ _ _ _) (or E!)+rebalN :: Key -> IntMap a -> a -> IntMap a -> IntMap a+rebalN _ _ _  E                               = error "rebalN: Bug0"                     -- impossible case+rebalN k l a (N rk rl                  ra rr) = Z rk (Z k l a rl) ra rr                  -- N->Z, dH=-1+rebalN k l a (Z rk rl                  ra rr) = P rk (N k l a rl) ra rr                  -- N->P, dH= 0+rebalN _ _ _ (P _   E                  _  _ ) = error "rebalN: Bug1"                     -- impossible case+rebalN k l a (P rk (N rlk rll rla rlr) ra rr) = Z rlk (P k l a rll) rla (Z rk rlr ra rr) -- N->Z, dH=-1+rebalN k l a (P rk (Z rlk rll rla rlr) ra rr) = Z rlk (Z k l a rll) rla (Z rk rlr ra rr) -- N->Z, dH=-1+rebalN k l a (P rk (P rlk rll rla rlr) ra rr) = Z rlk (Z k l a rll) rla (N rk rlr ra rr) -- N->Z, dH=-1++-- Rebalance a tree of form (P k l a r) which has become unbalanced as+-- a result of the height of the right sub-tree (r) decreasing by 1.+-- N.B Result is never of form (P _ _ _ _) (or E!)+rebalP :: Key -> IntMap a -> a -> IntMap a -> IntMap a+rebalP _  E                               _ _ = error "rebalP: Bug0"                     -- impossible case+rebalP k (P lk ll la lr                 ) a r = Z lk ll la (Z k lr a r)                  -- P->Z, dH=-1+rebalP k (Z lk ll la lr                 ) a r = N lk ll la (P k lr a r)                  -- P->N, dH= 0+rebalP _ (N _  _  _   E                 ) _ _ = error "rebalP: Bug1"                     -- impossible case+rebalP k (N lk ll la (P lrk lrl lra lrr)) a r = Z lrk (Z lk ll la lrl) lra (N k lrr a r) -- P->Z, dH=-1+rebalP k (N lk ll la (Z lrk lrl lra lrr)) a r = Z lrk (Z lk ll la lrl) lra (Z k lrr a r) -- P->Z, dH=-1+rebalP k (N lk ll la (N lrk lrl lra lrr)) a r = Z lrk (P lk ll la lrl) lra (Z k lrr a r) -- P->Z, dH=-1++-- Check for height changes in left subtree of (N k l a r),+-- where l was (N lk ll la lr) or (P lk ll la lr)+chkLN :: Key -> IntMap a -> a -> IntMap a -> IntMap a+chkLN k l a r = case l of+                E         -> error "chkLN: Bug0"     -- impossible if BF<>0+                N _ _ _ _ -> N k l a r               -- BF +/-1 -> -1, so dH= 0+                Z _ _ _ _ -> rebalN k l a r          -- BF +/-1 ->  0, so dH=-1+                P _ _ _ _ -> N k l a r               -- BF +/-1 -> +1, so dH= 0+-- Check for height changes in left subtree of (Z k l a r),+-- where l was (N lk ll la lr) or (P lk ll la lr)+chkLZ :: Key -> IntMap a -> a -> IntMap a -> IntMap a+chkLZ k l a r = case l of+                E         -> error "chkLZ: Bug0"   -- impossible if BF<>0+                N _ _ _ _ -> Z k l a r             -- BF +/-1 -> -1, so dH= 0+                Z _ _ _ _ -> N k l a r             -- BF +/-1 ->  0, so dH=-1+                P _ _ _ _ -> Z k l a r             -- BF +/-1 -> +1, so dH= 0+-- Check for height changes in left subtree of (P k l a r),+-- where l was (N lk ll la lr) or (P lk ll la lr)+chkLP :: Key -> IntMap a -> a -> IntMap a -> IntMap a+chkLP k l a r = case l of+                E         -> error "chkLP: Bug0"   -- impossible if BF<>0+                N _ _ _ _ -> P k l a r             -- BF +/-1 -> -1, so dH= 0+                Z _ _ _ _ -> Z k l a r             -- BF +/-1 ->  0, so dH=-1+                P _ _ _ _ -> P k l a r             -- BF +/-1 -> +1, so dH= 0+-- Check for height changes in right subtree of (N k l a r),+-- where r was (N rk rl ra rr) or (P rk rl ra rr)+chkRN :: Key -> IntMap a -> a -> IntMap a -> IntMap a+chkRN k l a r = case r of+                E         -> error "chkRN: Bug0"     -- impossible if BF<>0+                N _ _ _ _ -> N k l a r               -- BF +/-1 -> -1, so dH= 0+                Z _ _ _ _ -> Z k l a r               -- BF +/-1 ->  0, so dH=-1+                P _ _ _ _ -> N k l a r               -- BF +/-1 -> +1, so dH= 0+-- Check for height changes in right subtree of (Z k l a r),+-- where r was (N rk rl ra rr) or (P rk rl ra rr)+chkRZ :: Key -> IntMap a -> a -> IntMap a -> IntMap a+chkRZ k l a r = case r of+                E         -> error "chkRZ: Bug0"    -- impossible if BF<>0+                N _ _ _ _ -> Z k l a r              -- BF +/-1 -> -1, so dH= 0+                Z _ _ _ _ -> P k l a r              -- BF +/-1 ->  0, so dH=-1+                P _ _ _ _ -> Z k l a r              -- BF +/-1 -> +1, so dH= 0+-- Check for height changes in right subtree of (P k l a r),+-- where l was (N rk rl ra rr) or (P rk rl ra rr)+chkRP :: Key -> IntMap a -> a -> IntMap a -> IntMap a+chkRP k l a r = case r of+                E         -> error "chkRP: Bug0"    -- impossible if BF<>0+                N _ _ _ _ -> P k l a r              -- BF +/-1 -> -1, so dH= 0+                Z _ _ _ _ -> rebalP k l a r         -- BF +/-1 ->  0, so dH=-1+                P _ _ _ _ -> P k l a r              -- BF +/-1 -> +1, so dH= 0+++-- Substitute deleted element from (N _ l _ r)+subN :: IntMap a -> IntMap a -> IntMap a+subN _  E               = error "subN: Bug0"      -- Impossible+subN l (N rk rl ra rr)  = case popLN rk rl ra rr of (# iv,v,r_ #) -> chkRN  iv l v r_+subN l (Z rk rl ra rr)  = case popLZ rk rl ra rr of (# iv,v,r_ #) -> chkRN_ iv l v r_+subN l (P rk rl ra rr)  = case popLP rk rl ra rr of (# iv,v,r_ #) -> chkRN  iv l v r_++-- Substitute deleted element from (Z _ l _ r)+-- Pops the replacement from the right sub-tree, so result may be (P _ _ _)+subZR :: IntMap a -> IntMap a -> IntMap a+subZR _  E               = E   -- Both left and right subtrees must have been empty+subZR l (N rk rl ra rr)  = case popLN rk rl ra rr of (# iv,v,r_ #) -> chkRZ  iv l v r_+subZR l (Z rk rl ra rr)  = case popLZ rk rl ra rr of (# iv,v,r_ #) -> chkRZ_ iv l v r_+subZR l (P rk rl ra rr)  = case popLP rk rl ra rr of (# iv,v,r_ #) -> chkRZ  iv l v r_++-- Local utility to substitute deleted element from (Z _ l _ r)+-- Pops the replacement from the left sub-tree, so result may be (N _ _ _)+subZL :: IntMap a -> IntMap a -> IntMap a+subZL  E              _  = E   -- Both left and right subtrees must have been empty+subZL (N lk ll la lr) r  = case popRN lk ll la lr of (# l_,iv,v #) -> chkLZ  iv l_ v r+subZL (Z lk ll la lr) r  = case popRZ lk ll la lr of (# l_,iv,v #) -> chkLZ_ iv l_ v r+subZL (P lk ll la lr) r  = case popRP lk ll la lr of (# l_,iv,v #) -> chkLZ  iv l_ v r++-- Substitute deleted element from (P _ l _ r)+subP :: IntMap a -> IntMap a -> IntMap a+subP  E              _  = error "subP: Bug0"      -- Impossible+subP (N lk ll la lr) r  = case popRN lk ll la lr of (# l_,iv,v #) -> chkLP  iv l_ v r+subP (Z lk ll la lr) r  = case popRZ lk ll la lr of (# l_,iv,v #) -> chkLP_ iv l_ v r+subP (P lk ll la lr) r  = case popRP lk ll la lr of (# l_,iv,v #) -> chkLP  iv l_ v r++-- Check for height changes in left subtree of (N k l a r),+-- where l was (Z lk ll la lr)+chkLN_ :: Key -> IntMap a -> a -> IntMap a -> IntMap a+chkLN_ k l a r = case l of+                 E       -> rebalN k l a r  -- BF 0 -> E, so dH=-1+                 _       -> N k l a r       -- Otherwise dH=0+-- Check for height changes in left subtree of (Z k l a r),+-- where l was (Z lk ll la lr)+chkLZ_ :: Key -> IntMap a -> a -> IntMap a -> IntMap a+chkLZ_ k l a r = case l of+                 E       -> N k l a r      -- BF 0 -> E, so dH=-1+                 _       -> Z k l a r      -- Otherwise dH=0+-- Check for height changes in left subtree of (P k l a r),+-- where l was (Z lk ll la lr)+chkLP_ :: Key -> IntMap a -> a -> IntMap a -> IntMap a+chkLP_ k l a r = case l of+                 E       -> Z k l a r      -- BF 0 -> E, so dH=-1+                 _       -> P k l a r      -- Otherwise dH=0+-- Check for height changes in right subtree of (N k l a r),+-- where r was (Z lk rl ra rr)+chkRN_ :: Key -> IntMap a -> a -> IntMap a -> IntMap a+chkRN_ k l a r = case r of+                 E       -> Z k l a r      -- BF 0 -> E, so dH=-1+                 _       -> N k l a r      -- Otherwise dH=0+-- Check for height changes in right subtree of (Z k l a r),+-- where r was (Z lk rl ra rr)+chkRZ_ :: Key -> IntMap a -> a -> IntMap a -> IntMap a+chkRZ_ k l a r = case r of+                 E       -> P k l a r      -- BF 0 -> E, so dH=-1+                 _       -> Z k l a r      -- Otherwise dH=0+-- Check for height changes in right subtree of (P k l a r),+-- where l was (Z lk rl ra rr)+chkRP_ :: Key -> IntMap a -> a -> IntMap a -> IntMap a+chkRP_ k l a r = case r of+                 E       -> rebalP k l a r -- BF 0 -> E, so dH=-1+                 _       -> P k l a r      -- Otherwise dH=0++--------------------------------------------------------------------------+--                         OTHER INSTANCES                              --+--------------------------------------------------------------------------++--------+-- Eq --+--------+instance (Eq a) => Eq (IntMap a) where+ imp0 == imp1 = asIAList imp0 == asIAList imp1++---------+-- Ord --+---------+instance Ord a => Ord (IntMap a) where+ compare imp0 imp1 = compare (asIAList imp0) (asIAList imp1)++----------+-- Show --+----------+instance Show a => Show (IntMap a) where+  showsPrec d mp  = showParen (d > 10) $+    showString "fromAssocsAsc " . shows (assocsAsc mp)++----------+-- Read --+----------++instance R.Read a => R.Read (IntMap a) where+ readPrec = R.parens $ R.prec 10 $ do R.Ident "fromAssocsAsc" <- R.lexP+                                      xs <- R.readPrec+                                      return (fromAssocsAsc xs)+ readListPrec = R.readListPrecDefault++++++++------------------------+-- Typeable/Typeable1 --+------------------------+instance Typeable1 IntMap where+ typeOf1 _ = mkTyConApp (mkTyCon "Data.GMap.IntMap.IntMap") []+--------------+instance Typeable a => Typeable (IntMap a) where+ typeOf = typeOfDefault++-------------+-- Functor --+-------------+instance Functor IntMap where+-- fmap :: (a -> b) -> IntMap a -> IntMap b+   fmap = mapIntMap -- The lazy version++-----------------+-- Data.Monoid --+-----------------+instance M.Monoid a => M.Monoid (IntMap a) where+-- mempty :: IntMap a+   mempty = emptyIntMap+-- mappend :: IntMap a -> IntMap a -> IntMap a+   mappend map0 map1 = unionIntMap M.mappend map0 map1+-- mconcat :: [IntMap a] -> IntMap a+   mconcat maps = L.foldr (unionIntMap M.mappend) emptyIntMap maps++-------------------+-- Data.Foldable --+-------------------+instance F.Foldable IntMap where+-- fold :: Monoid m => IntMap m -> m+   fold mp = foldElemsAscIntMap M.mappend M.mempty mp+-- foldMap :: Monoid m => (a -> m) -> IntMap a -> m+   foldMap f mp = foldElemsAscIntMap (\a b -> M.mappend (f a) b) M.mempty mp+-- foldr :: (a -> b -> b) -> b -> IntMap a -> b+   foldr f b0 mp = foldElemsAscIntMap f b0 mp+-- foldl :: (a -> b -> a) -> a -> IntMap b -> a+   foldl f b0 mp = foldElemsDescIntMap (flip f) b0 mp+{- ToDo: Implement properly. Meantime Foldable class has suitable defaults via lists.+-- fold1 :: (a -> a -> a) -> IntMap a -> a+   fold1 = undefined+-- foldl1 :: (a -> a -> a) -> IntMap a -> a+   foldl1 = undefined+-}++{- ??+data IntMap a = E                                              -- ^ Empty IntMap+             | N {-# UNPACK #-} !Key (IntMap a) a (IntMap a)    -- ^ BF=-1 (right height > left height)+             | Z {-# UNPACK #-} !Key (IntMap a) a (IntMap a)    -- ^ BF= 0+             | P {-# UNPACK #-} !Key (IntMap a) a (IntMap a)    -- ^ BF=+1 (left height > right height)+-}++++---- ToDo: Tidy This Stuff up later --+vennIntMap :: (a -> b -> c) -> IntMap a -> IntMap b -> (IntMap a, IntMap c, IntMap b)+vennIntMap f = gu where -- This is to avoid O(log n) height calculation for empty sets+ gu     E            t1             = (E ,E,t1)+ gu t0                   E          = (t0,E,E )+ gu t0@(N _ l0 _ _ ) t1@(N _ l1 _ _ ) = gu_ t0 (addHeight 2# l0) t1 (addHeight 2# l1)+ gu t0@(N _ l0 _ _ ) t1@(Z _ l1 _ _ ) = gu_ t0 (addHeight 2# l0) t1 (addHeight 1# l1)+ gu t0@(N _ l0 _ _ ) t1@(P _ _  _ r1) = gu_ t0 (addHeight 2# l0) t1 (addHeight 2# r1)+ gu t0@(Z _ l0 _ _ ) t1@(N _ l1 _ _ ) = gu_ t0 (addHeight 1# l0) t1 (addHeight 2# l1)+ gu t0@(Z _ l0 _ _ ) t1@(Z _ l1 _ _ ) = gu_ t0 (addHeight 1# l0) t1 (addHeight 1# l1)+ gu t0@(Z _ l0 _ _ ) t1@(P _ _  _ r1) = gu_ t0 (addHeight 1# l0) t1 (addHeight 2# r1)+ gu t0@(P _ _  _ r0) t1@(N _ l1 _ _ ) = gu_ t0 (addHeight 2# r0) t1 (addHeight 2# l1)+ gu t0@(P _ _  _ r0) t1@(Z _ l1 _ _ ) = gu_ t0 (addHeight 2# r0) t1 (addHeight 1# l1)+ gu t0@(P _ _  _ r0) t1@(P _ _  _ r1) = gu_ t0 (addHeight 2# r0) t1 (addHeight 2# r1)+ gu_ t0 h0 t1 h1 = case vennH f Empt 0# t0 h0 t1 h1 of+                   (# tab,_,cs,cl,tba,_ #) -> case subst (rep (I# cl)) cs of (# tc,_ #) -> (tab,tc,tba)++vennH :: (a -> b -> c) -> IAList c -> Int# -> IntMap a -> Int# -> IntMap b -> Int# -> (# IntMap a,Int#,IAList c,Int#,IntMap b,Int# #)+vennH f = v where+ -- v :: IAList c -> Int# -> IntMap a -> Int# -> IntMap b -> Int# -> (# IntMap a,Int#,IAList c,Int#,IntMap b,Int# #)+ v cs cl  E          ha  tb         hb = (# E ,ha,cs,cl,tb,hb #)+ v cs cl  ta         ha  E          hb = (# ta,ha,cs,cl,E ,hb #)+ v cs cl (N ka la a ra) ha (N kb lb b rb) hb = v_ cs cl ka la (ha-#2#) a ra (ha-#1#) kb lb (hb-#2#) b rb (hb-#1#)+ v cs cl (N ka la a ra) ha (Z kb lb b rb) hb = v_ cs cl ka la (ha-#2#) a ra (ha-#1#) kb lb (hb-#1#) b rb (hb-#1#)+ v cs cl (N ka la a ra) ha (P kb lb b rb) hb = v_ cs cl ka la (ha-#2#) a ra (ha-#1#) kb lb (hb-#1#) b rb (hb-#2#)+ v cs cl (Z ka la a ra) ha (N kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#1#) kb lb (hb-#2#) b rb (hb-#1#)+ v cs cl (Z ka la a ra) ha (Z kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#1#) kb lb (hb-#1#) b rb (hb-#1#)+ v cs cl (Z ka la a ra) ha (P kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#1#) kb lb (hb-#1#) b rb (hb-#2#)+ v cs cl (P ka la a ra) ha (N kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#2#) kb lb (hb-#2#) b rb (hb-#1#)+ v cs cl (P ka la a ra) ha (Z kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#2#) kb lb (hb-#1#) b rb (hb-#1#)+ v cs cl (P ka la a ra) ha (P kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#2#) kb lb (hb-#1#) b rb (hb-#2#)+ v_ cs cl ka la hla a ra hra kb lb hlb b rb hrb =+  case compareInt# ka kb of+  -- a < b, so (la < a < b) & (a < b < rb)+  LT ->                                 case forkVenn ka lb hlb of+   (# llb,hllb,mybb,rlb,hrlb #)      -> case forkVenn kb ra hra of+    (# lra,hlra,myba,rra,hrra #)     ->+     -- (la + llb) < a < (lra + rlb) < b < (rra + rb)+                                           case v cs cl rra hrra rb hrb of+     (# rab,hrab,cs0,cl0,rba,hrba #)    -> case (case myba of+                                                 Nothing -> case v         cs0   cl0      lra hlra rlb hrlb of+                                                  (# mab,hmab,cs1,cl1,mba,hmba #) -> case spliceH kb mba hmba b rba hrba of+                                                   (# mrba,hmrba #)               -> (# mab,hmab,cs1,cl1,mrba,hmrba #)+                                                 Just a_ -> case (let c = f a_ b+                                                                  in v (Cons kb c cs0) (cl0+#1#) lra hlra rlb hrlb+                                                                 ) of+                                                  (# mab,hmab,cs1,cl1,mba,hmba #) -> case joinH   mba hmba   rba hrba of+                                                   (# mrba,hmrba #)               -> (# mab,hmab,cs1,cl1,mrba,hmrba #)+                                                ) of+      (# mab,hmab,cs1,cl1,mrba,hmrba #) -> case joinH mab hmab rab hrab of+       (# mrab,hmrab #)                 -> case (case mybb of+                                                 Nothing -> case v         cs1   cl1      la hla llb hllb of+                                                  (# lab,hlab,cs2,cl2,lba,hlba #) -> case spliceH ka lab hlab a mrab hmrab of+                                                   (# ab,hab #)                   -> (# ab,hab,cs2,cl2,lba,hlba #)+                                                 Just b_ -> case (let c = f a b_+                                                                  in v (Cons ka c cs1) (cl1+#1#) la hla llb hllb+                                                                 ) of+                                                  (# lab,hlab,cs2,cl2,lba,hlba #) -> case joinH   lab hlab   mrab hmrab of+                                                   (# ab,hab #)                   -> (# ab,hab,cs2,cl2,lba,hlba #)+                                                ) of+        (# ab,hab,cs2,cl2,lba,hlba #)   -> case joinH lba hlba mrba hmrba of+         (# ba,hba #)                   -> (# ab,hab,cs2,cl2,ba,hba #)+  -- a = b+  EQ ->                                case v    cs           cl   ra hra rb hrb of+   (# rab,hrab,cs0,cl0,rba,hrba #)  -> case (let c = f a b+                                             in v (Cons ka c cs0) (cl0+#1#) la hla lb hlb+                                            ) of+    (# lab,hlab,cs1,cl1,lba,hlba #) -> case joinH lab hlab rab hrab of+     (# ab,hab #)                   -> case joinH lba hlba rba hrba of+      (# ba,hba #)                  -> (# ab,hab,cs1,cl1,ba,hba #)+  -- b < a, so (lb < b < a) & (b < a < ra)+  GT ->                                  case forkVenn ka rb hrb of+   (# lrb,hlrb,mybb,rrb,hrrb #)       -> case forkVenn kb la hla of+    (# lla,hlla,myba,rla,hrla #)      ->+     -- (lla + lb) < b < (rla + lrb) < a < (ra + rrb)+                                            case v cs cl ra hra rrb hrrb of+     (# rab,hrab,cs0,cl0,rba,hrba #)     -> case (case mybb of+                                                  Nothing -> case v         cs0   cl0      rla hrla lrb hlrb of+                                                   (# mab,hmab,cs1,cl1,mba,hmba #) -> case spliceH ka mab hmab a rab hrab of+                                                    (# mrab,hmrab #)               -> (# mrab,hmrab,cs1,cl1,mba,hmba #)+                                                  Just b_ -> case (let c = f a b_+                                                                   in v (Cons ka c cs0) (cl0+#1#) rla hrla lrb hlrb+                                                                  ) of+                                                   (# mab,hmab,cs1,cl1,mba,hmba #) -> case joinH   mab hmab   rab hrab of+                                                    (# mrab,hmrab #)               -> (# mrab,hmrab,cs1,cl1,mba,hmba #)+                                                 ) of+      (# mrab,hmrab,cs1,cl1,mba,hmba #)  -> case joinH mba hmba rba hrba of+       (# mrba,hmrba #)                  -> case (case myba of+                                                  Nothing -> case v         cs1   cl1      lla hlla lb hlb of+                                                   (# lab,hlab,cs2,cl2,lba,hlba #) -> case spliceH kb lba hlba b mrba hmrba of+                                                    (# ba,hba #)                   -> (# lab,hlab,cs2,cl2,ba,hba #)+                                                  Just a_ -> case (let c = f a_ b+                                                                   in v (Cons kb c cs1) (cl1+#1#) lla hlla lb hlb+                                                                  ) of+                                                   (# lab,hlab,cs2,cl2,lba,hlba #) -> case joinH   lba hlba   mrba hmrba of+                                                    (# ba,hba #)                   -> (# lab,hlab,cs2,cl2,ba,hba #)+                                                 ) of+        (# lab,hlab,cs2,cl2,ba,hba #)    -> case joinH lab hlab mrab hmrab of+         (# ab,hab #)                    -> (# ab,hab,cs2,cl2,ba,hba #)+-----------------------------------------------------------------------+-------------------------- vennH Ends Here ----------------------------+-----------------------------------------------------------------------++vennIntMap' :: (a -> b -> c) -> IntMap a -> IntMap b -> (IntMap a, IntMap c, IntMap b)+vennIntMap' f = gu where -- This is to avoid O(log n) height calculation for empty sets+ gu     E            t1             = (E ,E,t1)+ gu t0                   E          = (t0,E,E )+ gu t0@(N _ l0 _ _ ) t1@(N _ l1 _ _ ) = gu_ t0 (addHeight 2# l0) t1 (addHeight 2# l1)+ gu t0@(N _ l0 _ _ ) t1@(Z _ l1 _ _ ) = gu_ t0 (addHeight 2# l0) t1 (addHeight 1# l1)+ gu t0@(N _ l0 _ _ ) t1@(P _ _  _ r1) = gu_ t0 (addHeight 2# l0) t1 (addHeight 2# r1)+ gu t0@(Z _ l0 _ _ ) t1@(N _ l1 _ _ ) = gu_ t0 (addHeight 1# l0) t1 (addHeight 2# l1)+ gu t0@(Z _ l0 _ _ ) t1@(Z _ l1 _ _ ) = gu_ t0 (addHeight 1# l0) t1 (addHeight 1# l1)+ gu t0@(Z _ l0 _ _ ) t1@(P _ _  _ r1) = gu_ t0 (addHeight 1# l0) t1 (addHeight 2# r1)+ gu t0@(P _ _  _ r0) t1@(N _ l1 _ _ ) = gu_ t0 (addHeight 2# r0) t1 (addHeight 2# l1)+ gu t0@(P _ _  _ r0) t1@(Z _ l1 _ _ ) = gu_ t0 (addHeight 2# r0) t1 (addHeight 1# l1)+ gu t0@(P _ _  _ r0) t1@(P _ _  _ r1) = gu_ t0 (addHeight 2# r0) t1 (addHeight 2# r1)+ gu_ t0 h0 t1 h1 = case vennH' f Empt 0# t0 h0 t1 h1 of+                   (# tab,_,cs,cl,tba,_ #) -> case subst (rep (I# cl)) cs of (# tc,_ #) -> (tab,tc,tba)+-- Strict version of vennH+vennH' :: (a -> b -> c) -> IAList c -> Int# -> IntMap a -> Int# -> IntMap b -> Int# -> (# IntMap a,Int#,IAList c,Int#,IntMap b,Int# #)+vennH' f = v where+ -- v :: IAList c -> Int# -> IntMap a -> Int# -> IntMap b -> Int# -> (# IntMap a,Int#,IAList c,Int#,IntMap b,Int# #)+ v cs cl  E          ha  tb         hb = (# E ,ha,cs,cl,tb,hb #)+ v cs cl  ta         ha  E          hb = (# ta,ha,cs,cl,E ,hb #)+ v cs cl (N ka la a ra) ha (N kb lb b rb) hb = v_ cs cl ka la (ha-#2#) a ra (ha-#1#) kb lb (hb-#2#) b rb (hb-#1#)+ v cs cl (N ka la a ra) ha (Z kb lb b rb) hb = v_ cs cl ka la (ha-#2#) a ra (ha-#1#) kb lb (hb-#1#) b rb (hb-#1#)+ v cs cl (N ka la a ra) ha (P kb lb b rb) hb = v_ cs cl ka la (ha-#2#) a ra (ha-#1#) kb lb (hb-#1#) b rb (hb-#2#)+ v cs cl (Z ka la a ra) ha (N kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#1#) kb lb (hb-#2#) b rb (hb-#1#)+ v cs cl (Z ka la a ra) ha (Z kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#1#) kb lb (hb-#1#) b rb (hb-#1#)+ v cs cl (Z ka la a ra) ha (P kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#1#) kb lb (hb-#1#) b rb (hb-#2#)+ v cs cl (P ka la a ra) ha (N kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#2#) kb lb (hb-#2#) b rb (hb-#1#)+ v cs cl (P ka la a ra) ha (Z kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#2#) kb lb (hb-#1#) b rb (hb-#1#)+ v cs cl (P ka la a ra) ha (P kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#2#) kb lb (hb-#1#) b rb (hb-#2#)+ v_ cs cl ka la hla a ra hra kb lb hlb b rb hrb =+  case compareInt# ka kb of+  -- a < b, so (la < a < b) & (a < b < rb)+  LT ->                                 case forkVenn ka lb hlb of+   (# llb,hllb,mybb,rlb,hrlb #)      -> case forkVenn kb ra hra of+    (# lra,hlra,myba,rra,hrra #)     ->+     -- (la + llb) < a < (lra + rlb) < b < (rra + rb)+                                           case v cs cl rra hrra rb hrb of+     (# rab,hrab,cs0,cl0,rba,hrba #)    -> case (case myba of+                                                 Nothing -> case v         cs0   cl0      lra hlra rlb hrlb of+                                                  (# mab,hmab,cs1,cl1,mba,hmba #) -> case spliceH kb mba hmba b rba hrba of+                                                   (# mrba,hmrba #)               -> (# mab,hmab,cs1,cl1,mrba,hmrba #)+                                                 Just a_ -> case (let c = f a_ b+                                                                  in c `seq` v (Cons kb c cs0) (cl0+#1#) lra hlra rlb hrlb+                                                                 ) of+                                                  (# mab,hmab,cs1,cl1,mba,hmba #) -> case joinH   mba hmba   rba hrba of+                                                   (# mrba,hmrba #)               -> (# mab,hmab,cs1,cl1,mrba,hmrba #)+                                                ) of+      (# mab,hmab,cs1,cl1,mrba,hmrba #) -> case joinH mab hmab rab hrab of+       (# mrab,hmrab #)                 -> case (case mybb of+                                                 Nothing -> case v         cs1   cl1      la hla llb hllb of+                                                  (# lab,hlab,cs2,cl2,lba,hlba #) -> case spliceH ka lab hlab a mrab hmrab of+                                                   (# ab,hab #)                   -> (# ab,hab,cs2,cl2,lba,hlba #)+                                                 Just b_ -> case (let c = f a b_+                                                                  in c `seq` v (Cons ka c cs1) (cl1+#1#) la hla llb hllb+                                                                 ) of+                                                  (# lab,hlab,cs2,cl2,lba,hlba #) -> case joinH   lab hlab   mrab hmrab of+                                                   (# ab,hab #)                   -> (# ab,hab,cs2,cl2,lba,hlba #)+                                                ) of+        (# ab,hab,cs2,cl2,lba,hlba #)   -> case joinH lba hlba mrba hmrba of+         (# ba,hba #)                   -> (# ab,hab,cs2,cl2,ba,hba #)+  -- a = b+  EQ ->                                case v    cs           cl   ra hra rb hrb of+   (# rab,hrab,cs0,cl0,rba,hrba #)  -> case (let c = f a b+                                             in c `seq` v (Cons ka c cs0) (cl0+#1#) la hla lb hlb+                                            ) of+    (# lab,hlab,cs1,cl1,lba,hlba #) -> case joinH lab hlab rab hrab of+     (# ab,hab #)                   -> case joinH lba hlba rba hrba of+      (# ba,hba #)                  -> (# ab,hab,cs1,cl1,ba,hba #)+  -- b < a, so (lb < b < a) & (b < a < ra)+  GT ->                                  case forkVenn ka rb hrb of+   (# lrb,hlrb,mybb,rrb,hrrb #)       -> case forkVenn kb la hla of+    (# lla,hlla,myba,rla,hrla #)      ->+     -- (lla + lb) < b < (rla + lrb) < a < (ra + rrb)+                                            case v cs cl ra hra rrb hrrb of+     (# rab,hrab,cs0,cl0,rba,hrba #)     -> case (case mybb of+                                                  Nothing -> case v         cs0   cl0      rla hrla lrb hlrb of+                                                   (# mab,hmab,cs1,cl1,mba,hmba #) -> case spliceH ka mab hmab a rab hrab of+                                                    (# mrab,hmrab #)               -> (# mrab,hmrab,cs1,cl1,mba,hmba #)+                                                  Just b_ -> case (let c = f a b_+                                                                   in c `seq` v (Cons ka c cs0) (cl0+#1#) rla hrla lrb hlrb+                                                                  ) of+                                                   (# mab,hmab,cs1,cl1,mba,hmba #) -> case joinH   mab hmab   rab hrab of+                                                    (# mrab,hmrab #)               -> (# mrab,hmrab,cs1,cl1,mba,hmba #)+                                                 ) of+      (# mrab,hmrab,cs1,cl1,mba,hmba #)  -> case joinH mba hmba rba hrba of+       (# mrba,hmrba #)                  -> case (case myba of+                                                  Nothing -> case v         cs1   cl1      lla hlla lb hlb of+                                                   (# lab,hlab,cs2,cl2,lba,hlba #) -> case spliceH kb lba hlba b mrba hmrba of+                                                    (# ba,hba #)                   -> (# lab,hlab,cs2,cl2,ba,hba #)+                                                  Just a_ -> case (let c = f a_ b+                                                                   in c `seq` v (Cons kb c cs1) (cl1+#1#) lla hlla lb hlb+                                                                  ) of+                                                   (# lab,hlab,cs2,cl2,lba,hlba #) -> case joinH   lba hlba   mrba hmrba of+                                                    (# ba,hba #)                   -> (# lab,hlab,cs2,cl2,ba,hba #)+                                                 ) of+        (# lab,hlab,cs2,cl2,ba,hba #)    -> case joinH lab hlab mrab hmrab of+         (# ab,hab #)                    -> (# ab,hab,cs2,cl2,ba,hba #)+-----------------------------------------------------------------------+-------------------------- vennH' Ends Here ---------------------------+-----------------------------------------------------------------------+++vennMaybeIntMap :: (a -> b -> Maybe c) -> IntMap a -> IntMap b -> (IntMap a, IntMap c, IntMap b)+vennMaybeIntMap f = gu where -- This is to avoid O(log n) height calculation for empty sets+ gu     E            t1             = (E ,E,t1)+ gu t0                   E          = (t0,E,E )+ gu t0@(N _ l0 _ _ ) t1@(N _ l1 _ _ ) = gu_ t0 (addHeight 2# l0) t1 (addHeight 2# l1)+ gu t0@(N _ l0 _ _ ) t1@(Z _ l1 _ _ ) = gu_ t0 (addHeight 2# l0) t1 (addHeight 1# l1)+ gu t0@(N _ l0 _ _ ) t1@(P _ _  _ r1) = gu_ t0 (addHeight 2# l0) t1 (addHeight 2# r1)+ gu t0@(Z _ l0 _ _ ) t1@(N _ l1 _ _ ) = gu_ t0 (addHeight 1# l0) t1 (addHeight 2# l1)+ gu t0@(Z _ l0 _ _ ) t1@(Z _ l1 _ _ ) = gu_ t0 (addHeight 1# l0) t1 (addHeight 1# l1)+ gu t0@(Z _ l0 _ _ ) t1@(P _ _  _ r1) = gu_ t0 (addHeight 1# l0) t1 (addHeight 2# r1)+ gu t0@(P _ _  _ r0) t1@(N _ l1 _ _ ) = gu_ t0 (addHeight 2# r0) t1 (addHeight 2# l1)+ gu t0@(P _ _  _ r0) t1@(Z _ l1 _ _ ) = gu_ t0 (addHeight 2# r0) t1 (addHeight 1# l1)+ gu t0@(P _ _  _ r0) t1@(P _ _  _ r1) = gu_ t0 (addHeight 2# r0) t1 (addHeight 2# r1)+ gu_ t0 h0 t1 h1 = case vennMaybeH f Empt 0# t0 h0 t1 h1 of+                   (# tab,_,cs,cl,tba,_ #) -> case subst (rep (I# cl)) cs of (# tc,_ #) -> (tab,tc,tba)+vennMaybeH :: (a -> b -> Maybe c) -> IAList c -> Int# -> IntMap a -> Int# -> IntMap b -> Int# -> (# IntMap a,Int#,IAList c,Int#,IntMap b,Int# #)+vennMaybeH f = v where+ -- v :: IAList c -> Int# -> IntMap a -> Int# -> IntMap b -> Int# -> (# IntMap a,Int#,IAList c,Int#,IntMap b,Int# #)+ v cs cl  E          ha  tb         hb = (# E ,ha,cs,cl,tb,hb #)+ v cs cl  ta         ha  E          hb = (# ta,ha,cs,cl,E ,hb #)+ v cs cl (N ka la a ra) ha (N kb lb b rb) hb = v_ cs cl ka la (ha-#2#) a ra (ha-#1#) kb lb (hb-#2#) b rb (hb-#1#)+ v cs cl (N ka la a ra) ha (Z kb lb b rb) hb = v_ cs cl ka la (ha-#2#) a ra (ha-#1#) kb lb (hb-#1#) b rb (hb-#1#)+ v cs cl (N ka la a ra) ha (P kb lb b rb) hb = v_ cs cl ka la (ha-#2#) a ra (ha-#1#) kb lb (hb-#1#) b rb (hb-#2#)+ v cs cl (Z ka la a ra) ha (N kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#1#) kb lb (hb-#2#) b rb (hb-#1#)+ v cs cl (Z ka la a ra) ha (Z kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#1#) kb lb (hb-#1#) b rb (hb-#1#)+ v cs cl (Z ka la a ra) ha (P kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#1#) kb lb (hb-#1#) b rb (hb-#2#)+ v cs cl (P ka la a ra) ha (N kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#2#) kb lb (hb-#2#) b rb (hb-#1#)+ v cs cl (P ka la a ra) ha (Z kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#2#) kb lb (hb-#1#) b rb (hb-#1#)+ v cs cl (P ka la a ra) ha (P kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#2#) kb lb (hb-#1#) b rb (hb-#2#)+ v_ cs cl ka la hla a ra hra kb lb hlb b rb hrb =+  case compareInt# ka kb of+  -- a < b, so (la < a < b) & (a < b < rb)+  LT ->                                 case forkVenn ka lb hlb of+   (# llb,hllb,mybb,rlb,hrlb #)      -> case forkVenn kb ra hra of+    (# lra,hlra,myba,rra,hrra #)     ->+     -- (la + llb) < a < (lra + rlb) < b < (rra + rb)+                                           case v cs cl rra hrra rb hrb of+     (# rab,hrab,cs0,cl0,rba,hrba #)    -> case (case myba of+                                                 Nothing -> case v            cs0   cl0      lra hlra rlb hrlb of+                                                  (# mab,hmab,cs1,cl1,mba,hmba #) -> case spliceH kb mba hmba b rba hrba of+                                                   (# mrba,hmrba #)               -> (# mab,hmab,cs1,cl1,mrba,hmrba #)+                                                 Just a_ -> case (case f a_ b of+                                                                  Nothing -> v            cs0   cl0      lra hlra rlb hrlb+                                                                  Just c  -> v (Cons kb c cs0) (cl0+#1#) lra hlra rlb hrlb+                                                                 ) of+                                                  (# mab,hmab,cs1,cl1,mba,hmba #) -> case joinH   mba hmba   rba hrba of+                                                   (# mrba,hmrba #)               -> (# mab,hmab,cs1,cl1,mrba,hmrba #)+                                                ) of+      (# mab,hmab,cs1,cl1,mrba,hmrba #) -> case joinH mab hmab rab hrab of+       (# mrab,hmrab #)                 -> case (case mybb of+                                                 Nothing -> case v            cs1   cl1      la hla llb hllb of+                                                  (# lab,hlab,cs2,cl2,lba,hlba #) -> case spliceH ka lab hlab a mrab hmrab of+                                                   (# ab,hab #)                   -> (# ab,hab,cs2,cl2,lba,hlba #)+                                                 Just b_ -> case (case f a b_ of+                                                                  Nothing -> v            cs1   cl1      la hla llb hllb+                                                                  Just c  -> v (Cons ka c cs1) (cl1+#1#) la hla llb hllb+                                                                 ) of+                                                  (# lab,hlab,cs2,cl2,lba,hlba #) -> case joinH   lab hlab   mrab hmrab of+                                                   (# ab,hab #)                   -> (# ab,hab,cs2,cl2,lba,hlba #)+                                                ) of+        (# ab,hab,cs2,cl2,lba,hlba #)   -> case joinH lba hlba mrba hmrba of+         (# ba,hba #)                   -> (# ab,hab,cs2,cl2,ba,hba #)+  -- a = b+  EQ ->                                case v    cs           cl   ra hra rb hrb of+   (# rab,hrab,cs0,cl0,rba,hrba #)  -> case (case f a b of+                                             Nothing -> v            cs0   cl0      la hla lb hlb+                                             Just c  -> v (Cons ka c cs0) (cl0+#1#) la hla lb hlb+                                            ) of+    (# lab,hlab,cs1,cl1,lba,hlba #) -> case joinH lab hlab rab hrab of+     (# ab,hab #)                   -> case joinH lba hlba rba hrba of+      (# ba,hba #)                  -> (# ab,hab,cs1,cl1,ba,hba #)+  -- b < a, so (lb < b < a) & (b < a < ra)+  GT ->                                  case forkVenn ka rb hrb of+   (# lrb,hlrb,mybb,rrb,hrrb #)       -> case forkVenn kb la hla of+    (# lla,hlla,myba,rla,hrla #)      ->+     -- (lla + lb) < b < (rla + lrb) < a < (ra + rrb)+                                            case v cs cl ra hra rrb hrrb of+     (# rab,hrab,cs0,cl0,rba,hrba #)     -> case (case mybb of+                                                  Nothing -> case v            cs0   cl0      rla hrla lrb hlrb of+                                                   (# mab,hmab,cs1,cl1,mba,hmba #) -> case spliceH ka mab hmab a rab hrab of+                                                    (# mrab,hmrab #)               -> (# mrab,hmrab,cs1,cl1,mba,hmba #)+                                                  Just b_ -> case (case f a b_ of+                                                                   Nothing -> v            cs0   cl0      rla hrla lrb hlrb+                                                                   Just c  -> v (Cons ka c cs0) (cl0+#1#) rla hrla lrb hlrb+                                                                  ) of+                                                   (# mab,hmab,cs1,cl1,mba,hmba #) -> case joinH   mab hmab   rab hrab of+                                                    (# mrab,hmrab #)               -> (# mrab,hmrab,cs1,cl1,mba,hmba #)+                                                 ) of+      (# mrab,hmrab,cs1,cl1,mba,hmba #)  -> case joinH mba hmba rba hrba of+       (# mrba,hmrba #)                  -> case (case myba of+                                                  Nothing -> case v            cs1   cl1      lla hlla lb hlb of+                                                   (# lab,hlab,cs2,cl2,lba,hlba #) -> case spliceH kb lba hlba b mrba hmrba of+                                                    (# ba,hba #)                   -> (# lab,hlab,cs2,cl2,ba,hba #)+                                                  Just a_ -> case (case f a_ b of+                                                                   Nothing -> v            cs1   cl1      lla hlla lb hlb+                                                                   Just c  -> v (Cons kb c cs1) (cl1+#1#) lla hlla lb hlb+                                                                  ) of+                                                   (# lab,hlab,cs2,cl2,lba,hlba #) -> case joinH   lba hlba   mrba hmrba of+                                                    (# ba,hba #)                   -> (# lab,hlab,cs2,cl2,ba,hba #)+                                                 ) of+        (# lab,hlab,cs2,cl2,ba,hba #)    -> case joinH lab hlab mrab hmrab of+         (# ab,hab #)                    -> (# ab,hab,cs2,cl2,ba,hba #)+-----------------------------------------------------------------------+------------------------ vennMaybeH Ends Here -------------------------+-----------------------------------------------------------------------++-- Common fork for Vennops+forkVenn :: Key -> IntMap a -> Int# -> (# IntMap a,Int#,Maybe a,IntMap a,Int# #)+forkVenn k ta hta = f ta hta where+ f  E           h = (# E,h,Nothing,E,h #)+ f (N ka l a r) h = f_ ka l (h-#2#) a r (h-#1#)+ f (Z ka l a r) h = f_ ka l (h-#1#) a r (h-#1#)+ f (P ka l a r) h = f_ ka l (h-#1#) a r (h-#2#)+ f_ ka l hl a r hr = case compareInt# k ka of+                     LT ->                            case f l hl of+                           (# ll,hll,mba,lr,hlr #) -> case spliceH ka lr hlr a r hr of+                            (# r_,hr_ #)           -> (# ll,hll,mba,r_,hr_ #)+                     EQ -> (# l,hl,Just a,r,hr #)+                     GT ->                            case f r hr of+                           (# rl,hrl,mbc,rr,hrr #) -> case spliceH ka l hl a rl hrl of+                            (# l_,hl_ #)           -> (# l_,hl_,mbc,rr,hrr #)+++disjointUnionIntMap :: IntMap a -> IntMap a -> IntMap a+disjointUnionIntMap = gu where -- This is to avoid O(log n) height calculation for empty sets+ gu     E            t1               = t1+ gu t0                   E            = t0+ gu t0@(N _ l0 _ _ ) t1@(N _ l1 _ _ ) = gu_ t0 (addHeight 2# l0) t1 (addHeight 2# l1)+ gu t0@(N _ l0 _ _ ) t1@(Z _ l1 _ _ ) = gu_ t0 (addHeight 2# l0) t1 (addHeight 1# l1)+ gu t0@(N _ l0 _ _ ) t1@(P _ _  _ r1) = gu_ t0 (addHeight 2# l0) t1 (addHeight 2# r1)+ gu t0@(Z _ l0 _ _ ) t1@(N _ l1 _ _ ) = gu_ t0 (addHeight 1# l0) t1 (addHeight 2# l1)+ gu t0@(Z _ l0 _ _ ) t1@(Z _ l1 _ _ ) = gu_ t0 (addHeight 1# l0) t1 (addHeight 1# l1)+ gu t0@(Z _ l0 _ _ ) t1@(P _ _  _ r1) = gu_ t0 (addHeight 1# l0) t1 (addHeight 2# r1)+ gu t0@(P _ _  _ r0) t1@(N _ l1 _ _ ) = gu_ t0 (addHeight 2# r0) t1 (addHeight 2# l1)+ gu t0@(P _ _  _ r0) t1@(Z _ l1 _ _ ) = gu_ t0 (addHeight 2# r0) t1 (addHeight 1# l1)+ gu t0@(P _ _  _ r0) t1@(P _ _  _ r1) = gu_ t0 (addHeight 2# r0) t1 (addHeight 2# r1)+ gu_ t0 h0 t1 h1 = case disjointUnionH t0 h0 t1 h1 of (# t,_ #) -> t+disjointUnionH :: IntMap a -> Int# -> IntMap a -> Int# -> (# IntMap a,Int# #)+disjointUnionH = u where+ -- u :: IntMap a -> UINT -> IntMap a -> UINT -> (# IntMap a,UINT #)+ u  E              _   t1             h1 = (# t1,h1 #)+ u  t0             h0  E              _  = (# t0,h0 #)+ u (N k0 l0 e0 r0) h0 (N k1 l1 e1 r1) h1 = u_ k0 l0 (h0-#2#) e0 r0 (h0-#1#) k1 l1 (h1-#2#) e1 r1 (h1-#1#)+ u (N k0 l0 e0 r0) h0 (Z k1 l1 e1 r1) h1 = u_ k0 l0 (h0-#2#) e0 r0 (h0-#1#) k1 l1 (h1-#1#) e1 r1 (h1-#1#)+ u (N k0 l0 e0 r0) h0 (P k1 l1 e1 r1) h1 = u_ k0 l0 (h0-#2#) e0 r0 (h0-#1#) k1 l1 (h1-#1#) e1 r1 (h1-#2#)+ u (Z k0 l0 e0 r0) h0 (N k1 l1 e1 r1) h1 = u_ k0 l0 (h0-#1#) e0 r0 (h0-#1#) k1 l1 (h1-#2#) e1 r1 (h1-#1#)+ u (Z k0 l0 e0 r0) h0 (Z k1 l1 e1 r1) h1 = u_ k0 l0 (h0-#1#) e0 r0 (h0-#1#) k1 l1 (h1-#1#) e1 r1 (h1-#1#)+ u (Z k0 l0 e0 r0) h0 (P k1 l1 e1 r1) h1 = u_ k0 l0 (h0-#1#) e0 r0 (h0-#1#) k1 l1 (h1-#1#) e1 r1 (h1-#2#)+ u (P k0 l0 e0 r0) h0 (N k1 l1 e1 r1) h1 = u_ k0 l0 (h0-#1#) e0 r0 (h0-#2#) k1 l1 (h1-#2#) e1 r1 (h1-#1#)+ u (P k0 l0 e0 r0) h0 (Z k1 l1 e1 r1) h1 = u_ k0 l0 (h0-#1#) e0 r0 (h0-#2#) k1 l1 (h1-#1#) e1 r1 (h1-#1#)+ u (P k0 l0 e0 r0) h0 (P k1 l1 e1 r1) h1 = u_ k0 l0 (h0-#1#) e0 r0 (h0-#2#) k1 l1 (h1-#1#) e1 r1 (h1-#2#)+ u_ k0 l0 hl0 e0 r0 hr0 k1 l1 hl1 e1 r1 hr1 =+  case compareInt# k0 k1 of+  -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1)+  LT ->                             case fork k1 r0 hr0 of+        (# rl0,hrl0,rr0,hrr0 #)  -> case fork k0 l1 hl1 of -- (e0  < rl0 < e1) & (e0 < e1  < rr0)+         (# ll1,hll1,lr1,hlr1 #) ->                        -- (ll1 < e0  < e1) & (e0 < lr1 < e1)+          -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1)+                                    case u  l0  hl0 ll1 hll1 of+          (# l,hl #)             -> case u rl0 hrl0 lr1 hlr1 of+           (# m,hm #)            -> case u rr0 hrr0  r1  hr1 of+            (# r,hr #)           -> case spliceH k1 m hm e1 r hr of+             (# t,ht #)          -> spliceH k0 l hl e0 t ht+  -- e0 = e1+  EQ -> error "disjointUnionH: Trees intersect" `seq` (# E,0# #)+  -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)+  GT ->                             case fork k0 r1 hr1 of+        (# rl1,hrl1,rr1,hrr1 #)  -> case fork k1 l0 hl0 of -- (e1  < rl1 < e0) & (e1 < e0  < rr1)+         (# ll0,hll0,lr0,hlr0 #) ->                        -- (ll0 < e1  < e0) & (e1 < lr0 < e0)+          -- (ll0 + l1) < e1 < (lr0  + rl1) < e0 < (r0 + rr1)+                                    case u ll0 hll0  l1  hl1 of+          (# l,hl #)             -> case u lr0 hlr0 rl1 hrl1 of+           (# m,hm #)            -> case u  r0  hr0 rr1 hrr1 of+            (# r,hr #)           -> case spliceH k1 l hl e1 m hm of+             (# t,ht #)          -> spliceH k0 t ht e0 r hr+ -- fork :: Key -> IntMap a -> Int# -> (# IntMap a,Int#,IntMap a,Int# #)+ fork k0 t1 ht1 = fork_ t1 ht1 where+  fork_  E        _ = (# E,0#,E,0# #)+  fork_ (N k l e r) h = fork__ k l (h-#2#) e r (h-#1#)+  fork_ (Z k l e r) h = fork__ k l (h-#1#) e r (h-#1#)+  fork_ (P k l e r) h = fork__ k l (h-#1#) e r (h-#2#)+  fork__ k l hl e r hr = case compareInt# k0 k of+                         LT ->                        case fork_ l hl of+                               (# l0,hl0,l1,hl1 #) -> case spliceH k l1 hl1 e r hr of+                                (# l1_,hl1_ #)     -> (# l0,hl0,l1_,hl1_ #)+                         EQ -> error "disjointUnionH: Trees intersect" `seq` (# E,0#,E,0# #)+                         GT ->                        case fork_ r hr of+                               (# l0,hl0,l1,hl1 #) -> case spliceH k l hl e l0 hl0 of+                                (# l0_,hl0_ #)     -> (# l0_,hl0_,l1,hl1 #)+-----------------------------------------------------------------------+---------------------- disjointUnionH Ends Here -----------------------+-----------------------------------------------------------------------
+ src/Data/GMap/ListMap.hs view
@@ -0,0 +1,1704 @@+{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -Wall #-}++module Data.GMap.ListMap+(-- * ListMap type+ ListMap+) where++import Prelude hiding (foldr,map,filter,lookup)+import Data.GMap++import Data.Typeable+import qualified Data.Foldable as F+import qualified Data.Monoid as M+import Data.Maybe hiding (mapMaybe)++import GHC.Base hiding (map)+import qualified Text.Read as R (Read(..),Lexeme(..),parens,prec,lexP,readListPrecDefault)++import qualified Data.List as L++--------------------------------------------------------------------------------------------+--                     Map Type for lists and various helper functions                     --+--------------------------------------------------------------------------------------------++-- | The 'Map' type for keys of form @'Map' map k => [k]@.+data ListMap map k a+ = Empt                                  -- Empty special, never appears in non-empty ListMap!+ | BraF ![k] a !(map (ListMap map k a))   -- Full branch, tail map may be empty or singleton+ | BraE ![k]   !(map (ListMap map k a))   -- Empty branch, no empty or singletons allowed.++-- Invariants are:+-- * Tail maps must not contain 'Empt' ListMap elements.+-- * The tail map of a 'BraE' node must contain at least 2 entries.+--   (Empty and singleton tail maps are degenerate cases which are normalised appropriately.)+-- Smart constructor for BraE. Ensures tail is not empty or singleton map.+braE :: Map map k => [k] -> map (ListMap map k a) -> ListMap map k a+braE ks mp = case status mp of+             None                   -> Empt+             One _  Empt            -> error "braE: Empty ListMap in tail map."+             One k (BraF ks' a mp') -> BraF (ks ++ k:ks') a mp'+             One k (BraE ks'   mp') -> BraE (ks ++ k:ks')   mp'+             Many                   -> BraE ks mp++-- | ListMap is an instance of Map.+instance Map map k => Map (ListMap map k) [k] where+	empty                 	= emptyListMap+	singleton             	= singletonListMap+	pair                  	= pairListMap+	nonEmpty              	= nonEmptyListMap+	status                	= statusListMap+	addSize               	= addSizeListMap+	lookup                	= lookupListMap+	lookupCont            	= lookupContListMap+	alter			= alterListMap+	insertWith            	= insertWithListMap +	insertWith'           	= insertWithListMap'+	insertMaybe           	= insertMaybeListMap+-- 	fromAssocsWith	= fromAssocsWithListMap+-- 	fromAssocsMaybe 	= fromAssocsMaybeListMap+	delete                	= deleteListMap +	adjustWith           	= adjustWithListMap+	adjustWith' 		= adjustWithListMap'+	adjustMaybe		= adjustMaybeListMap+	venn			= vennListMap+	venn'			= vennListMap'+	vennMaybe		= vennMaybeListMap+-- 	disjointUnion		= disjointUnionListMap+	union                 	= unionListMap+	union'                	= unionListMap'+	unionMaybe            	= unionMaybeListMap+	intersection          	= intersectionListMap+	intersection'         	= intersectionListMap'+	intersectionMaybe     	= intersectionMaybeListMap+	difference            	= differenceListMap+	differenceMaybe       	= differenceMaybeListMap+	isSubsetOf            	= isSubsetOfListMap+	isSubmapOf            	= isSubmapOfListMap +	map                   	= mapListMap+	map'                  	= mapListMap'+	mapMaybe              	= mapMaybeListMap+	mapWithKey            	= mapWithKeyListMap+	mapWithKey'           	= mapWithKeyListMap'+	filter                	= filterListMap+	foldKeys		= foldKeysListMap+	foldElems 		= foldElemsListMap+	foldAssocs		= foldAssocsListMap+	foldKeys'		= foldKeysListMap'+	foldElems' 		= foldElemsListMap'+	foldAssocs'		= foldAssocsListMap'+	foldElemsUInt         	= foldElemsUIntListMap+	valid                 	= validListMap+ +instance OrderedMap map k => OrderedMap (ListMap map k) [k] where+	compareKey 	= compareKeyListMap+	fromAssocsAscWith = fromAssocsAscWithListMap+	fromAssocsDescWith = fromAssocsDescWithListMap+	fromAssocsAscMaybe = fromAssocsAscMaybeListMap+	fromAssocsDescMaybe = fromAssocsDescMaybeListMap+ 	foldElemsAsc	= foldElemsAscListMap+	foldElemsDesc	= foldElemsDescListMap+	foldKeysAsc	= foldKeysAscListMap+	foldKeysDesc	= foldKeysDescListMap+	foldAssocsAsc	= foldAssocsAscListMap+	foldAssocsDesc	= foldAssocsDescListMap+	foldElemsAsc'	= foldElemsAscListMap'+	foldElemsDesc'	= foldElemsDescListMap'+	foldKeysAsc'	= foldKeysAscListMap'+	foldKeysDesc'	= foldKeysDescListMap'+	foldAssocsAsc'	= foldAssocsAscListMap'+	foldAssocsDesc'	= foldAssocsDescListMap'++-- Strict +++infixr 5 +!++(+!+) :: [a] -> [a] -> [a]+[]     +!+ ys = ys+(x:xs) +!+ ys = let xs' = xs +!+ ys in xs' `seq` x:xs'+{- (not used currently)+xs +!+ [] = xs+xs +!+ ys = f xs where f []      = ys+                       f (x:xs') = let xs'' = f xs' in xs'' `seq` x:xs''+-}++-- Local Utility for reverse join: revTo xs ys = (reverse xs) ++ ys+revTo :: [a] -> [a] -> [a]+revTo []     ys = ys+revTo (x:xs) ys = revTo xs (x:ys)++-- Take the first N elements of a list.+-- Gives an error if list is not long enough to do this!+takeN :: Int# -> [k] -> [k]+takeN 0# _      = []+takeN _    []     = error "Data.GMap.ListMap.takeN: List is too short."+takeN n    (k:ks) = let ks_ = takeN (n -# 1#) ks in ks_ `seq` k:ks_++-- Return type of the match function+-- Do we need the Int# in Sfx and Sfy constructors ??+data Match map k a =+   Mat                    -- Input lists match and have same length (I.E. they are identical)+ | Frk Int# (ListMap map k a -> ListMap map k a -> map (ListMap map k a)) [k] [k]       -- n f xs ys+ | Sfx Int# k [k]         -- Input lists match but xs has remaining non-empty suffix -- n x xs+ | Sfy Int# k [k]         -- Input lists match but ys has remaining non-empty suffix -- n y ys+-- Try to match two lists of keys+match :: Map map k => [k] -> [k] -> Match map k a+match xs0 ys0 = m 0# xs0 ys0+ where m _ []     []     = Mat+       m n []     (y:ys) = Sfy n y ys+       m n (x:xs) []     = Sfx n x xs+       m n (x:xs) (y:ys) = case pair x y of+                           Just f  -> Frk n (\mpa mpb -> mpa `seq` mpb `seq` f mpa mpb) xs ys+                           Nothing -> m ((n) +# 1#) xs ys   -- x == y++-- Common error message associated with (supposedly) sorted associations lists.+-- Can be caused by improper sorting (including duplicate keys)+badAssocs :: String+badAssocs = "Data.GMap.ListMap: Bad sorted association List."+--------------------------------------------------------------------------------------------++-- | See 'Map' class method 'empty'.+emptyListMap :: ListMap map k a+emptyListMap = Empt+{-# INLINE emptyListMap #-}++-- | See 'Map' class method 'singleton'.+singletonListMap :: Map map k => [k] -> a -> ListMap map k a+singletonListMap ks a = BraF ks a empty+{-# INLINE singletonListMap #-}++-- | See 'Map' class method 'pair'.+pairListMap :: Map map k => [k] -> [k] -> Maybe (a -> a -> ListMap map k a)+pairListMap xs0 ys0 = pr 0# xs0 ys0 where+ pr _ []     []     = Nothing+ pr _ []     (y:ys) = Just (\ax ay -> BraF xs0 ax (singleton y (BraF ys ay empty)))+ pr _ (x:xs) []     = Just (\ax ay -> BraF ys0 ay (singleton x (BraF xs ax empty)))+ pr n (x:xs) (y:ys) = case pair x y of+                      Just f  -> Just (\ax ay -> BraE (takeN n xs0) (f (BraF xs ax empty) (BraF ys ay empty)))+                      Nothing -> pr ((n) +# 1#) xs ys++-- | See 'Map' class method 'nonEmpty'.+nonEmptyListMap :: ListMap map k a -> Maybe (ListMap map k a)+nonEmptyListMap Empt = Nothing+nonEmptyListMap lmp  = Just lmp+{-# INLINE nonEmptyListMap #-}++-- | See 'Map' class method 'status'.+statusListMap :: Map map k => ListMap map k a -> Status [k] a+statusListMap  Empt          = None+statusListMap (BraF ks a mp) = if (isEmpty mp) then (One ks a) else Many+statusListMap (BraE _    _ ) = Many+{-# INLINE statusListMap #-}++-- | See 'Map' class method 'addSize'.+addSizeListMap :: Map map k => ListMap map k a -> Int# -> Int#+addSizeListMap  Empt         n = n+addSizeListMap (BraF _ _ mp) n = foldElemsUInt addSizeListMap ((n) +# 1#) mp+addSizeListMap (BraE _   mp) n = foldElemsUInt addSizeListMap n mp++-- | See 'Map' class method 'lookup'.+lookupListMap :: Map map k => [k] -> ListMap map k a -> Maybe a+lookupListMap ks0 lmp0 = lmb ks0 lmp0 where+ lmb _ Empt = Nothing+------------------------------+ lmb ks (BraF ks' a mp) = pre ks ks' where+  pre []     []     = Just a+  pre []     (_:_ ) = Nothing+  pre (x:xs) []     = case lookup x mp of+                      Just lmp -> lmb xs lmp+                      Nothing  -> Nothing+  pre (x:xs) (y:ys) = if x == y then pre xs ys else Nothing+------------------------------+ lmb ks (BraE ks' mp) = pre ks ks' where+  pre []     _      = Nothing+  pre (x:xs) []     = case lookup x mp of+                      Just lmp -> lmb xs lmp+                      Nothing  -> Nothing+  pre (x:xs) (y:ys) = if x == y then pre xs ys else Nothing+------------------------------++-- | See 'Map' class method 'lookupCont'.+lookupContListMap :: Map map k => (a -> Maybe b) -> [k] -> ListMap map k a -> Maybe b+-- Convention below is xs is the search key list and ys is the key list fragment from the Trie (ListMap)+lookupContListMap j ks0 lmp0 = lmb ks0 lmp0 where+ lmb _ Empt = Nothing+------------------------------+ lmb ks (BraF ks' a mp) = pre ks ks' where+  pre []     []     = j a+  pre []     (_:_ ) = Nothing+  pre (x:xs) []     = lookupCont (lmb xs) x mp+  pre (x:xs) (y:ys) = if x == y then pre xs ys else Nothing+------------------------------+ lmb ks (BraE ks' mp) = pre ks ks' where+  pre []     _      = Nothing+  pre (x:xs) []     = lookupCont (lmb xs) x mp+  pre (x:xs) (y:ys) = if x == y then pre xs ys else Nothing+------------------------------++-- | See 'Map' class method 'delete'.+deleteListMap :: Map map k => [k] -> ListMap map k a -> ListMap map k a+deleteListMap = adjustMaybeListMap (const Nothing)+{-# INLINE deleteListMap #-}++-- | See 'Map' class method 'adjustWith'.+adjustWithListMap :: Map map k => (a -> a) -> [k] -> ListMap map k a -> ListMap map k a+-- N.B. One day we will have a more efficient implementation of this+adjustWithListMap f ks0 lmp0 = dmb ks0 lmp0 where+ dmb _ Empt = Empt+------------------------------+ dmb ks bf@(BraF ks' a mp) = pre ks ks' where+  pre []     []     = BraF  ks' (f a) mp+  pre []     (_:_ ) = bf+  pre (x:xs) []     = BraF ks' a (adjustWith (\lmp -> dmb xs lmp) x mp)+  pre (x:xs) (y:ys) = if x == y then pre xs ys else bf+------------------------------+ dmb ks be@(BraE ks' mp) = pre ks ks' where+  pre []     _      = be+  pre (x:xs) []     = braE ks' (adjustWith (\lmp -> dmb xs lmp) x mp)+  pre (x:xs) (y:ys) = if x == y then pre xs ys else be+------------------------------++-- | See 'Map' class method 'adjustWith''.+adjustWithListMap' :: Map map k => (a -> a) -> [k] -> ListMap map k a -> ListMap map k a+-- N.B. One day we will have a more efficient implementation of this+adjustWithListMap' f ks0 lmp0 = dmb ks0 lmp0 where+ dmb _ Empt = Empt+------------------------------+ dmb ks bf@(BraF ks' a mp) = pre ks ks' where+  pre []     []     = let newElem = f a +  		      in newElem `seq` BraF  ks' newElem mp+  pre []     (_:_ ) = bf+  pre (x:xs) []     = BraF ks' a (adjustWith' (\lmp -> dmb xs lmp) x mp)+  pre (x:xs) (y:ys) = if x == y then pre xs ys else bf+------------------------------+ dmb ks be@(BraE ks' mp) = pre ks ks' where+  pre []     _      = be+  pre (x:xs) []     = braE ks' (adjustWith' (\lmp -> dmb xs lmp) x mp)+  pre (x:xs) (y:ys) = if x == y then pre xs ys else be+------------------------------++-- | See 'Map' class method 'adjustMaybe'.+adjustMaybeListMap :: Map map k => (a -> Maybe a) -> [k] -> ListMap map k a -> ListMap map k a+-- Convention below is xs is the search key list and ys is the key list fragment from the Trie (ListMap)+adjustMaybeListMap f ks0 lmp0 = dmb ks0 lmp0 where+ dmb _ Empt = Empt+------------------------------+ dmb ks bf@(BraF ks' a mp) = pre ks ks' where+  pre []     []     = case f a of Just a' -> BraF  ks' a' mp+                                  Nothing -> braE  ks'    mp+  pre []     (_:_ ) = bf+  pre (x:xs) []     = BraF ks' a (adjustMaybe (\lmp -> nonEmptyListMap (dmb xs lmp)) x mp)+  pre (x:xs) (y:ys) = if x == y then pre xs ys else bf+------------------------------+ dmb ks be@(BraE ks' mp) = pre ks ks' where+  pre []     _      = be+  pre (x:xs) []     = braE ks' (adjustMaybe (\lmp -> nonEmptyListMap (dmb xs lmp)) x mp)+  pre (x:xs) (y:ys) = if x == y then pre xs ys else be+------------------------------++-- |  See 'Map' class method 'venn'.+vennListMap ::  Map map k => (a -> b -> c) -> ListMap map k a -> ListMap map k b -> (ListMap map k a, ListMap map k c, ListMap map k b)+vennListMap f lmp0 lmp1 = v lmp0 lmp1 where+ appendStem ys y (BraF xs a mpx) = BraF (ys +!+ y:xs) a mpx+ appendStem ys y (BraE xs   mpx) = BraE (ys +!+ y:xs)  mpx+ appendStem _  _ Empt            = Empt+------------------------------------------+ replace k m mp = alter' (const (nonEmpty m)) k mp+------------------------------------------+ vennInner mpx mpy = (leftDiff,inter,rightDiff) +	where 	leftDiff  = disjointUnion mpl (mapMaybe (\(l,_,_) -> nonEmpty l) mpi)+		inter     =                    mapMaybe (\(_,i,_) -> nonEmpty i) mpi+		rightDiff = disjointUnion mpr (mapMaybe (\(_,_,r) -> nonEmpty r) mpi)+		(mpl,mpi,mpr) = venn' (venn f) mpx mpy -- NB use of venn'+------------------------------------------+ v Empt lmpy    = (Empt,Empt,lmpy)+ v lmpx    Empt = (lmpx,Empt,Empt)+------------------------------------------+ v lmpx@(BraF xs0 a mpx) lmpy@(BraF ys0 b mpy) = m xs0 ys0 where+  m []     []     = (braE xs0         leftDiff+                    ,BraF xs0 (f a b) inter+                    ,braE xs0         rightDiff)+  		    where (leftDiff,inter,rightDiff) = vennInner mpx mpy+  m (x:xs) []     = case lookup x mpy of Nothing   -> (lmpx,Empt,lmpy)+                                         Just lmpb -> case v (BraF xs a mpx) lmpb of+                                                      (_,Empt,_) -> (lmpx,Empt,lmpy)+                                                      (_,i   ,r) -> (difference +                                                      				(BraF xs0 a mpx)+                                                      				(appendStem ys0 x i)+                                                      		    ,appendStem ys0 x i+                                                      		    ,BraF ys0 b (replace x r mpy))+  m []     (y:ys) = case lookup y mpx of Nothing   -> (lmpx,Empt,lmpy)+                                         Just lmpa -> case v lmpa (BraF ys b mpy) of+                                                      (_,Empt,_) -> (lmpx,Empt,lmpy)+                                                      (l,i   ,_) -> (BraF xs0 a (replace y l mpx)+                                                      		    ,appendStem xs0 y i+                                                      		    ,difference +                                                      				(BraF ys0 b mpy)+                                                      				(appendStem xs0 y i))+  m (x:xs) (y:ys) = if x == y then m xs ys else (lmpx,Empt,lmpy)+------------------------------------------+ v lmpx@(BraF xs0 a mpx) lmpy@(BraE ys0 mpy) = m xs0 ys0 where+  m []     []     = (BraF xs0 a leftDiff+                    ,braE xs0   inter+                    ,braE xs0   rightDiff)+  		    where (leftDiff,inter,rightDiff) = vennInner mpx mpy+  m (x:xs) []     = case lookup x mpy of Nothing   -> (lmpx,Empt,lmpy)+                                         Just lmpb -> case v (BraF xs a mpx) lmpb of+                                                      (_,Empt,_) -> (lmpx,Empt,lmpy)+                                                      (_,i   ,r) -> (difference +                                                      				(BraF xs0 a mpx)+                                                      				(appendStem ys0 x i)+                                                      		    ,appendStem ys0 x i+                                                      		    ,BraE ys0 (replace x r mpy))+  m []     (y:ys) = case lookup y mpx of Nothing   -> (lmpx,Empt,lmpy)+                                         Just lmpa -> case v lmpa (BraE ys mpy) of+                                                      (_,Empt,_) -> (lmpx,Empt,lmpy)+                                                      (l,i   ,_) -> (BraF xs0 a (replace y l mpx)+                                                      		    ,appendStem xs0 y i+                                                      		    ,difference +                                                      				(BraE ys0 mpy)+                                                      				(appendStem xs0 y i))+  m (x:xs) (y:ys) = if x == y then m xs ys else (lmpx,Empt,lmpy)+------------------------------------------+ v lmpx@(BraE xs0 mpx) lmpy@(BraF ys0 b mpy) = m xs0 ys0 where+  m []     []     = (braE xs0   leftDiff+                    ,braE xs0   inter+                    ,BraF xs0 b rightDiff)+  		    where (leftDiff,inter,rightDiff) = vennInner mpx mpy+  m (x:xs) []     = case lookup x mpy of Nothing   -> (lmpx,Empt,lmpy)+                                         Just lmpb -> case v (BraE xs mpx) lmpb of+                                                      (_,Empt,_) -> (lmpx,Empt,lmpy)+                                                      (_,i   ,r) -> (difference +                                                      				(BraE xs0 mpx)+                                                      				(appendStem ys0 x i)+                                                      		    ,appendStem ys0 x i+                                                      		    ,BraF ys0 b (replace x r mpy))+  m []     (y:ys) = case lookup y mpx of Nothing   -> (lmpx,Empt,lmpy)+                                         Just lmpa -> case v lmpa (BraF ys b mpy) of+                                                      (_,Empt,_) -> (lmpx,Empt,lmpy)+                                                      (l,i   ,_) -> (BraE xs0 (replace y l mpx)+                                                      		    ,appendStem xs0 y i+                                                      		    ,difference +                                                      				(BraF ys0 b mpy)+                                                      				(appendStem xs0 y i))+  m (x:xs) (y:ys) = if x == y then m xs ys else (lmpx,Empt,lmpy)+------------------------------------------+ v lmpx@(BraE xs0 mpx) lmpy@(BraE ys0 mpy) = m xs0 ys0 where+  m []     []     = (braE xs0 leftDiff+                    ,braE xs0 inter+                    ,braE xs0 rightDiff)+  		    where (leftDiff,inter,rightDiff) = vennInner mpx mpy+  m (x:xs) []     = case lookup x mpy of Nothing   -> (lmpx,Empt,lmpy)+                                         Just lmpb -> case v (BraE xs mpx) lmpb of+                                                      (_,Empt,_) -> (lmpx,Empt,lmpy)+                                                      (_,i   ,r) -> (difference +                                                      				(BraE xs0 mpx)+                                                      				(appendStem ys0 x i)+                                                      		    ,appendStem ys0 x i+                                                      		    ,BraE ys0 (replace x r mpy))+  m []     (y:ys) = case lookup y mpx of Nothing   -> (lmpx,Empt,lmpy)+                                         Just lmpa -> case v lmpa (BraE ys mpy) of+                                                      (_,Empt,_) -> (lmpx,Empt,lmpy)+                                                      (l,i   ,_) -> (BraE xs0 (replace y l mpx)+                                                      		    ,appendStem xs0 y i+                                                      		    ,difference +                                                      				(BraE ys0 mpy)+                                                      				(appendStem xs0 y i))+  m (x:xs) (y:ys) = if x == y then m xs ys else (lmpx,Empt,lmpy)+------------------------------------------++-- |  See 'Map' class method 'venn''.+vennListMap' ::  Map map k => (a -> b -> c) -> ListMap map k a -> ListMap map k b -> (ListMap map k a, ListMap map k c, ListMap map k b)+vennListMap' f lmp0 lmp1 = v lmp0 lmp1 where+ appendStem ys y (BraF xs a mpx) = BraF (ys +!+ y:xs) a mpx+ appendStem ys y (BraE xs   mpx) = BraE (ys +!+ y:xs)  mpx+ appendStem _  _ Empt            = Empt+------------------------------------------+ replace k m mp = alter' (const (nonEmpty m)) k mp+------------------------------------------+ vennInner mpx mpy = (leftDiff,inter,rightDiff) +	where 	leftDiff  = disjointUnion mpl (mapMaybe (\(l,_,_) -> nonEmpty l) mpi)+		inter     =                    mapMaybe (\(_,i,_) -> nonEmpty i) mpi+		rightDiff = disjointUnion mpr (mapMaybe (\(_,_,r) -> nonEmpty r) mpi)+		(mpl,mpi,mpr) = venn' (venn' f) mpx mpy+------------------------------------------+ v Empt lmpy    = (Empt,Empt,lmpy)+ v lmpx    Empt = (lmpx,Empt,Empt)+------------------------------------------+ v lmpx@(BraF xs0 a mpx) lmpy@(BraF ys0 b mpy) = m xs0 ys0 where+  m []     []     = (braE xs0         leftDiff+                    ,let c = f a b in c `seq` BraF xs0 c inter+                    ,braE xs0         rightDiff)+  		    where (leftDiff,inter,rightDiff) = vennInner mpx mpy+  m (x:xs) []     = case lookup x mpy of Nothing   -> (lmpx,Empt,lmpy)+                                         Just lmpb -> case v (BraF xs a mpx) lmpb of+                                                      (_,Empt,_) -> (lmpx,Empt,lmpy)+                                                      (_,i   ,r) -> (difference +                                                      				(BraF xs0 a mpx)+                                                      				(appendStem ys0 x i)+                                                      		    ,appendStem ys0 x i+                                                      		    ,BraF ys0 b (replace x r mpy))+  m []     (y:ys) = case lookup y mpx of Nothing   -> (lmpx,Empt,lmpy)+                                         Just lmpa -> case v lmpa (BraF ys b mpy) of+                                                      (_,Empt,_) -> (lmpx,Empt,lmpy)+                                                      (l,i   ,_) -> (BraF xs0 a (replace y l mpx)+                                                      		    ,appendStem xs0 y i+                                                      		    ,difference +                                                      				(BraF ys0 b mpy)+                                                      				(appendStem xs0 y i))+  m (x:xs) (y:ys) = if x == y then m xs ys else (lmpx,Empt,lmpy)+------------------------------------------+ v lmpx@(BraF xs0 a mpx) lmpy@(BraE ys0 mpy) = m xs0 ys0 where+  m []     []     = (BraF xs0 a leftDiff+                    ,braE xs0   inter+                    ,braE xs0   rightDiff)+  		    where (leftDiff,inter,rightDiff) = vennInner mpx mpy+  m (x:xs) []     = case lookup x mpy of Nothing   -> (lmpx,Empt,lmpy)+                                         Just lmpb -> case v (BraF xs a mpx) lmpb of+                                                      (_,Empt,_) -> (lmpx,Empt,lmpy)+                                                      (_,i   ,r) -> (difference +                                                      				(BraF xs0 a mpx)+                                                      				(appendStem ys0 x i)+                                                      		    ,appendStem ys0 x i+                                                      		    ,BraE ys0 (replace x r mpy))+  m []     (y:ys) = case lookup y mpx of Nothing   -> (lmpx,Empt,lmpy)+                                         Just lmpa -> case v lmpa (BraE ys mpy) of+                                                      (_,Empt,_) -> (lmpx,Empt,lmpy)+                                                      (l,i   ,_) -> (BraF xs0 a (replace y l mpx)+                                                      		    ,appendStem xs0 y i+                                                      		    ,difference +                                                      				(BraE ys0 mpy)+                                                      				(appendStem xs0 y i))+  m (x:xs) (y:ys) = if x == y then m xs ys else (lmpx,Empt,lmpy)+------------------------------------------+ v lmpx@(BraE xs0 mpx) lmpy@(BraF ys0 b mpy) = m xs0 ys0 where+  m []     []     = (braE xs0   leftDiff+                    ,braE xs0   inter+                    ,BraF xs0 b rightDiff)+  		    where (leftDiff,inter,rightDiff) = vennInner mpx mpy+  m (x:xs) []     = case lookup x mpy of Nothing   -> (lmpx,Empt,lmpy)+                                         Just lmpb -> case v (BraE xs mpx) lmpb of+                                                      (_,Empt,_) -> (lmpx,Empt,lmpy)+                                                      (_,i   ,r) -> (difference +                                                      				(BraE xs0 mpx)+                                                      				(appendStem ys0 x i)+                                                      		    ,appendStem ys0 x i+                                                      		    ,BraF ys0 b (replace x r mpy))+  m []     (y:ys) = case lookup y mpx of Nothing   -> (lmpx,Empt,lmpy)+                                         Just lmpa -> case v lmpa (BraF ys b mpy) of+                                                      (_,Empt,_) -> (lmpx,Empt,lmpy)+                                                      (l,i   ,_) -> (BraE xs0 (replace y l mpx)+                                                      		    ,appendStem xs0 y i+                                                      		    ,difference +                                                      				(BraF ys0 b mpy)+                                                      				(appendStem xs0 y i))+  m (x:xs) (y:ys) = if x == y then m xs ys else (lmpx,Empt,lmpy)+------------------------------------------+ v lmpx@(BraE xs0 mpx) lmpy@(BraE ys0 mpy) = m xs0 ys0 where+  m []     []     = (braE xs0 leftDiff+                    ,braE xs0 inter+                    ,braE xs0 rightDiff)+  		    where (leftDiff,inter,rightDiff) = vennInner mpx mpy+  m (x:xs) []     = case lookup x mpy of Nothing   -> (lmpx,Empt,lmpy)+                                         Just lmpb -> case v (BraE xs mpx) lmpb of+                                                      (_,Empt,_) -> (lmpx,Empt,lmpy)+                                                      (_,i   ,r) -> (difference +                                                      				(BraE xs0 mpx)+                                                      				(appendStem ys0 x i)+                                                      		    ,appendStem ys0 x i+                                                      		    ,BraE ys0 (replace x r mpy))+  m []     (y:ys) = case lookup y mpx of Nothing   -> (lmpx,Empt,lmpy)+                                         Just lmpa -> case v lmpa (BraE ys mpy) of+                                                      (_,Empt,_) -> (lmpx,Empt,lmpy)+                                                      (l,i   ,_) -> (BraE xs0 (replace y l mpx)+                                                      		    ,appendStem xs0 y i+                                                      		    ,difference +                                                      				(BraE ys0 mpy)+                                                      				(appendStem xs0 y i))+  m (x:xs) (y:ys) = if x == y then m xs ys else (lmpx,Empt,lmpy)+------------------------------------------++-- |  See 'Map' class method 'vennMaybe'.+vennMaybeListMap ::  Map map k => (a -> b -> Maybe c) -> ListMap map k a -> ListMap map k b -> (ListMap map k a, ListMap map k c, ListMap map k b)+vennMaybeListMap f lmp0 lmp1 = v lmp0 lmp1 where+ appendStem ys y (BraF xs a mpx) = BraF (ys +!+ y:xs) a mpx+ appendStem ys y (BraE xs   mpx) = BraE (ys +!+ y:xs)  mpx+ appendStem _  _ Empt            = Empt+------------------------------------------+ replace k m mp = alter' (const (nonEmpty m)) k mp+------------------------------------------+ vennInner mpx mpy = (leftDiff,inter,rightDiff) +	where 	leftDiff  = disjointUnion mpl (mapMaybe (\(l,_,_) -> nonEmpty l) mpi)+		inter     =                    mapMaybe (\(_,i,_) -> nonEmpty i) mpi+		rightDiff = disjointUnion mpr (mapMaybe (\(_,_,r) -> nonEmpty r) mpi)+		(mpl,mpi,mpr) = venn (vennMaybe f) mpx mpy+------------------------------------------+ v Empt lmpy    = (Empt,Empt,lmpy)+ v lmpx    Empt = (lmpx,Empt,Empt)+------------------------------------------+ v lmpx@(BraF xs0 a mpx) lmpy@(BraF ys0 b mpy) = m xs0 ys0 where+  m []     []     = (braE xs0         leftDiff+                    ,case f a b of+                    	Nothing -> braE xs0   inter+                    	Just c  -> BraF xs0 c inter+                    ,braE xs0         rightDiff)+  		    where (leftDiff,inter,rightDiff) = vennInner mpx mpy+  m (x:xs) []     = case lookup x mpy of Nothing   -> (lmpx,Empt,lmpy)+                                         Just lmpb -> case v (BraF xs a mpx) lmpb of+                                                      (_,Empt,_) -> (lmpx,Empt,lmpy)+                                                      (_,i   ,r) -> (difference +                                                      				(BraF xs0 a mpx)+                                                      				(appendStem ys0 x i)+                                                      		    ,appendStem ys0 x i+                                                      		    ,BraF ys0 b (replace x r mpy))+  m []     (y:ys) = case lookup y mpx of Nothing   -> (lmpx,Empt,lmpy)+                                         Just lmpa -> case v lmpa (BraF ys b mpy) of+                                                      (_,Empt,_) -> (lmpx,Empt,lmpy)+                                                      (l,i   ,_) -> (BraF xs0 a (replace y l mpx)+                                                      		    ,appendStem xs0 y i+                                                      		    ,difference +                                                      				(BraF ys0 b mpy)+                                                      				(appendStem xs0 y i))+  m (x:xs) (y:ys) = if x == y then m xs ys else (lmpx,Empt,lmpy)+------------------------------------------+ v lmpx@(BraF xs0 a mpx) lmpy@(BraE ys0 mpy) = m xs0 ys0 where+  m []     []     = (BraF xs0 a leftDiff+                    ,braE xs0   inter+                    ,braE xs0   rightDiff)+  		    where (leftDiff,inter,rightDiff) = vennInner mpx mpy+  m (x:xs) []     = case lookup x mpy of Nothing   -> (lmpx,Empt,lmpy)+                                         Just lmpb -> case v (BraF xs a mpx) lmpb of+                                                      (_,Empt,_) -> (lmpx,Empt,lmpy)+                                                      (_,i   ,r) -> (difference +                                                      				(BraF xs0 a mpx)+                                                      				(appendStem ys0 x i)+                                                      		    ,appendStem ys0 x i+                                                      		    ,BraE ys0 (replace x r mpy))+  m []     (y:ys) = case lookup y mpx of Nothing   -> (lmpx,Empt,lmpy)+                                         Just lmpa -> case v lmpa (BraE ys mpy) of+                                                      (_,Empt,_) -> (lmpx,Empt,lmpy)+                                                      (l,i   ,_) -> (BraF xs0 a (replace y l mpx)+                                                      		    ,appendStem xs0 y i+                                                      		    ,difference +                                                      				(BraE ys0 mpy)+                                                      				(appendStem xs0 y i))+  m (x:xs) (y:ys) = if x == y then m xs ys else (lmpx,Empt,lmpy)+------------------------------------------+ v lmpx@(BraE xs0 mpx) lmpy@(BraF ys0 b mpy) = m xs0 ys0 where+  m []     []     = (braE xs0   leftDiff+                    ,braE xs0   inter+                    ,BraF xs0 b rightDiff)+  		    where (leftDiff,inter,rightDiff) = vennInner mpx mpy+  m (x:xs) []     = case lookup x mpy of Nothing   -> (lmpx,Empt,lmpy)+                                         Just lmpb -> case v (BraE xs mpx) lmpb of+                                                      (_,Empt,_) -> (lmpx,Empt,lmpy)+                                                      (_,i   ,r) -> (difference +                                                      				(BraE xs0 mpx)+                                                      				(appendStem ys0 x i)+                                                      		    ,appendStem ys0 x i+                                                      		    ,BraF ys0 b (replace x r mpy))+  m []     (y:ys) = case lookup y mpx of Nothing   -> (lmpx,Empt,lmpy)+                                         Just lmpa -> case v lmpa (BraF ys b mpy) of+                                                      (_,Empt,_) -> (lmpx,Empt,lmpy)+                                                      (l,i   ,_) -> (BraE xs0 (replace y l mpx)+                                                      		    ,appendStem xs0 y i+                                                      		    ,difference +                                                      				(BraF ys0 b mpy)+                                                      				(appendStem xs0 y i))+  m (x:xs) (y:ys) = if x == y then m xs ys else (lmpx,Empt,lmpy)+------------------------------------------+ v lmpx@(BraE xs0 mpx) lmpy@(BraE ys0 mpy) = m xs0 ys0 where+  m []     []     = (braE xs0 leftDiff+                    ,braE xs0 inter+                    ,braE xs0 rightDiff)+  		    where (leftDiff,inter,rightDiff) = vennInner mpx mpy+  m (x:xs) []     = case lookup x mpy of Nothing   -> (lmpx,Empt,lmpy)+                                         Just lmpb -> case v (BraE xs mpx) lmpb of+                                                      (_,Empt,_) -> (lmpx,Empt,lmpy)+                                                      (_,i   ,r) -> (difference +                                                      				(BraE xs0 mpx)+                                                      				(appendStem ys0 x i)+                                                      		    ,appendStem ys0 x i+                                                      		    ,BraE ys0 (replace x r mpy))+  m []     (y:ys) = case lookup y mpx of Nothing   -> (lmpx,Empt,lmpy)+                                         Just lmpa -> case v lmpa (BraE ys mpy) of+                                                      (_,Empt,_) -> (lmpx,Empt,lmpy)+                                                      (l,i   ,_) -> (BraE xs0 (replace y l mpx)+                                                      		    ,appendStem xs0 y i+                                                      		    ,difference +                                                      				(BraE ys0 mpy)+                                                      				(appendStem xs0 y i))+  m (x:xs) (y:ys) = if x == y then m xs ys else (lmpx,Empt,lmpy)+------------------------------------------++-- |  See 'Map' class method 'union'.+unionListMap ::  Map map k => (a -> a -> a) -> ListMap map k a -> ListMap map k a -> ListMap map k a+unionListMap f lmp0 lmp1 = u lmp0 lmp1 where+ u Empt lmp  = lmp+ u lmp  Empt = lmp+------------------------------------------+ u (BraF xs0 ax mpx) (BraF ys0 ay mpy) = case match xs0 ys0 of+  Mat            -> BraF xs0 (f ax ay) (union' u mpx mpy) -- N.B. Use of strict union'+  Frk n f' xs ys -> BraE (takeN n xs0) (f' (BraF xs ax mpx) (BraF ys ay mpy))+  Sfx _ x xs     -> BraF ys0 ay (insertWith' f' x braFx mpy) -- N.B. Use of strict insertWith'+                    where f' lmp = u braFx lmp+                          braFx  = BraF xs ax mpx+  Sfy _ y ys     -> BraF xs0 ax (insertWith' f' y braFy mpx) -- N.B. Use of strict insertWith'+                    where f' lmp = u lmp braFy+                          braFy  = BraF ys ay mpy+------------------------------------------+ u (BraF xs0 ax mpx) (BraE ys0 mpy) = case match xs0 ys0 of+  Mat            -> BraF xs0 ax (union' u mpx mpy) -- N.B. Use of strict union'+  Frk n f' xs ys -> BraE (takeN n xs0) (f' (BraF xs ax mpx) (BraE ys mpy))+  Sfx _ x xs     -> BraE ys0 (insertWith' f' x braFx mpy) -- N.B. Use of strict insertWith'+                    where f' lmp = u braFx lmp+                          braFx  = BraF xs ax mpx+  Sfy _ y ys     -> BraF xs0 ax (insertWith' f' y braEy mpx) -- N.B. Use of strict insertWith'+                    where f' lmp = u lmp braEy+                          braEy  = BraE ys mpy+------------------------------------------+ u (BraE xs0 mpx) (BraF ys0 ay mpy) = case match xs0 ys0 of+  Mat            -> BraF xs0 ay (union' u mpx mpy) -- N.B. Use of strict union'+  Frk n f' xs ys -> BraE (takeN n xs0) (f' (BraE xs mpx) (BraF ys ay mpy))+  Sfx _ x xs     -> BraF ys0 ay (insertWith' f' x braEx mpy) -- N.B. Use of strict insertWith'+                    where f' lmp = u braEx lmp+                          braEx  = BraE xs mpx+  Sfy _ y ys     -> BraE xs0 (insertWith' f' y braFy mpx) -- N.B. Use of strict insertWith'+                    where f' lmp = u lmp braFy+                          braFy  = BraF ys ay mpy+------------------------------------------+ u (BraE xs0 mpx) (BraE ys0 mpy) = case match xs0 ys0 of+  Mat            -> BraE xs0 (union' u mpx mpy) -- N.B. Use of strict union'+  Frk n f' xs ys -> BraE (takeN n xs0) (f' (BraE xs mpx) (BraE ys mpy))+  Sfx _ x xs     -> BraE ys0 (insertWith' f' x braEx mpy) -- N.B. Use of strict insertWith'+                    where f' lmp = u braEx lmp+                          braEx  = BraE xs mpx+  Sfy _ y ys     -> BraE xs0 (insertWith' f' y braEy mpx) -- N.B. Use of strict insertWith'+                    where f' lmp = u lmp braEy+                          braEy  = BraE ys mpy+------------------------------------------+++-- |  See 'Map' class method 'union''.+unionListMap' ::  Map map k => (a -> a -> a) -> ListMap map k a -> ListMap map k a -> ListMap map k a+unionListMap' f lmp0 lmp1 = u lmp0 lmp1 where+ u Empt lmp  = lmp+ u lmp  Empt = lmp+------------------------------------------+ u (BraF xs0 ax mpx) (BraF ys0 ay mpy) = case match xs0 ys0 of+  Mat            -> let a = f ax ay in a `seq` BraF xs0 a (union' u mpx mpy) -- N.B. Use of strict union'+  Frk n f' xs ys -> BraE (takeN n xs0) (left `seq` right `seq` f' left right)+  		    where left = BraF xs ax mpx+  		    	  right = BraF ys ay mpy+  Sfx _ x xs     -> BraF ys0 ay (insertWith' f' x braFx mpy) -- N.B. Use of strict insertWith'+                    where f' lmp = u braFx lmp+                          braFx  = BraF xs ax mpx+  Sfy _ y ys     -> BraF xs0 ax (insertWith' f' y braFy mpx) -- N.B. Use of strict insertWith'+                    where f' lmp = u lmp braFy+                          braFy  = BraF ys ay mpy+------------------------------------------+ u (BraF xs0 ax mpx) (BraE ys0 mpy) = case match xs0 ys0 of+  Mat            -> BraF xs0 ax (union' u mpx mpy) -- N.B. Use of strict union'+  Frk n f' xs ys -> BraE (takeN n xs0) (left `seq` f' left right)+  		    where left = BraF xs ax mpx+  		    	  right = BraE ys mpy+  Sfx _ x xs     -> BraE ys0 (insertWith' f' x braFx mpy) -- N.B. Use of strict insertWith'+                    where f' lmp = u braFx lmp+                          braFx  = BraF xs ax mpx+  Sfy _ y ys     -> BraF xs0 ax (insertWith' f' y braEy mpx) -- N.B. Use of strict insertWith'+                    where f' lmp = u lmp braEy+                          braEy  = BraE ys mpy+------------------------------------------+ u (BraE xs0 mpx) (BraF ys0 ay mpy) = case match xs0 ys0 of+  Mat            -> BraF xs0 ay (union' u mpx mpy) -- N.B. Use of strict union'+  Frk n f' xs ys -> BraE (takeN n xs0) (right `seq` f' left right)+  		    where left = BraE xs mpx+  		    	  right = BraF ys ay mpy+  Sfx _ x xs     -> BraF ys0 ay (insertWith' f' x braEx mpy) -- N.B. Use of strict insertWith'+                    where f' lmp = u braEx lmp+                          braEx  = BraE xs mpx+  Sfy _ y ys     -> BraE xs0 (insertWith' f' y braFy mpx) -- N.B. Use of strict insertWith'+                    where f' lmp = u lmp braFy+                          braFy  = BraF ys ay mpy+------------------------------------------+ u (BraE xs0 mpx) (BraE ys0 mpy) = case match xs0 ys0 of+  Mat            -> BraE xs0 (union' u mpx mpy) -- N.B. Use of strict union'+  Frk n f' xs ys -> BraE (takeN n xs0) (f' (BraE xs mpx) (BraE ys mpy))+  Sfx _ x xs     -> BraE ys0 (insertWith' f' x braEx mpy) -- N.B. Use of strict insertWith'+                    where f' lmp = u braEx lmp+                          braEx  = BraE xs mpx+  Sfy _ y ys     -> BraE xs0 (insertWith' f' y braEy mpx) -- N.B. Use of strict insertWith'+                    where f' lmp = u lmp braEy+                          braEy  = BraE ys mpy+------------------------------------------+++-- |  See 'Map' class method 'unionMaybe'.+unionMaybeListMap ::  Map map k => (a -> a -> Maybe a) -> ListMap map k a -> ListMap map k a -> ListMap map k a+unionMaybeListMap f lmp0 lmp1 = u lmp0 lmp1 where+ uNE lmpx lmpy = nonEmptyListMap (u lmpx lmpy) -- unionMaybe can yield empty maps !!+------------------------------------------+ u Empt lmp  = lmp+ u lmp  Empt = lmp+------------------------------------------+ u (BraF xs0 ax mpx) (BraF ys0 ay mpy) = case match xs0 ys0 of+  Mat            -> case f ax ay of+                    Just a  -> BraF xs0 a (unionMaybe' uNE mpx mpy)+                    Nothing -> braE xs0   (unionMaybe' uNE mpx mpy) -- N.B Use of braE, not BraE !!+  Frk n f' xs ys -> BraE (takeN n xs0) (f' (BraF xs ax mpx) (BraF ys ay mpy))+  Sfx _ x xs     -> BraF ys0 ay (insertMaybe' f' x braFx mpy)+                    where f' lmp = uNE braFx lmp+                          braFx  = BraF xs ax mpx+  Sfy _ y ys     -> BraF xs0 ax (insertMaybe' f' y braFy mpx)+                    where f' lmp = uNE lmp braFy+                          braFy  = BraF ys ay mpy+------------------------------------------+ u (BraF xs0 ax mpx) (BraE ys0 mpy) = case match xs0 ys0 of+  Mat            -> BraF xs0 ax (unionMaybe' uNE mpx mpy)+  Frk n f' xs ys -> BraE (takeN n xs0) (f' (BraF xs ax mpx) (BraE ys mpy))+  Sfx _ x xs     -> braE ys0 (insertMaybe' f' x braFx mpy) -- N.B Use of braE, not BraE !!+                    where f' lmp = uNE braFx lmp+                          braFx  = BraF xs ax mpx+  Sfy _ y ys     -> BraF xs0 ax (insertMaybe' f' y braEy mpx)+                    where f' lmp = uNE lmp braEy+                          braEy  = BraE ys mpy+------------------------------------------+ u (BraE xs0 mpx) (BraF ys0 ay mpy) = case match xs0 ys0 of+  Mat            -> BraF xs0 ay (unionMaybe' uNE mpx mpy)+  Frk n f' xs ys -> BraE (takeN n xs0) (f' (BraE xs mpx) (BraF ys ay mpy))+  Sfx _ x xs     -> BraF ys0 ay (insertMaybe' f' x braEx mpy)+                    where f' lmp = uNE braEx lmp+                          braEx  = BraE xs mpx+  Sfy _ y ys     -> braE xs0 (insertMaybe' f' y braFy mpx) -- N.B Use of braE, not BraE !!+                    where f' lmp = uNE lmp braFy+                          braFy  = BraF ys ay mpy+------------------------------------------+ u (BraE xs0 mpx) (BraE ys0 mpy) = case match xs0 ys0 of+  Mat            -> braE xs0 (unionMaybe' uNE mpx mpy)  -- N.B Use of braE, not BraE !!+  Frk n f' xs ys -> BraE (takeN n xs0) (f' (BraE xs mpx) (BraE ys mpy))+  Sfx _ x xs     -> braE ys0 (insertMaybe' f' x braEx mpy) -- N.B Use of braE, not BraE !!+                    where f' lmp = uNE braEx lmp+                          braEx  = BraE xs mpx+  Sfy _ y ys     -> braE xs0 (insertMaybe' f' y braEy mpx) -- N.B Use of braE, not BraE !!+                    where f' lmp = uNE lmp braEy+                          braEy  = BraE ys mpy+------------------------------------------++-- |  See 'Map' class method 'intersection'.+intersectionListMap ::  Map map k => (a -> b -> c) -> ListMap map k a -> ListMap map k b -> ListMap map k c+intersectionListMap f lmp0 lmp1 = i lmp0 lmp1 where+ iNE lmpx lmpy = nonEmptyListMap (i lmpx lmpy) -- intersection can yield empty maps !!+------------------------------------------+ i Empt _    = Empt+ i _    Empt = Empt+------------------------------------------+ i (BraF xs0 a mpx) (BraF ys0 b mpy) = m xs0 ys0 where+  m []     []     = BraF xs0 (f a b) (intersectionMaybe iNE mpx mpy)+  m (x:xs) []     = case lookup x mpy of Nothing   -> Empt+                                         Just lmpb -> case i (BraF xs a mpx) lmpb of+                                                      Empt          -> Empt+                                                      BraF zs c mpz -> BraF (ys0 +!+ x:zs) c mpz+                                                      BraE zs   mpz -> BraE (ys0 +!+ x:zs)   mpz+  m []     (y:ys) = case lookup y mpx of Nothing   -> Empt+                                         Just lmpa -> case i lmpa (BraF ys b mpy) of+                                                      Empt          -> Empt+                                                      BraF zs c mpz -> BraF (xs0 +!+ y:zs) c mpz+                                                      BraE zs   mpz -> BraE (xs0 +!+ y:zs)   mpz+  m (x:xs) (y:ys) = if x == y then m xs ys else Empt+------------------------------------------+ i (BraF xs0 a mpx) (BraE ys0 mpy) = m xs0 ys0 where+  m []     []     = braE xs0 (intersectionMaybe iNE mpx mpy) -- Note use of braE!+  m (x:xs) []     = case lookup x mpy of Nothing   -> Empt+                                         Just lmpb -> case i (BraF xs a mpx) lmpb of+                                                      Empt          -> Empt+                                                      BraF zs c mpz -> BraF (ys0 +!+ x:zs) c mpz+                                                      BraE zs   mpz -> BraE (ys0 +!+ x:zs)   mpz+  m []     (y:ys) = case lookup y mpx of Nothing   -> Empt+                                         Just lmpa -> case i lmpa (BraE ys mpy) of+                                                      Empt          -> Empt+                                                      BraF zs c mpz -> BraF (xs0 +!+ y:zs) c mpz+                                                      BraE zs   mpz -> BraE (xs0 +!+ y:zs)   mpz+  m (x:xs) (y:ys) = if x == y then m xs ys else Empt+------------------------------------------+ i (BraE xs0 mpx) (BraF ys0 b mpy) = m xs0 ys0 where+  m []     []     = braE xs0 (intersectionMaybe iNE mpx mpy) -- Note use of braE!+  m (x:xs) []     = case lookup x mpy of Nothing   -> Empt+                                         Just lmpb -> case i (BraE xs mpx) lmpb of+                                                      Empt          -> Empt+                                                      BraF zs c mpz -> BraF (ys0 +!+ x:zs) c mpz+                                                      BraE zs   mpz -> BraE (ys0 +!+ x:zs)   mpz+  m []     (y:ys) = case lookup y mpx of Nothing   -> Empt+                                         Just lmpa -> case i lmpa (BraF ys b mpy) of+                                                      Empt          -> Empt+                                                      BraF zs c mpz -> BraF (xs0 +!+ y:zs) c mpz+                                                      BraE zs   mpz -> BraE (xs0 +!+ y:zs)   mpz+  m (x:xs) (y:ys) = if x == y then m xs ys else Empt+------------------------------------------+ i (BraE xs0 mpx) (BraE ys0 mpy) = m xs0 ys0 where+  m []     []     = braE xs0 (intersectionMaybe iNE mpx mpy) -- Note use of braE!+  m (x:xs) []     = case lookup x mpy of Nothing   -> Empt+                                         Just lmpb -> case i (BraE xs mpx) lmpb of+                                                      Empt          -> Empt+                                                      BraF zs c mpz -> BraF (ys0 +!+ x:zs) c mpz+                                                      BraE zs   mpz -> BraE (ys0 +!+ x:zs)   mpz+  m []     (y:ys) = case lookup y mpx of Nothing   -> Empt+                                         Just lmpa -> case i lmpa (BraE ys mpy) of+                                                      Empt          -> Empt+                                                      BraF zs c mpz -> BraF (xs0 +!+ y:zs) c mpz+                                                      BraE zs   mpz -> BraE (xs0 +!+ y:zs)   mpz+  m (x:xs) (y:ys) = if x == y then m xs ys else Empt+------------------------------------------+++-- |  See 'Map' class method 'intersection''.+intersectionListMap' ::  Map map k => (a -> b -> c) -> ListMap map k a -> ListMap map k b -> ListMap map k c+intersectionListMap' f lmp0 lmp1 = i lmp0 lmp1 where+ iNE lmpx lmpy = nonEmptyListMap (i lmpx lmpy) -- intersection can yield empty maps !!+------------------------------------------+ i Empt _    = Empt+ i _    Empt = Empt+------------------------------------------+ i (BraF xs0 a mpx) (BraF ys0 b mpy) = m xs0 ys0 where+  m []     []     = let c = f a b in c `seq` BraF xs0 c (intersectionMaybe iNE mpx mpy)+  m (x:xs) []     = case lookup x mpy of Nothing   -> Empt+                                         Just lmpb -> case i (BraF xs a mpx) lmpb of+                                                      Empt          -> Empt+                                                      BraF zs c mpz -> BraF (ys0 +!+ x:zs) c mpz+                                                      BraE zs   mpz -> BraE (ys0 +!+ x:zs)   mpz+  m []     (y:ys) = case lookup y mpx of Nothing   -> Empt+                                         Just lmpa -> case i lmpa (BraF ys b mpy) of+                                                      Empt          -> Empt+                                                      BraF zs c mpz -> BraF (xs0 +!+ y:zs) c mpz+                                                      BraE zs   mpz -> BraE (xs0 +!+ y:zs)   mpz+  m (x:xs) (y:ys) = if x == y then m xs ys else Empt+------------------------------------------+ i (BraF xs0 a mpx) (BraE ys0 mpy) = m xs0 ys0 where+  m []     []     = braE xs0 (intersectionMaybe iNE mpx mpy) -- Note use of braE!+  m (x:xs) []     = case lookup x mpy of Nothing   -> Empt+                                         Just lmpb -> case i (BraF xs a mpx) lmpb of+                                                      Empt          -> Empt+                                                      BraF zs c mpz -> BraF (ys0 +!+ x:zs) c mpz+                                                      BraE zs   mpz -> BraE (ys0 +!+ x:zs)   mpz+  m []     (y:ys) = case lookup y mpx of Nothing   -> Empt+                                         Just lmpa -> case i lmpa (BraE ys mpy) of+                                                      Empt          -> Empt+                                                      BraF zs c mpz -> BraF (xs0 +!+ y:zs) c mpz+                                                      BraE zs   mpz -> BraE (xs0 +!+ y:zs)   mpz+  m (x:xs) (y:ys) = if x == y then m xs ys else Empt+------------------------------------------+ i (BraE xs0 mpx) (BraF ys0 b mpy) = m xs0 ys0 where+  m []     []     = braE xs0 (intersectionMaybe iNE mpx mpy) -- Note use of braE!+  m (x:xs) []     = case lookup x mpy of Nothing   -> Empt+                                         Just lmpb -> case i (BraE xs mpx) lmpb of+                                                      Empt          -> Empt+                                                      BraF zs c mpz -> BraF (ys0 +!+ x:zs) c mpz+                                                      BraE zs   mpz -> BraE (ys0 +!+ x:zs)   mpz+  m []     (y:ys) = case lookup y mpx of Nothing   -> Empt+                                         Just lmpa -> case i lmpa (BraF ys b mpy) of+                                                      Empt          -> Empt+                                                      BraF zs c mpz -> BraF (xs0 +!+ y:zs) c mpz+                                                      BraE zs   mpz -> BraE (xs0 +!+ y:zs)   mpz+  m (x:xs) (y:ys) = if x == y then m xs ys else Empt+------------------------------------------+ i (BraE xs0 mpx) (BraE ys0 mpy) = m xs0 ys0 where+  m []     []     = braE xs0 (intersectionMaybe iNE mpx mpy) -- Note use of braE!+  m (x:xs) []     = case lookup x mpy of Nothing   -> Empt+                                         Just lmpb -> case i (BraE xs mpx) lmpb of+                                                      Empt          -> Empt+                                                      BraF zs c mpz -> BraF (ys0 +!+ x:zs) c mpz+                                                      BraE zs   mpz -> BraE (ys0 +!+ x:zs)   mpz+  m []     (y:ys) = case lookup y mpx of Nothing   -> Empt+                                         Just lmpa -> case i lmpa (BraE ys mpy) of+                                                      Empt          -> Empt+                                                      BraF zs c mpz -> BraF (xs0 +!+ y:zs) c mpz+                                                      BraE zs   mpz -> BraE (xs0 +!+ y:zs)   mpz+  m (x:xs) (y:ys) = if x == y then m xs ys else Empt+------------------------------------------+++-- |  See 'Map' class method 'intersectionMaybe'.+intersectionMaybeListMap ::  Map map k => (a -> b -> Maybe c) -> ListMap map k a -> ListMap map k b -> ListMap map k c+intersectionMaybeListMap f lmp0 lmp1 = i lmp0 lmp1 where+ iNE lmpx lmpy = nonEmptyListMap (i lmpx lmpy) -- intersection can yield empty maps !!+------------------------------------------+ i Empt _    = Empt+ i _    Empt = Empt+------------------------------------------+ i (BraF xs0 a mpx) (BraF ys0 b mpy) = m xs0 ys0 where+  m []     []     = case f a b of+                    Just c  -> BraF xs0 c (intersectionMaybe' iNE mpx mpy)+                    Nothing -> braE xs0   (intersectionMaybe' iNE mpx mpy) -- Note use of braE!+  m (x:xs) []     = case lookup x mpy of Nothing   -> Empt+                                         Just lmpb -> case i (BraF xs a mpx) lmpb of+                                                      Empt          -> Empt+                                                      BraF zs c mpz -> BraF (ys0 +!+ x:zs) c mpz+                                                      BraE zs   mpz -> BraE (ys0 +!+ x:zs)   mpz+  m []     (y:ys) = case lookup y mpx of Nothing   -> Empt+                                         Just lmpa -> case i lmpa (BraF ys b mpy) of+                                                      Empt          -> Empt+                                                      BraF zs c mpz -> BraF (xs0 +!+ y:zs) c mpz+                                                      BraE zs   mpz -> BraE (xs0 +!+ y:zs)   mpz+  m (x:xs) (y:ys) = if x == y then m xs ys else Empt+------------------------------------------+ i (BraF xs0 a mpx) (BraE ys0 mpy) = m xs0 ys0 where+  m []     []     = braE xs0 (intersectionMaybe' iNE mpx mpy) -- Note use of braE!+  m (x:xs) []     = case lookup x mpy of Nothing   -> Empt+                                         Just lmpb -> case i (BraF xs a mpx) lmpb of+                                                      Empt          -> Empt+                                                      BraF zs c mpz -> BraF (ys0 +!+ x:zs) c mpz+                                                      BraE zs   mpz -> BraE (ys0 +!+ x:zs)   mpz+  m []     (y:ys) = case lookup y mpx of Nothing   -> Empt+                                         Just lmpa -> case i lmpa (BraE ys mpy) of+                                                      Empt          -> Empt+                                                      BraF zs c mpz -> BraF (xs0 +!+ y:zs) c mpz+                                                      BraE zs   mpz -> BraE (xs0 +!+ y:zs)   mpz+  m (x:xs) (y:ys) = if x == y then m xs ys else Empt+------------------------------------------+ i (BraE xs0 mpx) (BraF ys0 b mpy) = m xs0 ys0 where+  m []     []     = braE xs0 (intersectionMaybe' iNE mpx mpy) -- Note use of braE!+  m (x:xs) []     = case lookup x mpy of Nothing   -> Empt+                                         Just lmpb -> case i (BraE xs mpx) lmpb of+                                                      Empt          -> Empt+                                                      BraF zs c mpz -> BraF (ys0 +!+ x:zs) c mpz+                                                      BraE zs   mpz -> BraE (ys0 +!+ x:zs)   mpz+  m []     (y:ys) = case lookup y mpx of Nothing   -> Empt+                                         Just lmpa -> case i lmpa (BraF ys b mpy) of+                                                      Empt          -> Empt+                                                      BraF zs c mpz -> BraF (xs0 +!+ y:zs) c mpz+                                                      BraE zs   mpz -> BraE (xs0 +!+ y:zs)   mpz+  m (x:xs) (y:ys) = if x == y then m xs ys else Empt+------------------------------------------+ i (BraE xs0 mpx) (BraE ys0 mpy) = m xs0 ys0 where+  m []     []     = braE xs0 (intersectionMaybe' iNE mpx mpy) -- Note use of braE!+  m (x:xs) []     = case lookup x mpy of Nothing   -> Empt+                                         Just lmpb -> case i (BraE xs mpx) lmpb of+                                                      Empt          -> Empt+                                                      BraF zs c mpz -> BraF (ys0 +!+ x:zs) c mpz+                                                      BraE zs   mpz -> BraE (ys0 +!+ x:zs)   mpz+  m []     (y:ys) = case lookup y mpx of Nothing   -> Empt+                                         Just lmpa -> case i lmpa (BraE ys mpy) of+                                                      Empt          -> Empt+                                                      BraF zs c mpz -> BraF (xs0 +!+ y:zs) c mpz+                                                      BraE zs   mpz -> BraE (xs0 +!+ y:zs)   mpz+  m (x:xs) (y:ys) = if x == y then m xs ys else Empt+------------------------------------------++-- | See 'Map' class method 'difference'.+differenceListMap :: Map map k => ListMap map k a -> ListMap map k b -> ListMap map k a+differenceListMap lmp0 lmp1 = d lmp0 lmp1 where+ dNE lmpx lmpy = nonEmptyListMap (d lmpx lmpy) -- difference can yield empty maps !!+------------------------------------------+ d Empt _    = Empt+ d lmpx Empt = lmpx+------------------------------------------+ d lmpx@(BraF xs0 a mpx) (BraF ys0 b mpy) = m xs0 ys0 where+  m []     []     = braE xs0 (differenceMaybe' dNE mpx mpy) -- Note use of braE!+  m (x:xs) []     = case lookup x mpy of Nothing   -> lmpx+                                         Just lmpb -> case d (BraF xs a mpx) lmpb of+                                                      Empt           -> Empt+                                                      BraF zs a' mpz -> BraF (ys0 +!+ x:zs) a' mpz+                                                      BraE zs    mpz -> BraE (ys0 +!+ x:zs)    mpz+  m []     (y:ys) = BraF xs0 a (adjustMaybe' (\lmpa -> dNE lmpa (BraF ys b mpy)) y mpx)+  m (x:xs) (y:ys) = if x==y then m xs ys else lmpx+------------------------------------------+ d lmpx@(BraF xs0 a mpx) (BraE ys0 mpy) = m xs0 ys0 where+  m []     []     = BraF xs0 a (differenceMaybe' dNE mpx mpy)+  m (x:xs) []     = case lookup x mpy of Nothing   -> lmpx+                                         Just lmpb -> case d (BraF xs a mpx) lmpb of+                                                      Empt           -> Empt+                                                      BraF zs a' mpz -> BraF (ys0 +!+ x:zs) a' mpz+                                                      BraE zs    mpz -> BraE (ys0 +!+ x:zs)    mpz+  m []     (y:ys) = BraF xs0 a (adjustMaybe' (\lmpa -> dNE lmpa (BraE ys mpy)) y mpx)+  m (x:xs) (y:ys) = if x==y then m xs ys else lmpx+------------------------------------------+ d lmpx@(BraE xs0 mpx) (BraF ys0 b mpy) = m xs0 ys0 where+  m []     []     = braE xs0 (differenceMaybe' dNE mpx mpy) -- Note use of braE!+  m (x:xs) []     = case lookup x mpy of Nothing   -> lmpx+                                         Just lmpb -> case d (BraE xs mpx) lmpb of+                                                      Empt           -> Empt+                                                      BraF zs a' mpz -> BraF (ys0 +!+ x:zs) a' mpz+                                                      BraE zs    mpz -> BraE (ys0 +!+ x:zs)    mpz+  m []     (y:ys) = braE xs0 (adjustMaybe' (\lmpa -> dNE lmpa (BraF ys b mpy)) y mpx) -- Note use of braE!+  m (x:xs) (y:ys) = if x==y then m xs ys else lmpx+------------------------------------------+ d lmpx@(BraE xs0 mpx) (BraE ys0 mpy) = m xs0 ys0 where+  m []     []     = braE xs0 (differenceMaybe' dNE mpx mpy) -- Note use of braE!+  m (x:xs) []     = case lookup x mpy of Nothing   -> lmpx+                                         Just lmpb -> case d (BraE xs mpx) lmpb of+                                                      Empt           -> Empt+                                                      BraF zs a' mpz -> BraF (ys0 +!+ x:zs) a' mpz+                                                      BraE zs    mpz -> BraE (ys0 +!+ x:zs)    mpz+  m []     (y:ys) = braE xs0 (adjustMaybe' (\lmpa -> dNE lmpa (BraE ys mpy)) y mpx) -- Note use of braE!+  m (x:xs) (y:ys) = if x==y then m xs ys else lmpx+------------------------------------------+++-- | See 'Map' class method 'differenceMaybe'.+differenceMaybeListMap :: Map map k => (a -> b -> Maybe a) -> ListMap map k a -> ListMap map k b -> ListMap map k a+differenceMaybeListMap f lmp0 lmp1 = d lmp0 lmp1 where+ dNE lmpx lmpy = nonEmptyListMap (d lmpx lmpy) -- difference can yield empty maps !!+------------------------------------------+ d Empt _    = Empt+ d lmpx Empt = lmpx+------------------------------------------+ d lmpx@(BraF xs0 a mpx) (BraF ys0 b mpy) = m xs0 ys0 where+  m []     []     = case f a b of+                    Nothing -> braE xs0    (differenceMaybe' dNE mpx mpy) -- Note use of braE!+                    Just a' -> BraF xs0 a' (differenceMaybe' dNE mpx mpy)+  m (x:xs) []     = case lookup x mpy of Nothing   -> lmpx+                                         Just lmpb -> case d (BraF xs a mpx) lmpb of+                                                      Empt           -> Empt+                                                      BraF zs a' mpz -> BraF (ys0 +!+ x:zs) a' mpz+                                                      BraE zs    mpz -> BraE (ys0 +!+ x:zs)    mpz+  m []     (y:ys) = BraF xs0 a (adjustMaybe' (\lmpa -> dNE lmpa (BraF ys b mpy)) y mpx)+  m (x:xs) (y:ys) = if x==y then m xs ys else lmpx+------------------------------------------+ d lmpx@(BraF xs0 a mpx) (BraE ys0 mpy) = m xs0 ys0 where+  m []     []     = BraF xs0 a (differenceMaybe' dNE mpx mpy)+  m (x:xs) []     = case lookup x mpy of Nothing   -> lmpx+                                         Just lmpb -> case d (BraF xs a mpx) lmpb of+                                                      Empt           -> Empt+                                                      BraF zs a' mpz -> BraF (ys0 +!+ x:zs) a' mpz+                                                      BraE zs    mpz -> BraE (ys0 +!+ x:zs)    mpz+  m []     (y:ys) = BraF xs0 a (adjustMaybe' (\lmpa -> dNE lmpa (BraE ys mpy)) y mpx)+  m (x:xs) (y:ys) = if x==y then m xs ys else lmpx+------------------------------------------+ d lmpx@(BraE xs0 mpx) (BraF ys0 b mpy) = m xs0 ys0 where+  m []     []     = braE xs0 (differenceMaybe' dNE mpx mpy) -- Note use of braE!+  m (x:xs) []     = case lookup x mpy of Nothing   -> lmpx+                                         Just lmpb -> case d (BraE xs mpx) lmpb of+                                                      Empt           -> Empt+                                                      BraF zs a' mpz -> BraF (ys0 +!+ x:zs) a' mpz+                                                      BraE zs    mpz -> BraE (ys0 +!+ x:zs)    mpz+  m []     (y:ys) = braE xs0 (adjustMaybe' (\lmpa -> dNE lmpa (BraF ys b mpy)) y mpx) -- Note use of braE!+  m (x:xs) (y:ys) = if x==y then m xs ys else lmpx+------------------------------------------+ d lmpx@(BraE xs0 mpx) (BraE ys0 mpy) = m xs0 ys0 where+  m []     []     = braE xs0 (differenceMaybe' dNE mpx mpy) -- Note use of braE!+  m (x:xs) []     = case lookup x mpy of Nothing   -> lmpx+                                         Just lmpb -> case d (BraE xs mpx) lmpb of+                                                      Empt           -> Empt+                                                      BraF zs a' mpz -> BraF (ys0 +!+ x:zs) a' mpz+                                                      BraE zs    mpz -> BraE (ys0 +!+ x:zs)    mpz+  m []     (y:ys) = braE xs0 (adjustMaybe' (\lmpa -> dNE lmpa (BraE ys mpy)) y mpx) -- Note use of braE!+  m (x:xs) (y:ys) = if x==y then m xs ys else lmpx+------------------------------------------++-- | See 'Map' class method 'isSubsetOf'.+isSubsetOfListMap :: Map map k => ListMap map k a -> ListMap map k b -> Bool+-- This is basically finding out if (differenceListMap lmp0 lmp1 == Empt)+-- If so, lmp0 is a submap of lmp1.+------------------------------------------+isSubsetOfListMap Empt _    = True+isSubsetOfListMap _    Empt = False +------------------------------------------+isSubsetOfListMap (BraF xs0 a mpx) (BraF ys0 _ mpy) = m xs0 ys0 where+  m []     []     = isSubmapOf isSubsetOfListMap mpx mpy+  m (x:xs) []     = case lookup x mpy of Nothing   -> False+                                         Just lmpb -> isSubsetOfListMap (BraF xs a mpx) lmpb+  m []     (_:_ ) = False+  m (x:xs) (y:ys) = if x==y then m xs ys else False+------------------------------------------+isSubsetOfListMap (BraF xs0 a mpx) (BraE ys0 mpy) = m xs0 ys0 where+  m []     []     = False+  m (x:xs) []     = case lookup x mpy of Nothing   -> False+                                         Just lmpb -> isSubsetOfListMap (BraF xs a mpx) lmpb+  m []     (_:_ ) = False+  m (x:xs) (y:ys) = if x==y then m xs ys else False+------------------------------------------+isSubsetOfListMap (BraE xs0 mpx) (BraF ys0 _ mpy) = m xs0 ys0 where+  m []     []     = isSubmapOf isSubsetOfListMap mpx mpy+  m (x:xs) []     = case lookup x mpy of Nothing   -> False+                                         Just lmpb -> isSubsetOfListMap (BraE xs mpx) lmpb+  m []     (_:_ ) = False -- mpx must contain at least 2 entries+  m (x:xs) (y:ys) = if x==y then m xs ys else False+------------------------------------------+isSubsetOfListMap (BraE xs0 mpx) (BraE ys0 mpy) = m xs0 ys0 where+  m []     []     = isSubmapOf isSubsetOfListMap mpx mpy+  m (x:xs) []     = case lookup x mpy of Nothing   -> False+                                         Just lmpb -> isSubsetOfListMap (BraE xs mpx) lmpb+  m []     (_:_ ) = False -- mpx must contain at least 2 entries+  m (x:xs) (y:ys) = if x==y then m xs ys else False+------------------------------------------+++-- | See 'Map' class method 'isSubmapOf'.+isSubmapOfListMap :: Map map k => (a -> b -> Bool) -> ListMap map k a -> ListMap map k b -> Bool+isSubmapOfListMap p lmp0 lmp1 = d lmp0 lmp1 where+------------------------------------------+ d Empt _    = True+ d _    Empt = False+------------------------------------------+ d (BraF xs0 a mpx) (BraF ys0 b mpy) = m xs0 ys0 where+  m []     []     = if p a b then isSubmapOf d mpx mpy else False+  m (x:xs) []     = case lookup x mpy of Nothing   -> False+                                         Just lmpb -> d (BraF xs a mpx) lmpb+  m []     (_:_ ) = False+  m (x:xs) (y:ys) = if x==y then m xs ys else False+------------------------------------------+ d (BraF xs0 a mpx) (BraE ys0 mpy) = m xs0 ys0 where+  m []     []     = False+  m (x:xs) []     = case lookup x mpy of Nothing   -> False+                                         Just lmpb -> d (BraF xs a mpx) lmpb+  m []     (_:_ ) = False+  m (x:xs) (y:ys) = if x==y then m xs ys else False+------------------------------------------+ d (BraE xs0 mpx) (BraF ys0 _ mpy) = m xs0 ys0 where+  m []     []     = isSubmapOf d mpx mpy+  m (x:xs) []     = case lookup x mpy of Nothing   -> False+                                         Just lmpb -> d (BraE xs mpx) lmpb+  m []     (_:_ ) = False -- mpx must contain at least 2 entries+  m (x:xs) (y:ys) = if x==y then m xs ys else False+------------------------------------------+ d (BraE xs0 mpx) (BraE ys0 mpy) = m xs0 ys0 where+  m []     []     = isSubmapOf d mpx mpy+  m (x:xs) []     = case lookup x mpy of Nothing   -> False+                                         Just lmpb -> d (BraE xs mpx) lmpb+  m []     (_:_ ) = False -- mpx must contain at least 2 entries+  m (x:xs) (y:ys) = if x==y then m xs ys else False+------------------------------------------++-- | See 'Map' class method 'alter'.+alterListMap :: Map map k => (Maybe a -> Maybe a) -> [k] -> ListMap map k a -> ListMap map k a+-- Convention below is xs is the search key list and ys is the key list fragment from the Trie (ListMap)+alterListMap f xs0 lmp0 = iw xs0 lmp0 where+ iwNE xs (Just lmp) = nonEmptyListMap (iw xs lmp) -- alter can yield empty maps !!+ iwNE xs  Nothing   = nonEmptyListMap (iw xs empty)+------------------------------+ iw xs Empt = case (f Nothing) of+ 		Just ax 	-> BraF xs ax empty+ 		Nothing		-> Empt+------------------------------+ iw xs m@(BraF ys ay mp) = case match xs ys of+   Mat              -> case (f (Just ay)) of   -- xs == ys+                        Just ax -> BraF ys ax mp+                        Nothing -> braE ys    mp -- N.B. Use of braE, not BraE+   Frk n f' xs' ys' -> case (f Nothing) of+   			Just ax -> BraE (takeN n ys) (f' (BraF xs' ax empty) (BraF ys' ay mp))+   			Nothing -> m+   Sfy _ y' ys'     -> case (f Nothing) of+   			Just ax -> BraF xs ax (singleton y' (BraF ys' ay mp))+   			Nothing -> m+   Sfx _ x' xs'     -> BraF ys ay (alter (iwNE xs') x' mp)+------------------------------+ iw xs m@(BraE ys mp) = case match xs ys of+   Mat              -> case (f Nothing) of+   			Just ax -> BraF ys ax mp   -- xs == ys+   			Nothing -> m+   Frk n f' xs' ys' -> case (f Nothing) of+   			Just ax -> BraE (takeN n ys) (f' (BraF xs' ax empty) (BraE ys' mp))+   			Nothing -> m+   Sfy _ y' ys'     -> case (f Nothing) of+   			Just ax -> BraF xs ax (singleton y' (BraE ys' mp))+   			Nothing -> m+   Sfx _ x' xs'     -> braE ys (alter (iwNE xs') x' mp)  -- N.B. Use of braE, not BraE+------------------------------++-- | See 'Map' class method 'insertWith'.+insertWithListMap :: Map map k => (a -> a) -> [k] -> a -> ListMap map k a -> ListMap map k a+-- Convention below is xs is the search key list and ys is the key list fragment from the Trie (ListMap)+-- N.B We always use the Strict insertWith' method here!+insertWithListMap f xs0 ax lmp0 = iw xs0 lmp0 where+ iw xs Empt = BraF xs ax empty+------------------------------+ iw xs (BraF ys ay mp) = case match xs ys of+   Mat              -> BraF ys (f ay) mp  -- xs == ys+   Frk n f' xs' ys' -> BraE (takeN n ys) (f' (BraF xs' ax empty) (BraF ys' ay mp))+   Sfy _ y' ys'     -> BraF xs ax (singleton y' (BraF ys' ay mp))+   Sfx _ x' xs'     -> BraF ys ay (insertWith' (iw xs') x' (BraF xs' ax empty) mp)+------------------------------+ iw xs (BraE ys mp) = case match xs ys of+   Mat              -> BraF ys ax mp   -- xs == ys+   Frk n f' xs' ys' -> BraE (takeN n ys) (f' (BraF xs' ax empty) (BraE ys' mp))+   Sfy _ y' ys'     -> BraF xs ax (singleton y' (BraE ys' mp))+   Sfx _ x' xs'     -> BraE ys (insertWith' (iw xs') x' (BraF xs' ax empty) mp)+------------------------------++-- | See 'Map' class method 'insertWith'''.+insertWithListMap' :: Map map k => (a -> a) -> [k] -> a -> ListMap map k a -> ListMap map k a+-- Convention below is xs is the search key list and ys is the key list fragment from the Trie (ListMap)+-- N.B We always use the Stricter insertWith'' method here!+insertWithListMap' f xs0 ax lmp0 = iw xs0 lmp0 where+ iw xs Empt = ax `seq` BraF xs ax empty+------------------------------+ iw xs (BraF ys ay mp) = case match xs ys of+   Mat              -> let ay' = f ay in ay' `seq` BraF ys ay' mp  -- xs == ys+   Frk n f' xs' ys' -> ax `seq` BraE (takeN n ys) (f' (BraF xs' ax empty) (BraF ys' ay mp))+   Sfy _ y' ys'     -> ax `seq` BraF xs ax (singleton y' (BraF ys' ay mp))+   Sfx _ x' xs'     -> BraF ys ay (insertWith' (iw xs') x' (ax `seq` (BraF xs' ax empty)) mp) -- N.B.!!+------------------------------+ iw xs (BraE ys mp) = case match xs ys of+   Mat              -> ax `seq` BraF ys ax mp   -- xs == ys+   Frk n f' xs' ys' -> ax `seq` BraE (takeN n ys) (f' (BraF xs' ax empty) (BraE ys' mp))+   Sfy _ y' ys'     -> ax `seq` BraF xs ax (singleton y' (BraE ys' mp))+   Sfx _ x' xs'     -> BraE ys (insertWith' (iw xs') x' (ax `seq` (BraF xs' ax empty)) mp) -- N.B.!!+------------------------------+++-- | See 'Map' class method 'insertMaybe'.+insertMaybeListMap :: Map map k => (a -> Maybe a) -> [k] -> a -> ListMap map k a -> ListMap map k a+-- Convention below is xs is the search key list and ys is the key list fragment from the Trie (ListMap)+insertMaybeListMap f xs0 ax lmp0 = iw xs0 lmp0 where+ iwNE xs lmp = nonEmptyListMap (iw xs lmp) -- insertMaybe can yield empty maps !!+------------------------------+ iw xs Empt = BraF xs ax empty+------------------------------+ iw xs (BraF ys ay mp) = case match xs ys of+   Mat              -> case f ay of   -- xs == ys+                       Just ay' -> BraF ys ay' mp+                       Nothing  -> braE ys     mp -- N.B. Use of braE, not BraE+   Frk n f' xs' ys' -> BraE (takeN n ys) (f' (BraF xs' ax empty) (BraF ys' ay mp))+   Sfy _ y' ys'     -> BraF xs ax (singleton y' (BraF ys' ay mp))+   Sfx _ x' xs'     -> BraF ys ay (insertMaybe (iwNE xs') x' (BraF xs' ax empty) mp)+------------------------------+ iw xs (BraE ys mp) = case match xs ys of+   Mat              -> BraF ys ax mp   -- xs == ys+   Frk n f' xs' ys' -> BraE (takeN n ys) (f' (BraF xs' ax empty) (BraE ys' mp))+   Sfy _ y' ys'     -> BraF xs ax (singleton y' (BraE ys' mp))+   Sfx _ x' xs'     -> braE ys (insertMaybe (iwNE xs') x' (BraF xs' ax empty) mp)  -- N.B. Use of braE, not BraE+------------------------------++-- | See 'Map' class method 'foldElems'.+foldElemsListMap :: Map map k => (a -> b -> b) -> b -> ListMap map k a -> b+foldElemsListMap f b0 lmp0  = fld lmp0 b0 where+ fld  Empt         b = b+ fld (BraF _ a mp) b = f a (foldElems fld b mp)+ fld (BraE _   mp) b =      foldElems fld b mp++-- | See 'Map' class method 'foldKeys'.+foldKeysListMap :: Map map k => ([k] -> b -> b) -> b -> ListMap map k a -> b+foldKeysListMap f b0 lmp0 = fld [] lmp0 b0 where+ fld _    Empt          b = b+ fld rks (BraF ks _ mp) b = f (revTo rks ks) (foldAssocs f' b mp)+                            where f' k lmp b' = fld (k : revTo ks rks) lmp b'+ fld rks (BraE ks   mp) b = foldAssocs f' b mp+                            where f' k lmp b' = fld (k : revTo ks rks) lmp b'++-- | See 'Map' class method 'foldAssocs'.+foldAssocsListMap :: Map map k => ([k] -> a -> b -> b) -> b -> ListMap map k a -> b+foldAssocsListMap f b0 lmp0 = fld [] lmp0 b0 where+ fld _    Empt          b = b+ fld rks (BraF ks a mp) b = f (revTo rks ks) a (foldAssocs f' b mp)+                            where f' k lmp b' = fld (k : revTo ks rks) lmp b'+ fld rks (BraE ks   mp) b = foldAssocs f' b mp+                            where f' k lmp b' = fld (k : revTo ks rks) lmp b'++-- | See 'Map' class method 'foldElems''.+foldElemsListMap' :: Map map k => (a -> b -> b) -> b -> ListMap map k a -> b+foldElemsListMap' f b0 lmp0 = fld lmp0 b0 where+ fld  Empt         b = b+ fld (BraF _ a mp) b = let b' = foldElems' fld b mp  in b' `seq` f a b'+ fld (BraE _   mp) b =          foldElems' fld b mp++-- | See 'Map' class method 'foldKeys''.+foldKeysListMap' :: Map map k => ([k] -> b -> b) -> b -> ListMap map k a -> b+foldKeysListMap' f b0 lmp0 = fld [] lmp0 b0 where+ fld _    Empt          b = b+ fld rks (BraF ks _ mp) b = b'' `seq` f (revTo rks ks) b''+                            where f' k lmp b' = fld (k : revTo ks rks) lmp b'+                                  b''         = foldAssocs' f' b mp+ fld rks (BraE ks   mp) b = foldAssocs' f' b mp+                            where f' k lmp b' = fld (k : revTo ks rks) lmp b'++-- | See 'Map' class method 'foldAssocs''.+foldAssocsListMap' :: Map map k => ([k] -> a -> b -> b) -> b -> ListMap map k a -> b+foldAssocsListMap' f b0 lmp0 = fld [] lmp0 b0 where+ fld _    Empt          b = b+ fld rks (BraF ks a mp) b = b'' `seq` f (revTo rks ks) a b''+                            where f' k lmp b' = fld (k : revTo ks rks) lmp b'+                                  b''         = foldAssocs' f' b mp+ fld rks (BraE ks   mp) b = foldAssocs' f' b mp+                            where f' k lmp b' = fld (k : revTo ks rks) lmp b'++------------------------------------------------------------------------------------------++-- Group an ordered list of assocs according to which part of the map they will form+clump :: (Eq a) => [([a], b)] -> [a] -> ([b], [(a, [([a], b)])])+clump as prefix = +	if 	null nonNulls+	then	(L.map snd nulls, [])+	else	(L.map snd nulls, clumps' [(k',c' [])])+	-- 'currentClump' and 'clumps' are list building continuations to preserve order of 'as'+	where 	f (currentKey,currentClump,clumps) (key,tl) =+			if 	key == currentKey+			then	(currentKey,  currentClump . (tl:),  clumps                                   )+			else	(key,        (tl:),                  clumps . ((currentKey,currentClump []):) )+		(nulls,nonNulls) = L.partition (null . fst) $ L.map (\(k,a) -> (fromJust $ L.stripPrefix prefix k,a)) as+		rest = L.map (\(k:ks,a) -> (k,(ks,a))) nonNulls+		(k',c',clumps') = L.foldl' f (fst $ head rest,id,id) rest+		+commonPrefix :: (Eq a) => [([a], b)] -> [a]+commonPrefix as = common (fst $ head as) (fst $ last as)+	where 	common [] _ = []+		common _ [] = []+		common (ka:kas) (kb:kbs) =+			if 	ka == kb+			then	ka : common kas kbs+			else	[]+	+fromAssocsAscWithListMap :: OrderedMap map k => (a -> a -> a) -> [([k],a)] -> ListMap map k a+fromAssocsAscWithListMap _ [] = emptyListMap+fromAssocsAscWithListMap f as = +	case nulls of+		[]	-> braE prefix                     (fromAssocsAsc innerAs) +		_	-> BraF prefix (L.foldl1' f nulls) (fromAssocsAsc innerAs) +	where	(nulls,clumps) = clump as prefix+		prefix = commonPrefix as+		innerAs = L.map (\(k,as') -> (k,fromAssocsAscWith f as')) clumps -- NB Shouldnt have any repeated keys in 'innerAs' if 'as' is ordered++fromAssocsDescWithListMap :: OrderedMap map k => (a -> a -> a) -> [([k],a)] -> ListMap map k a+fromAssocsDescWithListMap _ [] = emptyListMap+fromAssocsDescWithListMap f as = +	case nulls of+		[]	-> braE prefix                     (fromAssocsDesc innerAs) +		_	-> BraF prefix (L.foldl1' f nulls) (fromAssocsDesc innerAs) +	where	(nulls,clumps) = clump as prefix+		prefix = commonPrefix as+		innerAs = L.map (\(k,as') -> (k,fromAssocsDescWith f as')) clumps -- NB Shouldnt have any repeated keys in 'innerAs' if 'as' is ordered+		+fromAssocsAscMaybeListMap :: OrderedMap map k => (a -> a -> Maybe a) -> [([k],a)] -> ListMap map k a+fromAssocsAscMaybeListMap _ [] = emptyListMap+fromAssocsAscMaybeListMap f as = +	case L.foldl' insNull Nothing nulls of+		Nothing	-> braE prefix   (fromAssocsAsc innerAs) +		Just a	-> BraF prefix a (fromAssocsAsc innerAs) +	where	insNull Nothing  b = Just b+		insNull (Just a) b = f a b+		(nulls,clumps) = clump as prefix+		prefix = commonPrefix as+		innerAs = catMaybes $ L.map (\(k,as') -> do mp <- nonEmpty $ fromAssocsAscMaybe f as'; return (k,mp)) clumps+		 -- NB Shouldnt have any repeated keys in 'innerAs' if 'as' is ordered++fromAssocsDescMaybeListMap :: OrderedMap map k => (a -> a -> Maybe a) -> [([k],a)] -> ListMap map k a+fromAssocsDescMaybeListMap _ [] = emptyListMap+fromAssocsDescMaybeListMap f as = +	case L.foldl' insNull Nothing nulls of+		Nothing	-> braE prefix   (fromAssocsDesc innerAs)+		Just a	-> BraF prefix a (fromAssocsDesc innerAs)+	where	insNull Nothing  b = Just b+		insNull (Just a) b = f a b+		(nulls,clumps) = clump as prefix+		prefix = commonPrefix as+		innerAs = catMaybes $ L.map (\(k,as') -> do mp <- nonEmpty $ fromAssocsDescMaybe f as'; return (k,mp)) clumps+		 -- NB Shouldnt have any repeated keys in 'innerAs' if 'as' is ordered++-- | See 'Map' class method 'foldElemsAsc'.+foldElemsAscListMap :: OrderedMap map k => (a -> b -> b) -> b -> ListMap map k a -> b+foldElemsAscListMap f b0 lmp0  = fld lmp0 b0 where+ fld  Empt         b = b+ fld (BraF _ a mp) b = f a (foldElemsAsc fld b mp)+ fld (BraE _   mp) b =      foldElemsAsc fld b mp++-- | See 'Map' class method 'foldElemsDesc'.+foldElemsDescListMap :: OrderedMap map k => (a -> b -> b) -> b -> ListMap map k a -> b+foldElemsDescListMap f b0 lmp0 = fld lmp0 b0 where+ fld  Empt         b = b+ fld (BraF _ a mp) b = foldElemsDesc fld (f a b) mp+ fld (BraE _   mp) b = foldElemsDesc fld b       mp++-- | See 'Map' class method 'foldKeysAsc'.+foldKeysAscListMap :: OrderedMap map k => ([k] -> b -> b) -> b -> ListMap map k a -> b+foldKeysAscListMap f b0 lmp0 = fld [] lmp0 b0 where+ fld _    Empt          b = b+ fld rks (BraF ks _ mp) b = f (revTo rks ks) (foldAssocsAsc f' b mp)+                            where f' k lmp b' = fld (k : revTo ks rks) lmp b'+ fld rks (BraE ks   mp) b = foldAssocsAsc f' b mp+                            where f' k lmp b' = fld (k : revTo ks rks) lmp b'++-- | See 'Map' class method 'foldKeysDesc'.+foldKeysDescListMap :: OrderedMap map k => ([k] -> b -> b) -> b -> ListMap map k a -> b+foldKeysDescListMap f b0 lmp0 = fld [] lmp0 b0 where+ fld _    Empt          b = b+ fld rks (BraF ks _ mp) b = foldAssocsDesc f' (f (revTo rks ks) b) mp+                            where f' k lmp b' = fld (k : revTo ks rks) lmp b'+ fld rks (BraE ks   mp) b = foldAssocsDesc f' b mp+                            where f' k lmp b' = fld (k : revTo ks rks) lmp b'++-- | See 'Map' class method 'foldAssocsAsc'.+foldAssocsAscListMap :: OrderedMap map k => ([k] -> a -> b -> b) -> b -> ListMap map k a -> b+foldAssocsAscListMap f b0 lmp0 = fld [] lmp0 b0 where+ fld _    Empt          b = b+ fld rks (BraF ks a mp) b = f (revTo rks ks) a (foldAssocsAsc f' b mp)+                            where f' k lmp b' = fld (k : revTo ks rks) lmp b'+ fld rks (BraE ks   mp) b = foldAssocsAsc f' b mp+                            where f' k lmp b' = fld (k : revTo ks rks) lmp b'++-- | See 'Map' class method 'foldAssocsDesc'.+foldAssocsDescListMap :: OrderedMap map k => ([k] -> a -> b -> b) -> b -> ListMap map k a -> b+foldAssocsDescListMap f b0 lmp0 = fld [] lmp0 b0 where+ fld _    Empt          b = b+ fld rks (BraF ks a mp) b = foldAssocsDesc f' (f (revTo rks ks) a b) mp +                            where f' k lmp b' = fld (k : revTo ks rks) lmp b'+ fld rks (BraE ks   mp) b = foldAssocsDesc f' b mp +                            where f' k lmp b' = fld (k : revTo ks rks) lmp b'++-- | See 'Map' class method 'foldElemsAsc''.+foldElemsAscListMap' :: OrderedMap map k => (a -> b -> b) -> b -> ListMap map k a -> b+foldElemsAscListMap' f b0 lmp0 = fld lmp0 b0 where+ fld  Empt         b = b+ fld (BraF _ a mp) b = let b' = foldElemsAsc' fld b mp  in b' `seq` f a b'+ fld (BraE _   mp) b =          foldElemsAsc' fld b mp++-- | See 'Map' class method 'foldElemsDesc''.+foldElemsDescListMap' :: OrderedMap map k => (a -> b -> b) -> b -> ListMap map k a -> b+foldElemsDescListMap' f b0 lmp0 = fld lmp0 b0 where+ fld  Empt         b = b+ fld (BraF _ a mp) b = let b' = f a b in b' `seq` foldElemsDesc' fld b' mp+ fld (BraE _   mp) b =                            foldElemsDesc' fld b  mp++-- | See 'Map' class method 'foldKeysAsc''.+foldKeysAscListMap' :: OrderedMap map k => ([k] -> b -> b) -> b -> ListMap map k a -> b+foldKeysAscListMap' f b0 lmp0 = fld [] lmp0 b0 where+ fld _    Empt          b = b+ fld rks (BraF ks _ mp) b = b'' `seq` f (revTo rks ks) b''+                            where f' k lmp b' = fld (k : revTo ks rks) lmp b'+                                  b''         = foldAssocsAsc' f' b mp+ fld rks (BraE ks   mp) b = foldAssocsAsc' f' b mp+                            where f' k lmp b' = fld (k : revTo ks rks) lmp b'++-- | See 'Map' class method 'foldKeysDesc''.+foldKeysDescListMap' :: OrderedMap map k => ([k] -> b -> b) -> b -> ListMap map k a -> b+foldKeysDescListMap' f b0 lmp0 = fld [] lmp0 b0 where+ fld _    Empt          b = b+ fld rks (BraF ks _ mp) b = b'' `seq` foldAssocsDesc' f' b'' mp+                            where f' k lmp b' = fld (k : revTo ks rks) lmp b'+                                  b''         = f (revTo rks ks) b+ fld rks (BraE ks   mp) b = foldAssocsDesc' f' b mp+                            where f' k lmp b' = fld (k : revTo ks rks) lmp b'++-- | See 'Map' class method 'foldAssocsAsc''.+foldAssocsAscListMap' :: OrderedMap map k => ([k] -> a -> b -> b) -> b -> ListMap map k a -> b+foldAssocsAscListMap' f b0 lmp0 = fld [] lmp0 b0 where+ fld _    Empt          b = b+ fld rks (BraF ks a mp) b = b'' `seq` f (revTo rks ks) a b''+                            where f' k lmp b' = fld (k : revTo ks rks) lmp b'+                                  b''         = foldAssocsAsc' f' b mp+ fld rks (BraE ks   mp) b = foldAssocsAsc' f' b mp+                            where f' k lmp b' = fld (k : revTo ks rks) lmp b'++-- | See 'Map' class method 'foldAssocsDesc''.+foldAssocsDescListMap' :: OrderedMap map k => ([k] -> a -> b -> b) -> b -> ListMap map k a -> b+foldAssocsDescListMap' f b0 lmp0 = fld [] lmp0 b0 where+ fld _    Empt          b = b+ fld rks (BraF ks a mp) b = b'' `seq` foldAssocsDesc' f' b'' mp+                            where f' k lmp b' = fld (k : revTo ks rks) lmp b'+                                  b''         = f (revTo rks ks) a b+ fld rks (BraE ks   mp) b = foldAssocsDesc' f' b mp+                            where f' k lmp b' = fld (k : revTo ks rks) lmp b'++-- | See 'Map' class method 'foldElemsUInt'.+foldElemsUIntListMap :: Map map k => (a -> Int# -> Int#) -> Int# -> ListMap map k a -> Int#+foldElemsUIntListMap f n0 lmp0 = fld lmp0 n0 where+ fld  Empt         n = n+ fld (BraF _ a mp) n = foldElemsUInt fld (f a n) mp+ fld (BraE _   mp) n = foldElemsUInt fld n mp++-- | See 'Map' class method 'map'.+mapListMap :: Map map k => (a -> b) -> ListMap map k a -> ListMap map k b+mapListMap _  Empt          = Empt+mapListMap f (BraF ks a mp) = BraF ks (f a) (map' (mapListMap f) mp) -- Note use of strict map'+mapListMap f (BraE ks   mp) = BraE ks       (map' (mapListMap f) mp) -- Note use of strict map'++-- | See 'Map' class method 'map''.+mapListMap' :: Map map k => (a -> b) -> ListMap map k a -> ListMap map k b+mapListMap' _  Empt          = Empt+mapListMap' f (BraF ks a mp) = let b = f a in b `seq` BraF ks b (map' (mapListMap' f) mp) -- Note use of strict map'+mapListMap' f (BraE ks   mp) =                        BraE ks   (map' (mapListMap' f) mp) -- Note use of strict map'++-- | See 'Map' class method 'mapMaybe'.+mapMaybeListMap :: Map map k => (a -> Maybe b) -> ListMap map k a -> ListMap map k b+mapMaybeListMap _  Empt          = Empt+mapMaybeListMap f (BraF ks a mp) = let mp' = mapMaybe (\lmp -> nonEmptyListMap (mapMaybeListMap f lmp)) mp+                                  in case f a of Just b  -> BraF ks b mp'+                                                 Nothing -> braE ks   mp'+mapMaybeListMap f (BraE ks   mp) = let mp' = mapMaybe (\lmp -> nonEmptyListMap (mapMaybeListMap f lmp)) mp+                                  in braE ks mp'++-- | See 'Map' class method 'mapWithKey'.+mapWithKeyListMap :: Map map k => ([k] -> a -> b) -> ListMap map k a -> ListMap map k b+mapWithKeyListMap f mp = mwk id mp where+ mwk _    Empt           = Empt+ mwk kcont (BraF ks a mp') = BraF ks (f (kcont ks) a) (mapWithKey' f' mp') -- Note use of strict mapWithKey'+                           where f' k lmp = mwk (kcont . (ks++) . (k:)) lmp+ mwk kcont (BraE ks   mp') = BraE ks (mapWithKey' f' mp') -- Note use of strict mapWithKey'+                           where f' k lmp = mwk (kcont . (ks++) . (k:)) lmp++-- | See 'Map' class method 'mapWithKey''.+mapWithKeyListMap' :: Map map k => ([k] -> a -> b) -> ListMap map k a -> ListMap map k b+mapWithKeyListMap' f mp = mwk id mp where+ mwk _    Empt           = Empt+ mwk kcont (BraF ks a mp') = let b = f (kcont ks) a+                           in  b `seq` BraF ks b (mapWithKey' f' mp') -- Note use of strict mapWithKey'+                           where f' k lmp = mwk (kcont . (ks++) . (k:)) lmp+ mwk kcont (BraE ks   mp') = BraE ks (mapWithKey' f' mp') -- Note use of strict mapWithKey'+                           where f' k lmp = mwk (kcont . (ks++) . (k:)) lmp++-- | See 'Map' class method 'mapMaybe'.+filterListMap :: Map map k => (a -> Bool) -> ListMap map k a -> ListMap map k a+filterListMap p lmp0 = flt lmp0 where+ flt     Empt          = Empt+ flt    (BraF ks a mp) = let mp' = mapMaybe (\lmp -> nonEmptyListMap (flt lmp)) mp+                         in if p a then BraF ks a mp'+                                   else braE ks   mp'+ flt    (BraE ks   mp) = let mp' = mapMaybe (\lmp -> nonEmptyListMap (flt lmp)) mp+                         in braE ks mp'+++-- | See 'Map' class method 'valid'.+validListMap :: Map map k => ListMap map k a -> Maybe String+validListMap  Empt = Nothing+validListMap  lmp  = validListMap' lmp+-- Disallows Empt+validListMap' :: Map map k => ListMap map k a -> Maybe String+validListMap'  Empt         = Just "ListMap: Non-empty map contains Empt node."+-- Empty and singleton sub-maps are OK+validListMap' (BraF _ _ mp) = case valid mp of+                             Nothing -> foldElems valAccum Nothing mp+                             Just s  -> Just ("ListMap:" ++ s)+-- Empty and singleton sub-maps are invalid+validListMap' (BraE _   mp) = case valid mp of+                             Nothing -> case status mp of+                                        None    -> Just ("ListMap: Empty branch map in BraE node.")+                                        One _ _ -> Just ("ListMap: Singleton branch map in BraE node.")+                                        Many    -> foldElems valAccum Nothing mp+                             Just s  -> Just ("ListMap:" ++ s)+-- Accumulating valid (does not accept empty ListMaps)+valAccum :: Map map k => ListMap map k a -> Maybe String -> Maybe String+valAccum lmp Nothing = validListMap' lmp+valAccum _   just    = just++-- | See 'Map' class method 'compareKey.+compareKeyListMap :: OrderedMap map k => ListMap map k a -> [k] -> [k] -> Ordering+compareKeyListMap _  []     []     = EQ+compareKeyListMap _  _      []     = GT+compareKeyListMap _  []     _      = LT+compareKeyListMap mp (x:xs) (y:ys) = +	case (compareKey (innerMap mp) x y) of+		GT -> GT+		EQ -> compareKeyListMap mp xs ys+		LT -> LT+	where 	innerMap :: ListMap map k a -> map a+		innerMap _ = undefined++--------------------------------------------------------------------------+--                         OTHER INSTANCES                              --+--------------------------------------------------------------------------++--------+-- Eq --+--------+-- Needs -fallow-undecidable-instances+instance (Eq k, Eq a, Eq (map (ListMap map k a))) => Eq (ListMap map k a) where+ Empt            == Empt            = True+ BraF ks0 a0 mp0 == BraF ks1 a1 mp1 = (ks0==ks1) && (a0==a1) && (mp0==mp1)+ BraE ks0    mp0 == BraE ks1    mp1 = (ks0==ks1) && (mp0==mp1)+ _               == _               = False++---------+-- Ord --+---------+-- Needs -fallow-undecidable-instances+instance (Map map k, Ord k, Ord a, Ord (map (ListMap map k a))) => Ord (ListMap map k a) where+ compare Empt Empt = EQ+ compare Empt _    = LT+ compare _    Empt = GT+-----------------------+ compare (BraF xs0 ax mpx) (BraF ys0 ay mpy) = m xs0 ys0 where+  m []     []     = case compare ax ay of+                    LT -> LT+                    EQ -> compare mpx mpy+                    GT -> GT+  m (_:_ ) []     = GT+  m []     (_:_ ) = LT+  m (x:xs) (y:ys) = case compare x y of+                    LT -> LT+                    EQ -> m xs ys+                    GT -> GT+-----------------------+ compare (BraF xs0 ax mpx) (BraE ys0 mpy) = m xs0 ys0 where+  m []     _      = LT+  m (x:xs) []     = let sx = singleton x (BraF xs ax mpx) in sx `seq` compare sx mpy+  m (x:xs) (y:ys) = case compare x y of+                    LT -> LT+                    EQ -> m xs ys+                    GT -> GT+-----------------------+ compare (BraE xs0 mpx) (BraF ys0 ay mpy) = m xs0 ys0 where+  m _      []     = GT+  m []     (y:ys) = let sy = singleton y (BraF ys ay mpy) in sy `seq` compare mpx sy+  m (x:xs) (y:ys) = case compare x y of+                    LT -> LT+                    EQ -> m xs ys+                    GT -> GT+-----------------------+ compare (BraE xs0 mpx) (BraE ys0 mpy) = m xs0 ys0 where+  m []     []     = compare mpx mpy+  m (x:xs) []     = let sx = singleton x (BraE xs mpx) in sx `seq` compare sx mpy+  m []     (y:ys) = let sy = singleton y (BraE ys mpy) in sy `seq` compare mpx sy+  m (x:xs) (y:ys) = case compare x y of+                    LT -> LT+                    EQ -> m xs ys+                    GT -> GT+-----------------------++----------+-- Show --+----------+instance (Map map k, Show k, Show a) => Show (ListMap map k a) where+  showsPrec d mp  = showParen (d > 10) $+    showString "fromAssocs " . shows (assocs mp)++----------+-- Read --+----------+instance (Map map k, R.Read k, R.Read a) => R.Read (ListMap map k a) where+ readPrec = R.parens $ R.prec 10 $ do R.Ident "fromAssocs" <- R.lexP+                                      xs <- R.readPrec+                                      return (fromAssocs xs)+ readListPrec = R.readListPrecDefault++------------------------+-- Typeable/Typeable1 --+------------------------+instance (Typeable1 map,Typeable k) => Typeable1 (ListMap map k) where+ typeOf1 mp = mkTyConApp (mkTyCon "Data.GMap.ListMap.ListMap") [typeOf1 m, typeOf k]+  where BraF [k] _ m = mp -- This is just to get types for k & m !!+--------------+instance (Typeable1 (ListMap map k), Typeable a) => Typeable (ListMap map k a) where+ typeOf = typeOfDefault++-------------+-- Functor --+-------------+instance Map map k => Functor (ListMap map k) where+-- fmap :: (a -> b) -> ListMap map k a -> ListMap map k b+   fmap = mapListMap -- The lazy version++-----------------+-- Data.Monoid --+-----------------+instance (Map map k, M.Monoid a) => M.Monoid (ListMap map k a) where+-- mempty :: ListMap map k a+   mempty = emptyListMap+-- mappend :: ListMap map k a -> ListMap map k a -> ListMap map k a+   mappend map0 map1 = unionListMap M.mappend map0 map1+-- mconcat :: [ListMap map k a] -> ListMap map k a+   mconcat maps = L.foldr (unionListMap M.mappend) emptyListMap maps++-------------------+-- Data.Foldable --+-------------------+instance Map map k => F.Foldable (ListMap map k) where+-- fold :: Monoid m => ListMap map k m -> m+   fold mp = foldElemsListMap M.mappend M.mempty mp+-- foldMap :: Monoid m => (a -> m) -> ListMap map k a -> m+   foldMap f mp = foldElemsListMap (\a b -> M.mappend (f a) b) M.mempty mp+-- foldr :: (a -> b -> b) -> b -> ListMap map k a -> b+   foldr f b0 mp = foldElemsListMap f b0 mp+-- foldl :: (a -> b -> a) -> a -> ListMap map k b -> a+   foldl f b0 mp = foldElemsListMap (flip f) b0 mp+{- ToDo: Implement properly. Meantime Foldable class has suitable defaults via lists.+-- foldr1 :: (a -> a -> a) -> ListMap map k a -> a+   foldr1 = undefined+-- foldl1 :: (a -> a -> a) -> ListMap map k a -> a+   foldl1 = undefined+-}+
+ src/Data/GMap/MaybeMap.hs view
@@ -0,0 +1,26 @@+{-# OPTIONS_GHC -fglasgow-exts -Wall -fno-warn-missing-signatures #-}++module Data.GMap.MaybeMap+(-- * EnumMap type+ MaybeMap+) where++import Data.GMap()++import Data.GMap.ChoiceMap+import Data.GMap.InjectKeys+import Data.GMap.UnitMap++--------------------------------------------------------------------------------------------+--                     Map Type for Maybe                 --+--------------------------------------------------------------------------------------------++data InjectMaybe k++instance Injection (InjectMaybe k) (Maybe k) (Choice2 k ()) where+	inject _ (Just k)  = C1of2 k+	inject _ Nothing   = C2of2 ()+	outject _ (C1of2 k) = Just k+	outject _ (C2of2 _) = Nothing++type MaybeMap map k = InjectKeys (InjectMaybe k) (Maybe k) (Choice2 k ()) (Choice2Map map UnitMap k ())
+ src/Data/GMap/OrdMap.hs view
@@ -0,0 +1,543 @@+{-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans -fno-warn-unused-imports -Wall #-}++module Data.GMap.OrdMap+(-- * OrdMap type+ OrdMap+) where++import Data.GMap+import qualified Data.Tree.AVL  as A+import qualified Data.COrdering as C++import qualified Data.Monoid as M (Monoid(..))+import qualified Data.Foldable as F (Foldable(..))+import Data.Typeable+-- -fno-warn-unused-imports used because ghc currently gives spurious warning with this import+-- See Tickets 1074 and 1148+import qualified Data.List as L+import qualified Data.Maybe as MB+import Control.Monad++import GHC.Base+import qualified Text.Read as R (Read(..),Lexeme(..),parens,prec,lexP,readListPrecDefault)++-- | The default 'Map' type any key type which is an instance of 'Ord'.+-- This is a newtype wrapper around @'Data.Tree.AVL.AVL' (k,a)@.+newtype OrdMap k a = OrdMap (A.AVL (k,a))++instance Ord k => Map (OrdMap k) k where+	empty                 	= emptyOrdMap+	singleton             	= singletonOrdMap+	pair                  	= pairOrdMap+	nonEmpty              	= nonEmptyOrdMap+	status                	= statusOrdMap+	addSize               	= addSizeOrdMap+	lookup                	= lookupOrdMap+	lookupCont            	= lookupContOrdMap+	alter			= alterOrdMap+	insertWith            	= insertWithOrdMap+	insertWith'           	= insertWithOrdMap'+	insertMaybe           	= insertMaybeOrdMap+--  	fromAssocsWith		= fromAssocsWithOrdMap+--  	fromAssocsMaybe 	= fromAssocsMaybeOrdMap+	delete                	= deleteOrdMap+	adjustWith           	= adjustWithOrdMap+	adjustWith' 		= adjustWithOrdMap'+	adjustMaybe		= adjustMaybeOrdMap+        venn                    = vennOrdMap+        venn'                   = vennOrdMap'+        vennMaybe               = vennMaybeOrdMap+-- 	merge			= mergeOrdMap+	union                 	= unionOrdMap+	union'                	= unionOrdMap'+	unionMaybe            	= unionMaybeOrdMap+        disjointUnion           = disjointUnionOrdMap+	intersection          	= intersectionOrdMap+	intersection'         	= intersectionOrdMap'+	intersectionMaybe     	= intersectionMaybeOrdMap+	difference            	= differenceOrdMap+	differenceMaybe       	= differenceMaybeOrdMap+	isSubsetOf            	= isSubsetOfOrdMap+	isSubmapOf              = isSubmapOfOrdMap+	map                   	= mapOrdMap+	map'                  	= mapOrdMap'+	mapMaybe              	= mapMaybeOrdMap+	mapWithKey            	= mapWithKeyOrdMap+	mapWithKey'           	= mapWithKeyOrdMap'+	filter                	= filterOrdMap+	foldKeys		= foldKeysAscOrdMap+	foldElems 		= foldElemsAscOrdMap+	foldAssocs		= foldAssocsAscOrdMap+	foldKeys'		= foldKeysAscOrdMap'+	foldElems' 		= foldElemsAscOrdMap'+	foldAssocs'		= foldAssocsAscOrdMap'+	foldElemsUInt         	= foldElemsUIntOrdMap+	valid                 	= validOrdMap++instance Ord k => OrderedMap (OrdMap k) k where+	compareKey 		= compareKeyOrdMap+	fromAssocsAscWith 	= fromAssocsAscWithOrdMap+	fromAssocsDescWith 	= fromAssocsDescWithOrdMap+	fromAssocsAscMaybe 	= fromAssocsAscMaybeOrdMap+	fromAssocsDescMaybe 	= fromAssocsDescMaybeOrdMap+ 	foldElemsAsc		= foldElemsAscOrdMap+	foldElemsDesc		= foldElemsDescOrdMap+	foldKeysAsc		= foldKeysAscOrdMap+	foldKeysDesc		= foldKeysDescOrdMap+	foldAssocsAsc		= foldAssocsAscOrdMap+	foldAssocsDesc		= foldAssocsDescOrdMap+	foldElemsAsc'		= foldElemsAscOrdMap'+	foldElemsDesc'		= foldElemsDescOrdMap'+	foldKeysAsc'		= foldKeysAscOrdMap'+	foldKeysDesc'		= foldKeysDescOrdMap'+	foldAssocsAsc'		= foldAssocsAscOrdMap'+	foldAssocsDesc'		= foldAssocsDescOrdMap'++-- | See 'Map' class method 'empty'.+emptyOrdMap :: OrdMap k a+emptyOrdMap = OrdMap (A.empty)++-- | See 'Map' class method 'singleton'.+singletonOrdMap :: k -> a -> OrdMap k a+singletonOrdMap k a = OrdMap (A.singleton (k,a))+{-# INLINE singletonOrdMap #-}++-- | See 'Map' class method 'nonEmpty'.+nonEmptyOrdMap :: OrdMap k a -> Maybe (OrdMap k a)+nonEmptyOrdMap m@(OrdMap t) = if A.isEmpty t then Nothing else Just m+{-# INLINE nonEmptyOrdMap #-}++-- | See 'Map' class method 'pair'.+pairOrdMap :: Ord k => k -> k -> Maybe (a -> a -> OrdMap k a)+pairOrdMap x y = case compare x y of+                LT -> Just (\ax ay -> OrdMap (A.pair (x,ax) (y,ay)))+                EQ -> Nothing+                GT -> Just (\ax ay -> OrdMap (A.pair (y,ay) (x,ax)))++-- Group an ordered list of assocs by key+clump :: Eq k => [(k,a)] -> [(k,[a])]+clump [] = []+clump kas = list' [(k',as' [])]+	where 	(k',as',list') = L.foldl' combine (fst $ head kas,id,id) kas+		-- 'as' and 'list' are list building continuations - so order of 'kas' is preserved+		combine (k1,as,list) (k2,a) =+			if 	k1 == k2+			then	(k1,  as . (a:), list                 )+			else	(k2, (a:),       list . ((k1,as []):) )++-- | See 'Map' class method 'fromAssocsAscWith'+fromAssocsAscWithOrdMap :: Ord k => (a -> a -> a) -> [(k,a)] -> OrdMap k a+fromAssocsAscWithOrdMap f kas  = OrdMap $ A.asTreeL [ (k,L.foldl1' f as) | (k,as) <- clump kas]++-- | See 'Map' class method 'fromAssocsDescWith'+fromAssocsDescWithOrdMap :: Ord k => (a -> a -> a) -> [(k,a)] -> OrdMap k a+fromAssocsDescWithOrdMap f kas = OrdMap $ A.asTreeR [ (k,L.foldl1' f as) | (k,as) <- clump kas]++-- | See 'Map' class method 'fromAssocsAscMaybe'+fromAssocsAscMaybeOrdMap  :: Ord k => (a -> a -> Maybe a) -> [(k,a)] -> OrdMap k a+fromAssocsAscMaybeOrdMap f kas  = OrdMap $ A.asTreeL $ MB.catMaybes [ fld k as | (k,as) <- clump kas]+	where fld k as = (\a -> (k,a)) `fmap` foldM f (head as) (tail as) -- NB 'as' guaranteed nonempty by clump++-- | See 'Map' class method 'fromAssocsDescMaybe'+fromAssocsDescMaybeOrdMap :: Ord k => (a -> a -> Maybe a) -> [(k,a)] -> OrdMap k a+fromAssocsDescMaybeOrdMap f kas = OrdMap $ A.asTreeR $ MB.catMaybes [ fld k as | (k,as) <- clump kas]+	where fld k as = (\a -> (k,a)) `fmap` foldM f (head as) (tail as) -- NB 'as' guaranteed nonempty by clump++-- | See 'Map' class method 'status'.+statusOrdMap :: OrdMap k a -> Status k a+statusOrdMap (OrdMap t) = case A.tryGetSingleton t of+                        Just (k,a) -> One k a+                        Nothing    -> if A.isEmpty t then None else Many+{-# INLINE statusOrdMap #-}++-- | See 'Map' class method 'addSize'.+addSizeOrdMap :: OrdMap k a -> Int# -> Int#+addSizeOrdMap (OrdMap t) n = A.addSize# n t+{-# INLINE addSizeOrdMap #-}++-- | See 'Map' class method 'Data.GMap.lookup'.+lookupOrdMap :: Ord k => k -> OrdMap k a -> Maybe a+lookupOrdMap k (OrdMap t) = A.tryRead t cmp+ where cmp (k',a) = case compare k k' of+                    LT -> C.Lt+                    EQ -> C.Eq a+                    GT -> C.Gt++-- | See 'Map' class method 'lookupCont'.+lookupContOrdMap :: Ord k => (a -> Maybe b) -> k -> OrdMap k a -> Maybe b+lookupContOrdMap f k (OrdMap t) = A.tryReadMaybe t cmp+ where cmp (k',a) = case compare k k' of+                    LT -> C.Lt+                    EQ -> let mb = f a in mb `seq` C.Eq mb+                    GT -> C.Gt++-- | See 'Map' class method 'alter'.+alterOrdMap :: Ord k => (Maybe a -> Maybe a) -> k -> OrdMap k a -> OrdMap k a+alterOrdMap f k (OrdMap t) = case A.tryReadBAVL bavl of+                           Nothing     -> OrdMap (doIt k  Nothing ) -- bavl is empty+                           Just (k',a) -> OrdMap (doIt k' (Just a)) -- bavl is full+ where bavl = A.openBAVL cmp t+       cmp (k',_)  = compare k k'+       doIt k' mba = case f mba of+                     Nothing -> A.deleteBAVL bavl       -- This is a nop for empty bavl+                     Just a' -> A.pushBAVL (k',a') bavl -- This is a write for full bavl++-- | See 'Map' class method 'insertWith'.+insertWithOrdMap :: Ord k => (a -> a) -> k -> a -> OrdMap k a -> OrdMap k a+insertWithOrdMap f k a (OrdMap t) = OrdMap (A.push cmp (k,a) t)+ where cmp (k',a') = case compare k k' of+                     LT -> C.Lt+                     EQ -> C.Eq (k',f a')+                     GT -> C.Gt++-- | See 'Map' class method 'insertWith'.+insertWithOrdMap' :: Ord k => (a -> a) -> k -> a -> OrdMap k a -> OrdMap k a+insertWithOrdMap' f k a (OrdMap t) = OrdMap (A.push' cmp (a `seq` (k,a)) t) -- Note use of genPush'+ where cmp (k',a') = case compare k k' of+                     LT -> C.Lt+                     EQ -> let b' = f a' in b' `seq` C.Eq (k',f a')+                     GT -> C.Gt++-- | See 'Map' class method 'insertMaybe'.+insertMaybeOrdMap :: Ord k => (a -> Maybe a) -> k -> a -> OrdMap k a -> OrdMap k a+insertMaybeOrdMap f k a (OrdMap t) = case A.tryReadBAVL bavl of+                                   Nothing -> OrdMap (A.pushBAVL (k,a) bavl)+                                   Just (k',a') -> case f a' of+                                                   Nothing  -> OrdMap (A.deleteBAVL bavl)+                                                   Just a'' -> OrdMap (A.pushBAVL (k',a'') bavl)+ where bavl = A.openBAVL cmp t+       cmp (k',_) = compare k k'++-- | See 'Map' class method 'delete'.+deleteOrdMap :: Ord k => k -> OrdMap k a -> OrdMap k a+deleteOrdMap k (OrdMap t) = OrdMap (A.delete cmp t)+ where cmp (k',_) = compare k k'+{-# INLINE deleteOrdMap #-}++-- | See 'Map' class method 'adjust'.+adjustWithOrdMap :: Ord k => (a -> a) -> k -> OrdMap k a -> OrdMap k a+adjustWithOrdMap f k (OrdMap t) = OrdMap (A.deleteMaybe cmp t)+ where cmp (k',a) = case compare k k' of+                    LT -> C.Lt+                    EQ -> C.Eq (Just (k',f a))+                    GT -> C.Gt++-- | See 'Map' class method 'adjust''.+adjustWithOrdMap' :: Ord k => (a -> a) -> k -> OrdMap k a -> OrdMap k a+adjustWithOrdMap' f k (OrdMap t) = OrdMap (A.deleteMaybe cmp t)+ where cmp (k',a) = case compare k k' of+                    LT -> C.Lt+                    EQ -> let a' = f a in a' `seq` C.Eq (Just (k',a'))+                    GT -> C.Gt++-- | See 'Map' class method 'adjustMaybe'.+adjustMaybeOrdMap :: Ord k => (a -> Maybe a) -> k -> OrdMap k a -> OrdMap k a+adjustMaybeOrdMap f k (OrdMap t) = OrdMap (A.deleteMaybe cmp t)+ where cmp (k',a) = case compare k k' of+                    LT -> C.Lt+                    EQ -> case f a of+                          Nothing -> C.Eq Nothing+                          Just a' -> C.Eq (Just (k',a'))+                    GT -> C.Gt++-- | See 'Map' class method 'venn'.+vennOrdMap :: Ord k => (a -> b -> c) -> OrdMap k a -> OrdMap k b -> (OrdMap k a, OrdMap k c, OrdMap k b)+vennOrdMap f (OrdMap t) (OrdMap t') = case A.venn cmp t t' of (tab,ti,tba) -> (OrdMap tab,OrdMap ti,OrdMap tba)+ where cmp (k,a) (k',b) = case compare k k' of+                          LT -> C.Lt+                          EQ -> C.Eq (k, f a b)+                          GT -> C.Gt++-- | See 'Map' class method 'venn''.+vennOrdMap' :: Ord k => (a -> b -> c) -> OrdMap k a -> OrdMap k b -> (OrdMap k a, OrdMap k c, OrdMap k b)+vennOrdMap' f (OrdMap t) (OrdMap t') = case A.venn cmp t t' of (tab,ti,tba) -> (OrdMap tab,OrdMap ti,OrdMap tba)+ where cmp (k,a) (k',b) = case compare k k' of+                          LT -> C.Lt+                          EQ -> let c =  f a b in c `seq` C.Eq (k,c)+                          GT -> C.Gt++-- | See 'Map' class method 'vennMaybe'.+vennMaybeOrdMap :: Ord k => (a -> b -> Maybe c) -> OrdMap k a -> OrdMap k b -> (OrdMap k a, OrdMap k c, OrdMap k b)+vennMaybeOrdMap f (OrdMap t) (OrdMap t') = case A.vennMaybe cmp t t' of (tab,ti,tba) -> (OrdMap tab,OrdMap ti,OrdMap tba)+ where cmp (k,a) (k',b) = case compare k k' of+                          LT -> C.Lt+                          EQ -> case f a b of+                                Nothing -> C.Eq Nothing+                                Just c  -> C.Eq (Just (k,c))+                          GT -> C.Gt++-- | See 'Map' class method 'union'.+unionOrdMap :: Ord k => (a -> a -> a) -> OrdMap k a -> OrdMap k a -> OrdMap k a+unionOrdMap f (OrdMap t) (OrdMap t') = OrdMap (A.union cmp t t')+ where cmp (k,a) (k',a') = case compare k k' of+                           LT -> C.Lt+                           EQ -> C.Eq (k, f a a')+                           GT -> C.Gt++-- | See 'Map' class method 'union''.+unionOrdMap' :: Ord k => (a -> a -> a) -> OrdMap k a -> OrdMap k a -> OrdMap k a+unionOrdMap' f (OrdMap t) (OrdMap t') = OrdMap (A.union cmp t t')+ where cmp (k,a) (k',a') = case compare k k' of+                           LT -> C.Lt+                           EQ -> let a'' = f a a' in a'' `seq` C.Eq (k, a'')+                           GT -> C.Gt++-- | See 'Map' class method 'unionMaybe'.+unionMaybeOrdMap :: Ord k => (a -> a -> Maybe a) -> OrdMap k a -> OrdMap k a -> OrdMap k a+unionMaybeOrdMap f (OrdMap t) (OrdMap t') = OrdMap (A.unionMaybe cmp t t')+ where cmp (k,a) (k',a') = case compare k k' of+                           LT -> C.Lt+                           EQ -> case f a a' of+                                 Nothing  -> C.Eq Nothing+                                 Just a'' -> C.Eq (Just (k,a''))+                           GT -> C.Gt++-- | See 'Map' class method 'disjointUnion'.+disjointUnionOrdMap :: Ord k => OrdMap k a -> OrdMap k a -> OrdMap k a+disjointUnionOrdMap (OrdMap t) (OrdMap t') = OrdMap (A.disjointUnion cmp t t')+ where cmp (k,_) (k',_) = compare k k'++-- | See 'Map' class method 'intersection'.+intersectionOrdMap :: Ord k => (a -> b -> c) -> OrdMap k a -> OrdMap k b -> OrdMap k c+intersectionOrdMap f (OrdMap t) (OrdMap t') = OrdMap (A.intersection cmp t t')+ where cmp (k,a) (k',b) = case compare k k' of+                          LT -> C.Lt+                          EQ -> C.Eq (k, f a b)+                          GT -> C.Gt++-- | See 'Map' class method 'intersection''.+intersectionOrdMap' :: Ord k => (a -> b -> c) -> OrdMap k a -> OrdMap k b -> OrdMap k c+intersectionOrdMap' f (OrdMap t) (OrdMap t') = OrdMap (A.intersection cmp t t')+ where cmp (k,a) (k',b) = case compare k k' of+                          LT -> C.Lt+                          EQ -> let c = f a b in c `seq` C.Eq (k, c)+                          GT -> C.Gt++-- | See 'Map' class method 'intersectionMaybe'.+intersectionMaybeOrdMap :: Ord k => (a -> b -> Maybe c) -> OrdMap k a -> OrdMap k b -> OrdMap k c+intersectionMaybeOrdMap f (OrdMap ta) (OrdMap tb) = OrdMap (A.intersectionMaybe cmp ta tb)+ where cmp (k,a) (k',b) = case compare k k' of+                          LT -> C.Lt+                          EQ -> case f a b of+                                Nothing -> C.Eq Nothing+                                Just c  -> C.Eq (Just (k,c))+                          GT -> C.Gt++-- | See 'Map' class method 'difference'.+differenceOrdMap :: Ord k => OrdMap k a -> OrdMap k b -> OrdMap k a+differenceOrdMap (OrdMap t1) (OrdMap t2) = OrdMap (A.difference cmp t1 t2)+ where cmp (k,_) (k',_) = compare k k'++-- | See 'Map' class method 'differenceMaybe'.+differenceMaybeOrdMap :: Ord k => (a -> b -> Maybe a) -> OrdMap k a -> OrdMap k b -> OrdMap k a+differenceMaybeOrdMap f (OrdMap ta) (OrdMap tb) = OrdMap (A.differenceMaybe cmp ta tb)+ where cmp (k,a) (k',b) = case compare k k' of+                          LT -> C.Lt+                          EQ -> case f a b of+                                Nothing -> C.Eq Nothing+                                Just a' -> C.Eq (Just (k,a'))+                          GT -> C.Gt++-- | See 'Map' class method 'isSubsetOf'.+isSubsetOfOrdMap :: Ord k => OrdMap k a -> OrdMap k b -> Bool+isSubsetOfOrdMap (OrdMap ta) (OrdMap tb) = A.isSubsetOf cmp ta tb+ where cmp (k,_) (k',_) = compare k k'++-- | See 'Map' class method 'isSubmapOf'.+isSubmapOfOrdMap :: Ord k => (a -> b -> Bool) -> OrdMap k a -> OrdMap k b -> Bool+isSubmapOfOrdMap p (OrdMap ta) (OrdMap tb) = A.isSubsetOfBy cmp ta tb+ where cmp (k,a) (k',b) = case compare k k' of+                          LT -> C.Lt+                          EQ -> C.Eq $! p a b+                          GT -> C.Gt++-- | See 'Map' class method 'Data.GMap.map'.+mapOrdMap :: (a -> b) -> OrdMap k a -> OrdMap k b+-- Note use of strict AVL map! (This does not force evaluation of f a).+mapOrdMap f (OrdMap t) = OrdMap (A.map' (\(k,a) -> (k,f a)) t)+{-# INLINE mapOrdMap #-}++-- | See 'Map' class method 'map''.+mapOrdMap' :: (a -> b) -> OrdMap k a -> OrdMap k b+mapOrdMap' f (OrdMap t) = OrdMap (A.map' (\(k,a) -> let b = f a in b `seq` (k,b)) t)+{-# INLINE mapOrdMap' #-}++-- | See 'Map' class method 'mapMaybe'.+mapMaybeOrdMap :: (a -> Maybe b) -> OrdMap k a -> OrdMap k b+mapMaybeOrdMap f (OrdMap t) = OrdMap (A.mapMaybe f' t)+ where f' (k,a) = case f a of+                  Nothing -> Nothing+                  Just b  -> Just (k,b)++-- | See 'Map' class method 'mapWithKey'.+mapWithKeyOrdMap :: (k -> a -> b) -> OrdMap k a -> OrdMap k b+-- Note use of strict AVL map! (This does not force evaluation of f k a).+mapWithKeyOrdMap f (OrdMap t) = OrdMap (A.map' (\(k,a) -> (k, f k a)) t)+{-# INLINE mapWithKeyOrdMap #-}++-- | See 'Map' class method 'mapWithKey''.+mapWithKeyOrdMap' :: (k -> a -> b) -> OrdMap k a -> OrdMap k b+mapWithKeyOrdMap' f (OrdMap t) = OrdMap (A.map' (\(k,a) -> let b = f k a in b `seq` (k, b)) t)+{-# INLINE mapWithKeyOrdMap' #-}++-- | See 'Map' class method 'Data.GMap.filter'.+filterOrdMap :: (a -> Bool) -> OrdMap k a -> OrdMap k a+filterOrdMap f (OrdMap t) = OrdMap (A.filter (\(_,a) -> f a) t)+{-# INLINE filterOrdMap #-}++-- | See 'Map' class method 'foldElemsAsc'.+foldElemsAscOrdMap :: (a -> b -> b) -> b  -> OrdMap k a-> b+foldElemsAscOrdMap f b0 (OrdMap t) = A.foldr (\(_,a) b -> f a b) b0 t -- Lazy foldr+{-# INLINE foldElemsAscOrdMap #-}++-- | See 'Map' class method 'foldElemsDesc'.+foldElemsDescOrdMap :: (a -> b -> b) -> b -> OrdMap k a -> b+foldElemsDescOrdMap f b0 (OrdMap t) = A.foldl (\b (_,a) -> f a b) b0 t -- Lazy foldl+{-# INLINE foldElemsDescOrdMap #-}++-- | See 'Map' class method 'foldKeysAsc'.+foldKeysAscOrdMap :: (k -> b -> b) -> b -> OrdMap k a -> b+foldKeysAscOrdMap f b0 (OrdMap t) = A.foldr (\(k,_) b -> f k b) b0 t -- Lazy foldr+{-# INLINE foldKeysAscOrdMap #-}++-- | See 'Map' class method 'foldKeysDesc'.+foldKeysDescOrdMap :: (k -> b -> b) -> b -> OrdMap k a -> b+foldKeysDescOrdMap f b0 (OrdMap t) = A.foldl (\b (k,_) -> f k b) b0 t -- Lazy foldl+{-# INLINE foldKeysDescOrdMap #-}++-- | See 'Map' class method 'foldAssocsAsc'.+foldAssocsAscOrdMap :: (k -> a -> b -> b) -> b -> OrdMap k a -> b+foldAssocsAscOrdMap f b0 (OrdMap t) = A.foldr (\(k,a) b -> f k a b) b0 t -- Lazy foldr+{-# INLINE foldAssocsAscOrdMap #-}++-- | See 'Map' class method 'foldAssocsDesc'.+foldAssocsDescOrdMap :: (k -> a -> b -> b) -> b -> OrdMap k a -> b+foldAssocsDescOrdMap f b0 (OrdMap t) = A.foldl (\b (k,a) -> f k a b) b0 t -- Lazy foldl+{-# INLINE foldAssocsDescOrdMap #-}++-- | See 'Map' class method 'foldElemsAsc''.+foldElemsAscOrdMap' :: (a -> b -> b) -> b -> OrdMap k a -> b+foldElemsAscOrdMap' f b0 (OrdMap t) = A.foldr' (\(_,a) b -> f a b) b0 t -- Strict foldr+{-# INLINE foldElemsAscOrdMap' #-}++-- | See 'Map' class method 'foldElemsDesc''.+foldElemsDescOrdMap' :: (a -> b -> b) -> b -> OrdMap k a -> b+foldElemsDescOrdMap' f b0 (OrdMap t) = A.foldl' (\b (_,a) -> f a b) b0 t -- Strict foldl+{-# INLINE foldElemsDescOrdMap' #-}++-- | See 'Map' class method 'foldKeysAsc''.+foldKeysAscOrdMap' :: (k -> b -> b) -> b -> OrdMap k a -> b+foldKeysAscOrdMap' f b0 (OrdMap t) = A.foldr' (\(k,_) b -> f k b) b0 t -- Strict foldr+{-# INLINE foldKeysAscOrdMap' #-}++-- | See 'Map' class method 'foldKeysDesc''.+foldKeysDescOrdMap' :: (k -> b -> b) -> b -> OrdMap k a -> b+foldKeysDescOrdMap' f b0 (OrdMap t) = A.foldl' (\b (k,_) -> f k b) b0 t -- Strict foldl+{-# INLINE foldKeysDescOrdMap' #-}++-- | See 'Map' class method 'foldAssocsAsc''.+foldAssocsAscOrdMap' :: (k -> a -> b -> b) -> b -> OrdMap k a -> b+foldAssocsAscOrdMap' f b0 (OrdMap t) = A.foldr' (\(k,a) b -> f k a b) b0 t -- Strict foldr+{-# INLINE foldAssocsAscOrdMap' #-}++-- | See 'Map' class method 'foldAssocsDesc''.+foldAssocsDescOrdMap' :: (k -> a -> b -> b) -> b -> OrdMap k a -> b+foldAssocsDescOrdMap' f b0 (OrdMap t) = A.foldl' (\b (k,a) -> f k a b) b0 t -- Strict foldl+{-# INLINE foldAssocsDescOrdMap' #-}++-- | See 'Map' class method 'foldElemsUInt'.+foldElemsUIntOrdMap :: (a -> Int# -> Int#) -> Int# -> OrdMap k a -> Int#+foldElemsUIntOrdMap f n (OrdMap t) = A.foldrInt# (\(_,a) u -> f a u) n t+{-# INLINE foldElemsUIntOrdMap #-}++-- | See 'Map' class method 'valid'.+validOrdMap :: Ord k => OrdMap k a -> Maybe String+validOrdMap (OrdMap t) =+ if      A.isSorted (\(k0,_) (k1,_) -> compare k0 k1) t+ then if A.isBalanced t+      then Nothing+      else Just "OrdMap: Tree is not balanced."+ else      Just "OrdMap: Tree is not sorted."++-- | See 'Map' class method 'compareKey'+compareKeyOrdMap :: Ord k => OrdMap k a -> k -> k -> Ordering+compareKeyOrdMap _ = compare++--------------------------------------------------------------------------+--                         OTHER INSTANCES                              --+--------------------------------------------------------------------------++--------+-- Eq --+--------+instance (Eq k, Eq a) => Eq (OrdMap k a) where+ OrdMap t0 == OrdMap t1 = t0 == t1++---------+-- Ord --+---------+instance (Ord k, Ord a) => Ord (OrdMap k a) where+ compare (OrdMap t0) (OrdMap t1) = compare t0 t1++----------+-- Show --+----------+instance (Ord k, Show k, Show a) => Show (OrdMap k a) where+  showsPrec d mp  = showParen (d > 10) $+    showString "fromAssocsAsc " . shows (assocsAsc mp)++----------+-- Read --+----------+instance (Ord k, R.Read k, R.Read a) => R.Read (OrdMap k a) where+ readPrec = R.parens $ R.prec 10 $ do R.Ident "fromAssocsAsc" <- R.lexP+                                      xs <- R.readPrec+                                      return (fromAssocsAsc xs)+ readListPrec = R.readListPrecDefault++------------------------+-- Typeable/Typeable1 --+------------------------+instance (Ord k, Typeable k) => Typeable1 (OrdMap k) where+ typeOf1 mp =  mkTyConApp (mkTyCon "Data.GMap.OrdMap.OrdMap") [typeOf k]+  where [(k,_)]  = assocsAsc mp -- This is just to get type for k !!+--------------+instance (Typeable1 (OrdMap k), Typeable a) => Typeable (OrdMap k a) where+ typeOf = typeOfDefault++-------------+-- Functor --+-------------+instance Functor (OrdMap k) where+-- fmap :: (a -> b) -> OrdMap k a -> OrdMap k b+   fmap = mapOrdMap -- The lazy version++-----------------+-- Data.Monoid --+-----------------+instance (Ord k, M.Monoid a) => M.Monoid (OrdMap k a) where+-- mempty :: OrdMap k a+   mempty = emptyOrdMap+-- mappend :: OrdMap k a -> OrdMap k a -> OrdMap k a+   mappend map0 map1 = unionOrdMap M.mappend map0 map1+-- mconcat :: [OrdMap k a] -> OrdMap k a+   mconcat maps = L.foldr (unionOrdMap M.mappend) emptyOrdMap maps++-------------------+-- Data.Foldable --+-------------------+instance F.Foldable (OrdMap k) where+-- fold :: Monoid m => OrdMap k m -> m+   fold mp = foldElemsAscOrdMap M.mappend M.mempty mp+-- foldMap :: Monoid m => (a -> m) -> OrdMap k a -> m+   foldMap f mp = foldElemsAscOrdMap (\a b -> M.mappend (f a) b) M.mempty mp+-- foldr :: (a -> b -> b) -> b -> OrdMap k a -> b+   foldr f b0 mp = foldElemsAscOrdMap f b0 mp+-- foldl :: (a -> b -> a) -> a -> OrdMap k b -> a+   foldl f b0 mp = foldElemsDescOrdMap (flip f) b0 mp+{- ToDo: Implement properly. Meantime Foldable class has suitable defaults via lists.+-- foldr1 :: (a -> a -> a) -> OrdMap k a -> a+   foldr1 = undefined+-- foldl1 :: (a -> a -> a) -> OrdMap k a -> a+   foldl1 = undefined+-}
+ src/Data/GMap/TupleMap.hs view
@@ -0,0 +1,366 @@+{-# OPTIONS_GHC -fglasgow-exts -fno-monomorphism-restriction -Wall -fno-warn-missing-signatures #-}++module Data.GMap.TupleMap+(-- * Tuple2Map type+ Tuple2Map+,Tuple3Map+,Tuple4Map+,Tuple5Map+) where++import Prelude hiding (foldr,map,filter,lookup)+import Data.GMap+import Data.GMap.InjectKeys++import Data.Typeable+import qualified Data.Foldable as F+import qualified Data.Monoid as M+import Data.Ord+-- -fno-warn-unused-imports used because ghc currently gives spurious warning with this import+-- See Tickets 1074 and 1148+import qualified Data.List as L (foldr,foldl')+import Data.Maybe hiding (mapMaybe)++import GHC.Base hiding (map)+import qualified Text.Read as R (Read(..),Lexeme(..),parens,prec,lexP,readListPrecDefault)++import qualified Data.List as L+import Control.Monad (mplus)++--------------------------------------------------------------------------------------------+--                     Map Type for tuples and various helper functions                     --+--------------------------------------------------------------------------------------------++data Tuple2Map map1 map2 k1 k2 a = Tuple2Map !(map1 (map2 a))+-- Maintain the invariant that the nested maps are non-empty+emptyInnerMapError funName = error ("Data.GMap.Tuple2Map." ++ funName ++ ": Empty inner map")++-- | Tuple2Map is an instance of Map.+instance (Map map1 k1, Map map2 k2) => Map (Tuple2Map map1 map2 k1 k2) (k1,k2) where+	empty                 	= emptyTuple2Map+	singleton             	= singletonTuple2Map+-- 	pair                  	= pairTuple2Map+	nonEmpty              	= nonEmptyTuple2Map+	status                	= statusTuple2Map+	addSize               	= addSizeTuple2Map+	lookup                	= lookupTuple2Map+	lookupCont            	= lookupContTuple2Map+	alter			= alterTuple2Map+	insertWith            	= insertWithTuple2Map +	insertWith'           	= insertWithTuple2Map'+	insertMaybe           	= insertMaybeTuple2Map+-- 	fromAssocsWith	        = fromAssocsWithTuple2Map+-- 	fromAssocsMaybe 	= fromAssocsMaybeTuple2Map+	delete                	= deleteTuple2Map +	adjustWith           	= adjustWithTuple2Map+	adjustWith' 		= adjustWithTuple2Map'+	adjustMaybe		= adjustMaybeTuple2Map+	venn			= vennTuple2Map+	venn'			= vennTuple2Map'+	vennMaybe		= vennMaybeTuple2Map+	disjointUnion		= disjointUnionTuple2Map+	union                 	= unionTuple2Map+	union'                	= unionTuple2Map'+	unionMaybe            	= unionMaybeTuple2Map+	intersection          	= intersectionTuple2Map+	intersection'         	= intersectionTuple2Map'+	intersectionMaybe     	= intersectionMaybeTuple2Map+	difference            	= differenceTuple2Map+	differenceMaybe       	= differenceMaybeTuple2Map+	isSubsetOf            	= isSubsetOfTuple2Map+	isSubmapOf            	= isSubmapOfTuple2Map +	map                   	= mapTuple2Map+	map'                  	= mapTuple2Map'+	mapMaybe              	= mapMaybeTuple2Map+	mapWithKey            	= mapWithKeyTuple2Map+	mapWithKey'           	= mapWithKeyTuple2Map'+	filter                	= filterTuple2Map+	foldKeys		= foldKeysTuple2Map+	foldElems 		= foldElemsTuple2Map+	foldAssocs		= foldAssocsTuple2Map+	foldKeys'		= foldKeysTuple2Map'+	foldElems' 		= foldElemsTuple2Map'+	foldAssocs'		= foldAssocsTuple2Map'+	foldElemsUInt         	= foldElemsUIntTuple2Map+	valid                 	= validTuple2Map+ +instance (OrderedMap map1 k1, OrderedMap map2 k2) => OrderedMap (Tuple2Map map1 map2 k1 k2) (k1,k2) where+	compareKey 	= compareKeyTuple2Map+	fromAssocsAscWith = fromAssocsAscWithTuple2Map+	fromAssocsDescWith = fromAssocsDescWithTuple2Map+	fromAssocsAscMaybe = fromAssocsAscMaybeTuple2Map+	fromAssocsDescMaybe = fromAssocsDescMaybeTuple2Map+ 	foldElemsAsc	= foldElemsAscTuple2Map+	foldElemsDesc	= foldElemsDescTuple2Map+	foldKeysAsc	= foldKeysAscTuple2Map+	foldKeysDesc	= foldKeysDescTuple2Map+	foldAssocsAsc	= foldAssocsAscTuple2Map+	foldAssocsDesc	= foldAssocsDescTuple2Map+	foldElemsAsc'	= foldElemsAscTuple2Map'+	foldElemsDesc'	= foldElemsDescTuple2Map'+	foldKeysAsc'	= foldKeysAscTuple2Map'+	foldKeysDesc'	= foldKeysDescTuple2Map'+	foldAssocsAsc'	= foldAssocsAscTuple2Map'+	foldAssocsDesc'	= foldAssocsDescTuple2Map'+	+on f g a b = f $ g a b+	+emptyTuple2Map = Tuple2Map empty+singletonTuple2Map (k1,k2) a = Tuple2Map (singleton k1 (singleton k2 a))++nonEmptyTuple2Map (Tuple2Map mp) = Tuple2Map `fmap` nonEmpty mp++statusTuple2Map (Tuple2Map mp) = +	case status mp of+		None -> None+		One k1 mp' -> case status mp' of+				None -> emptyInnerMapError "status"+				One k2 a -> One (k1,k2) a+				Many -> Many+		Many -> Many ++addSizeTuple2Map (Tuple2Map mp) i = foldElemsUInt addSize i mp++lookupTuple2Map (k1,k2) (Tuple2Map mp) = lookupCont (lookup k2) k1 mp+lookupContTuple2Map f (k1,k2) (Tuple2Map mp) = lookupCont (lookupCont f k2) k1 mp++alterTuple2Map f (k1,k2) (Tuple2Map mp) = Tuple2Map (alter' alt k1 mp)+ where alt Nothing = singleton k2 `fmap` (f Nothing)+       alt (Just mp') = nonEmpty (alter f k2 mp') ++insertWithTuple2Map  f (k1,k2) a (Tuple2Map mp) = Tuple2Map (insertWith' (insertWith  f k2 a) k1 (singleton k2 a) mp)+insertWithTuple2Map' f (k1,k2) a (Tuple2Map mp) = Tuple2Map (insertWith' (insertWith' f k2 a) k1 (singleton k2 a) mp)+insertMaybeTuple2Map f (k1,k2) a (Tuple2Map mp) = Tuple2Map (insertMaybe' (nonEmpty . insertMaybe f k2 a) k1 (singleton k2 a) mp)++deleteTuple2Map (k1,k2) (Tuple2Map mp) = Tuple2Map (adjustMaybe' (nonEmpty . delete k2) k1 mp)++adjustWithTuple2Map  f (k1,k2) (Tuple2Map mp) = Tuple2Map (adjustWith' (adjustWith  f k2) k1 mp)+adjustWithTuple2Map' f (k1,k2) (Tuple2Map mp) = Tuple2Map (adjustWith' (adjustWith' f k2) k1 mp)+adjustMaybeTuple2Map f (k1,k2) (Tuple2Map mp) = Tuple2Map (adjustMaybe' (nonEmpty . adjustMaybe f k2) k1 mp)++vennTuple2Map f (Tuple2Map mp1) (Tuple2Map mp2) = (Tuple2Map leftDiff, Tuple2Map inter, Tuple2Map rightDiff)+ where	leftDiff  = disjointUnion mpl (mapMaybe (\(l,_,_) -> nonEmpty l) mpi)+ 	inter =			      (mapMaybe (\(_,i,_) -> nonEmpty i) mpi)+ 	rightDiff = disjointUnion mpr (mapMaybe (\(_,_,r) -> nonEmpty r) mpi)+ 	(mpl,mpi,mpr) = venn' (venn f) mp1 mp2++vennTuple2Map' f (Tuple2Map mp1) (Tuple2Map mp2) = (Tuple2Map leftDiff, Tuple2Map inter, Tuple2Map rightDiff)+ where	leftDiff  = disjointUnion mpl (mapMaybe (\(l,_,_) -> nonEmpty l) mpi)+ 	inter =			      (mapMaybe (\(_,i,_) -> nonEmpty i) mpi)+ 	rightDiff = disjointUnion mpr (mapMaybe (\(_,_,r) -> nonEmpty r) mpi)+ 	(mpl,mpi,mpr) = venn' (venn' f) mp1 mp2++vennMaybeTuple2Map f (Tuple2Map mp1) (Tuple2Map mp2) = (Tuple2Map leftDiff, Tuple2Map inter, Tuple2Map rightDiff)+ where	leftDiff  = disjointUnion mpl (mapMaybe (\(l,_,_) -> nonEmpty l) mpi)+ 	inter =			      (mapMaybe (\(_,i,_) -> nonEmpty i) mpi)+ 	rightDiff = disjointUnion mpr (mapMaybe (\(_,_,r) -> nonEmpty r) mpi)+ 	(mpl,mpi,mpr) = venn' (vennMaybe f) mp1 mp2+ 	+disjointUnionTuple2Map (Tuple2Map mp1) (Tuple2Map mp2) = Tuple2Map (union' disjointUnion mp1 mp2)+unionTuple2Map  f (Tuple2Map mp1) (Tuple2Map mp2) = Tuple2Map (union' (union  f) mp1 mp2)+unionTuple2Map' f (Tuple2Map mp1) (Tuple2Map mp2) = Tuple2Map (union' (union' f) mp1 mp2)+unionMaybeTuple2Map f (Tuple2Map mp1) (Tuple2Map mp2) = Tuple2Map (unionMaybe' (nonEmpty `on` unionMaybe f) mp1 mp2)++intersectionTuple2Map  f (Tuple2Map mp1) (Tuple2Map mp2) = Tuple2Map (intersectionMaybe' (nonEmpty `on` intersection  f) mp1 mp2)+intersectionTuple2Map' f (Tuple2Map mp1) (Tuple2Map mp2) = Tuple2Map (intersectionMaybe' (nonEmpty `on` intersection' f) mp1 mp2)+intersectionMaybeTuple2Map f (Tuple2Map mp1) (Tuple2Map mp2) = Tuple2Map (intersectionMaybe' (nonEmpty `on` intersectionMaybe f) mp1 mp2)++differenceTuple2Map (Tuple2Map mp1) (Tuple2Map mp2) = Tuple2Map (differenceMaybe' (nonEmpty `on` difference) mp1 mp2) +differenceMaybeTuple2Map f (Tuple2Map mp1) (Tuple2Map mp2) = Tuple2Map (differenceMaybe' (nonEmpty `on` differenceMaybe f) mp1 mp2) ++isSubsetOfTuple2Map   (Tuple2Map mp1) (Tuple2Map mp2) = isSubmapOf isSubsetOf     mp1 mp2+isSubmapOfTuple2Map f (Tuple2Map mp1) (Tuple2Map mp2) = isSubmapOf (isSubmapOf f) mp1 mp2++mapTuple2Map  f (Tuple2Map mp) = Tuple2Map (map' (map  f) mp)+mapTuple2Map' f (Tuple2Map mp) = Tuple2Map (map' (map' f) mp)+mapMaybeTuple2Map f (Tuple2Map mp) = Tuple2Map (mapMaybe' (nonEmpty . mapMaybe f) mp)+mapWithKeyTuple2Map  f (Tuple2Map mp) = Tuple2Map (mapWithKey' (\k1 mp' -> mapWithKey  (\k2 a -> f (k1,k2) a) mp') mp)+mapWithKeyTuple2Map' f (Tuple2Map mp) = Tuple2Map (mapWithKey' (\k1 mp' -> mapWithKey' (\k2 a -> f (k1,k2) a) mp') mp)++filterTuple2Map f (Tuple2Map mp) = Tuple2Map (mapMaybe' (nonEmpty . filter f) mp)++foldKeysTuple2Map  f b (Tuple2Map mp) = foldAssocs  (\k1 mp' b' -> foldKeys  (\k2 b'' -> f (k1,k2) b'') b' mp') b mp+foldKeysTuple2Map' f b (Tuple2Map mp) = foldAssocs' (\k1 mp' b' -> foldKeys' (\k2 b'' -> f (k1,k2) b'') b' mp') b mp+foldKeysAscTuple2Map  f b (Tuple2Map mp) = foldAssocsAsc  (\k1 mp' b' -> foldKeysAsc  (\k2 b'' -> f (k1,k2) b'') b' mp') b mp+foldKeysAscTuple2Map' f b (Tuple2Map mp) = foldAssocsAsc' (\k1 mp' b' -> foldKeysAsc' (\k2 b'' -> f (k1,k2) b'') b' mp') b mp+foldKeysDescTuple2Map  f b (Tuple2Map mp) = foldAssocsDesc  (\k1 mp' b' -> foldKeysDesc  (\k2 b'' -> f (k1,k2) b'') b' mp') b mp+foldKeysDescTuple2Map' f b (Tuple2Map mp) = foldAssocsDesc' (\k1 mp' b' -> foldKeysDesc' (\k2 b'' -> f (k1,k2) b'') b' mp') b mp++foldElemsTuple2Map  f b (Tuple2Map mp) = foldElems  (\mp' b' -> foldElems  f b' mp') b mp+foldElemsTuple2Map' f b (Tuple2Map mp) = foldElems' (\mp' b' -> foldElems' f b' mp') b mp+foldElemsAscTuple2Map  f b (Tuple2Map mp) = foldElemsAsc  (\mp' b' -> foldElemsAsc  f b' mp') b mp+foldElemsAscTuple2Map' f b (Tuple2Map mp) = foldElemsAsc' (\mp' b' -> foldElemsAsc' f b' mp') b mp+foldElemsDescTuple2Map  f b (Tuple2Map mp) = foldElemsDesc  (\mp' b' -> foldElemsDesc  f b' mp') b mp+foldElemsDescTuple2Map' f b (Tuple2Map mp) = foldElemsDesc' (\mp' b' -> foldElemsDesc' f b' mp') b mp++foldAssocsTuple2Map  f b (Tuple2Map mp) = foldAssocs  (\k1 mp' b' -> foldAssocs  (\k2 a b'' -> f (k1,k2) a b'') b' mp') b mp+foldAssocsTuple2Map' f b (Tuple2Map mp) = foldAssocs' (\k1 mp' b' -> foldAssocs' (\k2 a b'' -> f (k1,k2) a b'') b' mp') b mp+foldAssocsAscTuple2Map  f b (Tuple2Map mp) = foldAssocsAsc  (\k1 mp' b' -> foldAssocsAsc  (\k2 a b'' -> f (k1,k2) a b'') b' mp') b mp+foldAssocsAscTuple2Map' f b (Tuple2Map mp) = foldAssocsAsc' (\k1 mp' b' -> foldAssocsAsc' (\k2 a b'' -> f (k1,k2) a b'') b' mp') b mp+foldAssocsDescTuple2Map  f b (Tuple2Map mp) = foldAssocsDesc  (\k1 mp' b' -> foldAssocsDesc  (\k2 a b'' -> f (k1,k2) a b'') b' mp') b mp+foldAssocsDescTuple2Map' f b (Tuple2Map mp) = foldAssocsDesc' (\k1 mp' b' -> foldAssocsDesc' (\k2 a b'' -> f (k1,k2) a b'') b' mp') b mp++foldElemsUIntTuple2Map f b (Tuple2Map mp) = foldElemsUInt (\mp' b' -> foldElemsUInt f b' mp') b mp++-- Util function for fromAssocs+-- Note that the fold is building difference lists+clump [] = []+clump kas = clumps' [(k',c' [])]+ where  (k', c', clumps') = L.foldl' f (fst $ fst $ head kas,id,id) kas+ 	f (currentKey,currentClump,clumps) ((k1,k2),a) =+		if 	k1 == currentKey+		then	(currentKey, currentClump . ((k2,a):), clumps                                   )+		else	(k1,         ((k2,a):),                clumps . ((currentKey,currentClump []):) )++fromAssocsAscWithTuple2Map  f kkas = Tuple2Map (fromAssocsAsc  [(k1,fromAssocsAscWith f kas)  | (k1,kas) <- clump kkas])+fromAssocsDescWithTuple2Map f kkas = Tuple2Map (fromAssocsDesc [(k1,fromAssocsDescWith f kas) | (k1,kas) <- clump kkas])++fromAssocsAscMaybeTuple2Map  f kkas = Tuple2Map (mapMaybe' nonEmpty (fromAssocsAsc  [(k1,fromAssocsAscMaybe f kas)  | (k1,kas) <- clump kkas]))+fromAssocsDescMaybeTuple2Map f kkas = Tuple2Map (mapMaybe' nonEmpty (fromAssocsDesc [(k1,fromAssocsDescMaybe f kas) | (k1,kas) <- clump kkas]))++validTuple2Map (Tuple2Map mp) = +	case valid mp of+		Nothing -> foldElems (\mp' b -> valid mp' `mplus` b) Nothing mp+		je -> je++compareKeyTuple2Map tmp (k1a,k2a) (k1b,k2b) =+	case compareKey (firstMap tmp) k1a k1b of+		LT -> LT+		EQ -> case compareKey (secondMap tmp) k2a k2b of+			LT -> LT+			EQ -> EQ+			GT -> GT+		GT -> GT+ where 	firstMap :: Tuple2Map map1 map2 k1 k2 a -> map1 a+ 	firstMap _ = undefined+ 	secondMap :: Tuple2Map map1 map2 k1 k2 a -> map2 a+ 	secondMap _ = undefined+ 	+--------------------------------------------------------------------------+--                         OTHER INSTANCES                              --+--------------------------------------------------------------------------++--------+-- Eq --+--------+instance Eq (map1 (map2 a)) => Eq (Tuple2Map map1 map2 k1 k2 a) where+ Tuple2Map mapa == Tuple2Map mapb = mapa == mapb++---------+-- Ord --+---------+instance (Map map1 k1, Map map2 k2, Ord (map1 (map2 a))) => Ord (Tuple2Map map1 map2 k1 k2 a) where+ compare (Tuple2Map mapa) (Tuple2Map mapb) = compare mapa mapb++----------+-- Show --+----------+instance (Map map1 k1, Map map2 k2, Show k1, Show k2, Show a) => Show (Tuple2Map map1 map2 k1 k2 a) where+  showsPrec d mp  = showParen (d > 10) $+    showString "fromAssocs " . shows (assocs mp)++----------+-- Read --+----------+instance (Map map1 k1, Map map2 k2, R.Read k1, R.Read k2, R.Read a) => R.Read (Tuple2Map map1 map2 k1 k2 a) where+ readPrec = R.parens $ R.prec 10 $ do R.Ident "fromAssocs" <- R.lexP+                                      xs <- R.readPrec+                                      return (fromAssocs xs)+ readListPrec = R.readListPrecDefault++------------------------+-- Typeable/Typeable1 --+------------------------+instance (Typeable1 map1, Typeable1 map2) => Typeable1 (Tuple2Map map1 map2 k1 k2) where+ typeOf1 m = mkTyConApp (mkTyCon "Data.GMap.TupleMap.Tuple2Map") [typeOf1 map]+  where Tuple2Map map = m -- This is just to get types for map1 & map2 !!+--------------+instance (Typeable1 (Tuple2Map map1 map2 k1 k2), Typeable a) => Typeable (Tuple2Map map1 map2 k1 k2 a) where+ typeOf = typeOfDefault++-------------+-- Functor --+-------------+instance (Map map1 k1, Map map2 k2) => Functor (Tuple2Map map1 map2 k1 k2) where+-- fmap :: (a -> b) -> Tuple2Map map1 map2 k1 k2 a -> Tuple2Map map1 map2 k1 k2 b+   fmap = mapTuple2Map -- The lazy version++-----------------+-- Data.Monoid --+-----------------+instance (Map map1 k1, Map map2 k2, M.Monoid a) => M.Monoid (Tuple2Map map1 map2 k1 k2 a) where+-- mempty :: Tuple2Map map1 map2 k1 k2 a+   mempty = emptyTuple2Map+-- mappend :: Tuple2Map map1 map2 k1 k2 a -> Tuple2Map map1 map2 k1 k2 a -> Tuple2Map map1 map2 k1 k2 a+   mappend map0 map1 = unionTuple2Map M.mappend map0 map1+-- mconcat :: [Tuple2Map map1 map2 k1 k2 a] -> Tuple2Map map1 map2 k1 k2 a+   mconcat maps = L.foldr (unionTuple2Map M.mappend) emptyTuple2Map maps++-------------------+-- Data.Foldable --+-------------------+instance (Map map1 k1, Map map2 k2) => F.Foldable (Tuple2Map map1 map2 k1 k2) where+-- fold :: Monoid m => Tuple2Map map1 map2 m -> m+   fold mp = foldElemsTuple2Map M.mappend M.mempty mp+-- foldMap :: Monoid m => (a -> m) -> Tuple2Map map1 map2 k1 k2 a -> m+   foldMap f mp = foldElemsTuple2Map (\a b -> M.mappend (f a) b) M.mempty mp+-- fold :: (a -> b -> b) -> b -> Tuple2Map map1 map2 k1 k2 a -> b+   foldr f b0 mp = foldElemsTuple2Map f b0 mp+-- foldl :: (a -> b -> a) -> a -> Tuple2Map map1 map2 k1 k2 b -> a+   foldl f b0 mp = foldElemsTuple2Map (flip f) b0 mp+{- ToDo: Implement properly. Meantime Foldable class has suitable defaults via lists.+-- fold1 :: (a -> a -> a) -> Tuple2Map map1 map2 k1 k2 a -> a+   fold1 = undefined+-- foldl1 :: (a -> a -> a) -> Tuple2Map map1 map2 k1 k2 a -> a+   foldl1 = undefined+-}++-------------------------------------------------------------------------------++-- Larger tuples are mapped recursively++data InjectTuple3 a b c++instance Injection (InjectTuple3 a b c) (a,b,c) (a,(b,c)) where+	inject _ (a,b,c) = (a,(b,c))+	outject _ (a,(b,c)) = (a,b,c)+	+type Tuple3Map mapa mapb mapc a b c = +	InjectKeys (InjectTuple3 a b c) (a,b,c) (a,(b,c)) +		(Tuple2Map mapa +			(Tuple2Map mapb mapc b c)+			a (b,c))+			+			+			+data InjectTuple4 a b c d++instance Injection (InjectTuple4 a b c d) (a,b,c,d) (a,(b,(c,d))) where+	inject _ (a,b,c,d) = (a,(b,(c,d)))+	outject _ (a,(b,(c,d))) = (a,b,c,d)+	+type Tuple4Map mapa mapb mapc mapd a b c d = +	InjectKeys (InjectTuple4 a b c d) (a,b,c,d) (a,(b,(c,d))) +		(Tuple2Map mapa +			(Tuple2Map mapb +				(Tuple2Map mapc mapd c d)+				b (c,d))+			a (b,(c,d)))+			+			+			+data InjectTuple5 a b c d e++instance Injection (InjectTuple5 a b c d e) (a,b,c,d,e) (a,(b,(c,(d,e)))) where+	inject _ (a,b,c,d,e) = (a,(b,(c,(d,e))))+	outject _ (a,(b,(c,(d,e)))) = (a,b,c,d,e)+	+type Tuple5Map mapa mapb mapc mapd mape a b c d e = +	InjectKeys (InjectTuple5 a b c d e) (a,b,c,d,e) (a,(b,(c,(d,e)))) +		(Tuple2Map mapa +			(Tuple2Map mapb +				(Tuple2Map mapc +					(Tuple2Map mapd mape d e)+				c (d,e))+			b (c,(d,e)))+		a (b,(c,(d,e))))
+ src/Data/GMap/UnitMap.hs view
@@ -0,0 +1,266 @@+{-# OPTIONS_GHC -fglasgow-exts -Wall -fno-warn-orphans -fno-warn-unused-imports -fno-warn-missing-signatures #-}++module Data.GMap.UnitMap+(-- * UnitMap type+ UnitMap+) where++import Data.GMap++import qualified Data.Monoid as M (Monoid(..))+import qualified Data.Foldable as F (Foldable(..))+import Data.Typeable+-- -fno-warn-unused-imports used because ghc currently gives spurious warning with this import+-- See Tickets 1074 and 1148+import qualified Data.List as L (foldr)++import GHC.Base hiding (map)+import qualified Text.Read as R (Read(..),Lexeme(..),parens,prec,lexP,readListPrecDefault)++import Data.Maybe++-- | The default 'Map' type unit (empty tuple) keys.+newtype UnitMap a = UnitMap (Maybe a)++instance Map UnitMap () where+	empty                 	= emptyUnitMap+	singleton             	= singletonUnitMap+	pair                  	= pairUnitMap+	nonEmpty              	= nonEmptyUnitMap+	status                	= statusUnitMap+	addSize               	= addSizeUnitMap+	lookup                	= lookupUnitMap+	alter			= alterUnitMap+	vennMaybe		= vennMaybeUnitMap+	unionMaybe		= unionMaybeUnitMap+	isSubsetOf            	= isSubsetOfUnitMap+	isSubmapOf            = isSubmapOfUnitMap+	mapMaybe              	= mapMaybeUnitMap+	mapWithKey            	= mapWithKeyUnitMap+	mapWithKey'           	= mapWithKeyUnitMap'+	filter                	= filterUnitMap+	foldKeys		= foldKeysUnitMap+	foldElems 		= foldElemsUnitMap+	foldAssocs		= foldAssocsUnitMap+	foldKeys'		= foldKeysUnitMap+	foldElems' 		= foldElemsUnitMap+	foldAssocs'		= foldAssocsUnitMap+	foldElemsUInt         	= foldElemsUIntUnitMap+	valid                 	= validUnitMap++instance OrderedMap UnitMap () where+	compareKey 	= compareKeyUnitMap+	-- fromAssocsAscWith+	-- fromAssocsDescWith+	-- fromAssocsAscMaybe+	-- fromAssocsDescMaybe+	foldElemsAsc	= foldElemsUnitMap+	foldElemsDesc	= foldElemsUnitMap+	foldKeysAsc	= foldKeysUnitMap+	foldKeysDesc	= foldKeysUnitMap+	foldAssocsAsc	= foldAssocsUnitMap+	foldAssocsDesc	= foldAssocsUnitMap+	foldElemsAsc'	= foldElemsUnitMap+	foldElemsDesc'	= foldElemsUnitMap+	foldKeysAsc'	= foldKeysUnitMap+	foldKeysDesc'	= foldKeysUnitMap+	foldAssocsAsc'	= foldAssocsUnitMap+	foldAssocsDesc'	= foldAssocsUnitMap++-- | See 'Map' class method 'empty'.+emptyUnitMap :: UnitMap a+emptyUnitMap = UnitMap Nothing+{-# INLINE emptyUnitMap #-}++-- | See 'Map' class method 'singleton'.+singletonUnitMap :: () -> a -> UnitMap a+singletonUnitMap _ a = UnitMap (Just a)+{-# INLINE singletonUnitMap #-}++-- | See 'Map' class method 'pair'.+pairUnitMap :: () -> () -> Maybe (a -> a -> UnitMap a)+pairUnitMap _ _ = Nothing -- Args are always equal!!+{-# INLINE pairUnitMap #-}++-- | See 'Map' class method 'nonEmpty'.+nonEmptyUnitMap :: UnitMap a -> Maybe (UnitMap a)+nonEmptyUnitMap (UnitMap Nothing) = Nothing+nonEmptyUnitMap ugt              = Just ugt++-- | See 'Map' class method 'status'.+statusUnitMap :: UnitMap a -> Status () a+statusUnitMap (UnitMap (Just a)) = One () a+statusUnitMap _                 = None++-- | See 'Map' class method 'addSize'.+addSizeUnitMap :: UnitMap a -> Int# -> Int#+addSizeUnitMap (UnitMap Nothing) n = n+addSizeUnitMap _                n = (n +# 1#)++-- | See 'Map' class method 'Data.GMap.lookup'.+lookupUnitMap :: () -> UnitMap a -> Maybe a+lookupUnitMap _ (UnitMap mba) = mba+{-# INLINE lookupUnitMap #-}++alterUnitMap :: (Maybe a -> Maybe a) -> () -> UnitMap a -> UnitMap a+alterUnitMap f _ (UnitMap mba) = UnitMap (f mba)++-- | See 'Map' class method 'vennMaybe'+vennMaybeUnitMap :: (a -> b -> Maybe c) -> UnitMap a -> UnitMap b -> (UnitMap a, UnitMap c, UnitMap b)+vennMaybeUnitMap _ (UnitMap Nothing)  (UnitMap Nothing)  = (UnitMap Nothing, UnitMap Nothing, UnitMap Nothing)+vennMaybeUnitMap _ (UnitMap ja     )  (UnitMap Nothing)  = (UnitMap ja     , UnitMap Nothing, UnitMap Nothing)+vennMaybeUnitMap _ (UnitMap Nothing)  (UnitMap jb     )  = (UnitMap Nothing, UnitMap Nothing, UnitMap jb     )+vennMaybeUnitMap f (UnitMap (Just a)) (UnitMap (Just b)) = (UnitMap Nothing, UnitMap (f a b), UnitMap Nothing)++-- | See 'Map' class method 'unionMaybe'.+unionMaybeUnitMap :: (a -> a -> Maybe a) -> UnitMap a -> UnitMap a -> UnitMap a+unionMaybeUnitMap _ (UnitMap Nothing)  (UnitMap Nothing)  = UnitMap Nothing+unionMaybeUnitMap _ (UnitMap ja     )  (UnitMap Nothing)  = UnitMap ja+unionMaybeUnitMap _ (UnitMap Nothing)  (UnitMap jb     )  = UnitMap jb+unionMaybeUnitMap f (UnitMap (Just a)) (UnitMap (Just b)) = UnitMap (f a b)++-- | See 'Map' class method 'isSubsetOf'.+isSubsetOfUnitMap :: UnitMap a -> UnitMap b -> Bool+isSubsetOfUnitMap (UnitMap Nothing ) _                  = True+isSubsetOfUnitMap (UnitMap (Just _)) (UnitMap (Just _))  = True+isSubsetOfUnitMap _                 _                  = False++-- | See 'Map' class method 'isSubmapOf'.+isSubmapOfUnitMap :: (a -> b -> Bool) -> UnitMap a -> UnitMap b -> Bool+isSubmapOfUnitMap _ (UnitMap Nothing ) _                  = True+isSubmapOfUnitMap f (UnitMap (Just a)) (UnitMap (Just b))  = f a b+isSubmapOfUnitMap _ _                 _                  = False++-- | See 'Map' class method 'Data.GMap.mapMaybe'.+mapMaybeUnitMap :: (a -> Maybe b) -> UnitMap a -> UnitMap b+mapMaybeUnitMap f (UnitMap (Just a)) = UnitMap (f a)+mapMaybeUnitMap _ _                 = emptyUnitMap++-- | See 'Map' class method 'mapWithKey'.+mapWithKeyUnitMap :: (() -> a -> b) -> UnitMap a -> UnitMap b+mapWithKeyUnitMap f (UnitMap (Just a)) = UnitMap (Just (f () a))+mapWithKeyUnitMap _ _                 = emptyUnitMap++-- | See 'Map' class method 'mapWithKey''.+mapWithKeyUnitMap' :: (() -> a -> b) -> UnitMap a -> UnitMap b+mapWithKeyUnitMap' f (UnitMap (Just a)) = let b = f () a in b `seq` UnitMap (Just b)+mapWithKeyUnitMap' _ _                 = emptyUnitMap++-- | See 'Map' class method 'Data.GMap.filter'.+filterUnitMap :: (a -> Bool) -> UnitMap a -> UnitMap a+filterUnitMap p u@(UnitMap (Just a)) = if p a then u else emptyUnitMap+filterUnitMap _   _                 = emptyUnitMap++-- | See 'Map' class method 'foldElems'+foldKeysUnitMap :: (() -> b -> b) -> b -> UnitMap a -> b+foldKeysUnitMap f b (UnitMap mba) = case mba of+	Just _  -> f () b+	Nothing -> b++-- | See 'Map' class method 'foldElems'+foldElemsUnitMap :: (a -> b -> b) -> b -> UnitMap a -> b+foldElemsUnitMap f b (UnitMap mba) = case mba of+	Just a  -> f a b+	Nothing -> b++-- | See 'Map' class method 'foldAssocs'+foldAssocsUnitMap :: (() -> a -> b -> b) -> b -> UnitMap a -> b+foldAssocsUnitMap f b (UnitMap mba) = case mba of+	Just a  -> f () a b+	Nothing -> b++-- | See 'Map' class method 'foldElemsInt#'.+foldElemsUIntUnitMap :: (a -> Int# -> Int#) -> Int# -> UnitMap a -> Int#+foldElemsUIntUnitMap f n (UnitMap mba) = case mba of+	Just a  -> f a n+	Nothing -> n++-- | See 'Map' class method 'valid'.+validUnitMap :: UnitMap a -> Maybe String+validUnitMap _ = Nothing -- Always valid!+{-# INLINE validUnitMap #-}++-- | See 'Map' class method 'compareKey'+compareKeyUnitMap :: UnitMap a -> () -> () -> Ordering+compareKeyUnitMap _ _ _ = EQ++--------------------------------------------------------------------------+--                         OTHER INSTANCES                              --+--------------------------------------------------------------------------++--------+-- Eq --+--------+instance Eq a => Eq (UnitMap a) where+ UnitMap mba0 == UnitMap mba1 = mba0 == mba1++---------+-- Ord --+---------+instance Ord a => Ord (UnitMap a) where+ compare (UnitMap Nothing  ) (UnitMap Nothing  ) = EQ+ compare (UnitMap Nothing  ) (UnitMap (Just _ )) = LT+ compare (UnitMap (Just _ )) (UnitMap Nothing  ) = GT+ compare (UnitMap (Just a0)) (UnitMap (Just a1)) = compare a0 a1++----------+-- Show --+----------+instance Show a => Show (UnitMap a) where+  showsPrec d mp  = showParen (d > 10) $+    showString "fromAssocs " . shows (assocs mp)++----------+-- Read --+----------+instance R.Read a => R.Read (UnitMap a) where+ readPrec = R.parens $ R.prec 10 $ do R.Ident "fromAssocs" <- R.lexP+                                      xs <- R.readPrec+                                      return (fromAssocs xs)+ readListPrec = R.readListPrecDefault++------------------------+-- Typeable/Typeable1 --+------------------------+instance Typeable1 UnitMap where+ typeOf1 _ = mkTyConApp (mkTyCon "Data.GMap.UnitMap.UnitMap") []+--------------+instance Typeable a => Typeable (UnitMap a) where+ typeOf = typeOfDefault++-------------+-- Functor --+-------------+instance Functor (UnitMap) where+-- fmap :: (a -> b) -> UnitMap a -> UnitMap b+   fmap = Data.GMap.map -- The lazy version++-----------------+-- Data.Monoid --+-----------------+instance (M.Monoid a) => M.Monoid (UnitMap a) where+-- mempty :: UnitMap a+   mempty = emptyUnitMap+-- mappend :: UnitMap a -> UnitMap a -> UnitMap a+   mappend map0 map1 = union M.mappend map0 map1+-- mconcat :: [UnitMap a] -> UnitMap a+   mconcat maps = L.foldr (union M.mappend) emptyUnitMap maps++-------------------+-- Data.Foldable --+-------------------+instance F.Foldable (UnitMap) where+-- fold :: Monoid m => UnitMap m -> m+   fold mp = foldElemsUnitMap M.mappend M.mempty mp+-- foldMap :: Monoid m => (a -> m) -> UnitMap a -> m+   foldMap f mp = foldElemsUnitMap (\a b -> M.mappend (f a) b) M.mempty mp+-- foldr :: (a -> b -> b) -> b -> UnitMap a -> b+   foldr f b0 mp = foldElemsUnitMap f b0 mp+-- foldl :: (a -> b -> a) -> a -> UnitMap b -> a+   foldl f b0 mp = foldElemsUnitMap (flip f) b0 mp+{- ToDo: Implement properly. Meantime Foldable class has suitable defaults via lists.+-- foldr1 :: (a -> a -> a) -> UnitMap a -> a+   foldr1 = undefined+-- foldl1 :: (a -> a -> a) -> UnitMap a -> a+   foldl1 = undefined+-}
+ src/Test/GMap.hs view
@@ -0,0 +1,727 @@+{-# OPTIONS_GHC -fglasgow-exts -XNoMonomorphismRestriction #-}++module Test.GMap where++import Test.QuickCheck+import Test.QuickCheck.Batch(bottom,isBottom)+import Test.GMap.Utils++import Data.GMap as G+import Data.GMap.AssocList+import Data.GMap.ListMap+import Data.GMap.UnitMap+import Data.GMap.MaybeMap+import Data.GMap.EitherMap+import Data.GMap.OrdMap+import Data.GMap.IntMap+-- import Data.GMap.SerialMap+import Data.GMap.CacheKeys+import Data.GMap.TupleMap+import Data.GMap.EnumMap+import Data.GMap.ChoiceMap+-- import Data.GMap.BitMap+import Data.GMap.InjectKeys++-- import Data.Serial+-- import Data.Serial.Buildable.WordList()++import qualified Data.List as L+import Prelude hiding (map,lookup)++import Control.Monad(liftM)+import Data.Maybe+import Data.Ord+import qualified Data.List as L++import System.IO+import System.Environment++import GHC.Base hiding (map)++mapSortKeys :: OrderedMap map k => map a -> [k] -> [k]+mapSortKeys mp = L.sortBy (compareKey mp)++mapSortAssocs :: OrderedMap map k => map a -> [(k,a)] -> [(k,a)]+mapSortAssocs mp = L.sortBy (\ (k1,_) (k2,_) -> compareKey mp k1 k2)++-- ### Testing OrderedMap methods ###++prop_lookup_empty mp k =+	Nothing == (lookup k $ empty `like` mp)++prop_lookup_singleton mp (k,a) =+	Just a == (lookup k $ singleton k a `like` mp)++-- General test pattern+doWith k a mp f = lookup k $ f $ insert k a mp++-- Another useful pattern+doWithout k mp f = lookup k $ f $ delete k mp++prop_insert_with mp (k,a) =+	Just a == (doWith k a mp $ insert k a)++prop_insert_without mp (k,a) =+	Just a == (doWithout k mp $ insert k a)++prop_insertWith_with mp (k,a1,a2,f) =+	Just (f a1) == (doWith k a1 mp $ insertWith f k a2)++prop_insertWith_without mp (k,a2,f) =+	Just a2 == (doWithout k mp $ insertWith f k a2)++prop_insertWith'_with mp (k,a1,a2,f) =+	Just (f a1) == (doWith k a1 mp $ insertWith' f k a2)++prop_insertWith'_without mp (k,a2,f) =+	Just a2 == (doWithout k mp $ insertWith' f k a2)++prop_insertMaybe_with mp (k,a1,a2,f) =+	(f =<< Just a1) == (doWith k a1 mp $ insertMaybe f k a2)++prop_insertMaybe_without mp (k,a2,f) =+	Just a2 == (doWithout k mp $ insertMaybe f k a2)++prop_insertMaybe'_with mp (k,a1,a2,f) =+	(f =<< Just a1) == (doWith k a1 mp $ insertMaybe' f k a2)++prop_insertMaybe'_without mp (k,a2,f) =+	Just a2 == (doWithout k mp $ insertMaybe' f k a2)++-- Dont test insertAssocs yet, still not sure whether to include them++prop_delete_with mp (k,a) =+	Nothing == (doWith k a mp $ delete k)++prop_delete_without mp k =+	Nothing == (doWithout k mp $ delete k)++prop_adjustWith_with mp (k,a,f) =+	Just (f a) == (doWith k a mp $ adjustWith f k)++prop_adjustWith_without mp (k,f) =+	Nothing == (doWithout k mp $ adjustWith f k)++prop_adjustWith'_with mp (k,a,f) =+	Just (f a) == (doWith k a mp $ adjustWith' f k)++prop_adjustWith'_without mp (k,f) =+	Nothing == (doWithout k mp $ adjustWith' f k)++prop_adjustMaybe_with mp (k,a,f) =+	(f =<< Just a) == (doWith k a mp $ adjustMaybe f k)++prop_adjustMaybe_without mp (k,f) =+	Nothing == (doWithout k mp $ adjustMaybe f k)++prop_adjustMaybe'_with mp (k,a,f) =+	(f =<< Just a) == (doWith k a mp $ adjustMaybe' f k)++prop_adjustMaybe'_without mp (k,f) =+	Nothing == (doWithout k mp $ adjustMaybe' f k)++-- The various merges are better tested by the comparison tests++prop_isSubsetOf mp as =+	isSubsetOf mp (insertAssocs as mp)++prop_isSubmapOf mp (f,as) =+	isSubmapOf (\ a b -> f a == b) mp ((map f $ insertAssocsWith const as mp) `like` mp)++prop_map mp (k,a,f) =+	Just (f a) == (doWith k a mp $ \ mp -> map f mp `like` mp)++prop_map' mp (k,a,f) =+	Just (f a) == (doWith k a mp $ \ mp -> map' f mp `like` mp)++prop_mapMaybe mp (k,a,f) =+	(f =<< Just a) == (doWith k a mp $ \ mp -> G.mapMaybe f mp `like` mp)++prop_mapMaybe' mp (k,a,f) =+	(f =<< Just a) == (doWith k a mp $ \ mp -> G.mapMaybe' f mp `like` mp)++prop_mapWithKey mp (k,a,f) =+	Just (f k a) == (doWith k a mp $ \ mp -> mapWithKey f mp `like` mp)++prop_mapWithKey' mp (k,a,f) =+	Just (f k a) == (doWith k a mp $ \ mp -> mapWithKey' f mp `like` mp)++prop_filter_in mp (k,a) =+	Just a == (doWith k a mp $ G.filter (a ==))++prop_filter_out mp (k,a) =+	Nothing == (doWith k a mp $ G.filter (a /=))++-- Dont yet know how to test folds. Need to randomly produce an associative function (or use const and lookup?)++prop_valid mp () =+	Nothing == valid mp++-- ### Strictness tests for OrderedMap ###+-- For lazy funs make every resulting elem bottom+-- For strict funs make a single resulting elem bottom++isMaybeBottom a =+	(not $ isBottom a) &&+	case a of+		Nothing -> True+		Just a' -> isBottom a'++isLazyAlter mp k f =+	let 	mp' = f mp `like` mp+	in	(not $ isBottom mp') &&+		(isMaybeBottom $ lookup k mp')++isStrictAlter mp k f =+	let 	mp' = f mp `like` mp+	in	isBottom mp'++prop_lazy_alter mp k =+	isLazyAlter mp k $ alter (\a -> Just bottom) k++prop_strict_alter' mp k =+	isStrictAlter mp k $ alter' (\a -> Just bottom) k++prop_lazy_insertWith mp k =+	isLazyAlter mp k $ insertWith (\a -> bottom) k bottom++-- insertWith' is currently only strict if the key already exists+-- !!! Remember to change this test if the semantics of insertWith' are changed+prop_strict_insertWith' mp (k,a) =+	isStrictAlter (insert k a mp) k $ insertWith' (\a -> bottom) k bottom++prop_lazy_insertMaybe mp k =+	isLazyAlter mp k $ insertMaybe (\a -> Just bottom) k bottom++-- insertMaybe' is currently only strict if the key already exists+-- !!! Remember to change this test if the semantics of insertMaybe' are changed+prop_strict_insertMaybe' mp (k,a) =+	isStrictAlter (insert k a mp) k $ insertMaybe' (\a -> Just bottom) k bottom++-- For adjusts we need to ensure that k is in the map+prop_lazy_adjustWith mp (k,a) =+	isLazyAlter (insert k a mp) k $ adjustWith (\a -> bottom) k++prop_strict_adjustWith' mp (k,a) =+	isStrictAlter (insert k a mp) k $ adjustWith' (\a -> bottom) k++prop_lazy_adjustMaybe mp (k,a) =+	isLazyAlter (insert k a mp) k $ adjustMaybe (\a -> Just bottom) k++prop_strict_adjustMaybe' mp (k,a) =+	isStrictAlter (insert k a mp) k $ adjustMaybe' (\a -> Just bottom) k++isLazyMerge :: OrderedMap map k => map a -> map a -> k -> (map a -> map a -> map a) -> Bool+isLazyMerge mp1 mp2 k f =+	let 	mp' = f mp1 mp2 `like` mp1+	in	(not $ isBottom mp') &&+		(isMaybeBottom $ lookup k mp')++isStrictMerge :: OrderedMap map k => map a -> map a -> k -> (map a -> map a -> map a) -> Bool+isStrictMerge mp1 mp2 k f =+	let 	mp' = f mp1 mp2 `like` mp1+	in	isBottom mp'++sel1 (a,b,c) = a+sel2 (a,b,c) = b+sel3 (a,b,c) = c++-- For merge tests need to ensure that resulting map has at least one assoc or the tests dont work+-- Many of these tests need to have a shared key in both maps.++prop2_lazy_venn_left (mp1,mp2) (k) =+	isLazyMerge (map (const bottom) (insert k bottom mp1)) (delete k mp2) k $ (sel1 `on` venn const)++prop2_lazy_venn_inter (mp1,mp2) (k,a) =+	isLazyMerge (insert k a mp1) (insert k a mp2) k $ (sel2 `on` venn (\a b -> bottom))++prop2_lazy_venn_right (mp1,mp2) (k) =+	isLazyMerge (delete k mp1) (map (const bottom) (insert k bottom mp2)) k $ (sel3 `on` venn const)++prop2_strict_venn'_inter (mp1,mp2) (k,a) =+	isStrictMerge (insert k bottom mp1) (insert k a mp2) k $ (sel2 `on` venn' const)++prop2_lazy_union (mp1,mp2) (k,a) =+	isLazyMerge (insert k a mp1) (insert k a mp2) k $ union (\a b -> bottom)++prop2_strict_union' (mp1,mp2) (k,a) =+	isStrictMerge (insert k a mp1) (insert k bottom mp2) k $ union' (\a b -> a `seq` b `seq` a)++prop2_lazy_unionMaybe (mp1,mp2) (k,a) =+	isLazyMerge (insert k a mp1) (insert k a mp2) k $ unionMaybe (\a b -> Just bottom)++prop2_strict_unionMaybe' (mp1,mp2) (k,a) =+	isStrictMerge (insert k a mp1) (insert k bottom mp2) k $ unionMaybe' (\a b -> a `seq` b `seq` Just a)++prop2_lazy_intersection (mp1,mp2) (k,a) =+	isLazyMerge (insert k a mp1) (insert k a mp2) k $ intersection (\a b -> bottom)++prop2_strict_intersection' (mp1,mp2) (k,a) =+	isStrictMerge (insert k a mp1) (insert k bottom mp2) k $ intersection' (\a b -> a `seq` b `seq` a)++prop2_lazy_intersectionMaybe (mp1,mp2) (k,a) =+	isLazyMerge (insert k a mp1) (insert k a mp2) k $ intersectionMaybe (\a b -> Just bottom)++prop2_strict_intersectionMaybe' (mp1,mp2) (k,a) =+	isStrictMerge (insert k a mp1) (insert k bottom mp2) k $ intersectionMaybe' (\a b -> a `seq` b `seq` Just a)++prop2_lazy_differenceMaybe (mp1,mp2) (k,a) =+	isLazyMerge (insert k a mp1) (insert k a mp2) k $ differenceMaybe (\a b -> Just bottom)++prop2_strict_differenceMaybe' (mp1,mp2) (k,a) =+	isStrictMerge (insert k a mp1) (insert k bottom mp2) k $ differenceMaybe' (\a b -> a `seq` b `seq` Just a)++-- Need to have a nonEmpty OrderedMap to test strictness of map+prop_lazy_map mp (k,a) =+	isLazyAlter (insert k a mp) k $ map (\ a' -> bottom)++prop_strict_map' mp (k,a) =+	isStrictAlter (insert k a mp) k $ map' (\ a' -> if (a==a') then bottom else a')++prop_lazy_mapMaybe mp (k,a) =+	isLazyAlter (insert k a mp) k $ G.mapMaybe (\ a' -> Just bottom)++prop_strict_mapMaybe' mp (k,a) =+	isStrictAlter (insert k a mp) k $ G.mapMaybe' (\ a' -> if (a==a') then (Just bottom) else (Just a'))++prop_lazy_mapWithKey mp (k,a) =+	isLazyAlter (insert k a mp) k $ mapWithKey (\ k' a' -> bottom)++prop_strict_mapWithKey' mp (k,a) =+	isStrictAlter (insert k a mp) k $ mapWithKey' (\ k' a' -> if ((k',a')==(k,a)) then bottom else a')++-- Lazy and strict folds are identical if the map has zero or one assocs so we must ensure that they have at least two assocs+-- We test folds by ensuring that the first accumalated value is bottom and the rest are Justs.++foldArg a b+	| isBottom b 	= Just a+	| isNothing b	= bottom+	| otherwise	= Just a++foldArgK _ = foldArg++prop_lazy_foldKeys mp ((k1,a1),(k2,a2)) =+	k1 /= k2 ==>+	not $ isBottom $ foldKeys foldArg Nothing $ insertAssocs [(k1,a1),(k2,a2)] mp++prop_strict_foldKeys' mp ((k1,a1),(k2,a2)) =+	k1 /= k2 ==>+	isBottom $ foldKeys' foldArg Nothing $ insertAssocs [(k1,a1),(k2,a2)] mp++prop_lazy_foldElems mp ((k1,a1),(k2,a2)) =+	k1 /= k2 ==>+	not $ isBottom $ foldElems foldArg Nothing $ insertAssocs [(k1,a1),(k2,a2)] mp++prop_strict_foldElems' mp ((k1,a1),(k2,a2)) =+	k1 /= k2 ==>+	isBottom $ foldElems' foldArg Nothing $ insertAssocs [(k1,a1),(k2,a2)] mp++prop_lazy_foldAssocs mp ((k1,a1),(k2,a2)) =+	k1 /= k2 ==>+	not $ isBottom $ foldAssocs foldArgK Nothing $ insertAssocs [(k1,a1),(k2,a2)] mp++prop_strict_foldAssocs' mp ((k1,a1),(k2,a2)) =+	k1 /= k2 ==>+	isBottom $ foldAssocs' foldArgK Nothing $ insertAssocs [(k1,a1),(k2,a2)] mp++-- ### Comparisons to AList ###++comp_empty mp () =+	assocsAsc (empty `like` mp)++comp_singleton mp (k,a) =+	assocsAsc (singleton k a `like` mp)++comp_pair mp (k1,k2,a1,a2) =+	fmap assocsAsc ((fmap (\ f -> f a1 a2) (pair k1 k2)) `like` (Just mp))++comp_status mp () =+	status mp++comp_nonEmpty mp () =+	fmap assocsAsc $ nonEmpty mp++comp_addSize mp (I# i) =+	I# (addSize mp i)++comp_lookup mp k =+	lookup k mp++comp_lookupCont mp (k,f) =+	lookupCont f k mp `likeMaybeElem` mp++comp_alter mp (k,f) =+	assocsAsc $ alter f k mp++comp_alter' mp (k,f) =+	assocsAsc $ alter' f k mp++comp_insertWith mp (k,a,f) =+	assocsAsc $ insertWith f k a mp++comp_insertWith' mp (k,a,f) =+	assocsAsc $ insertWith' f k a mp++-- comp_insertAssocsWith : Waiting on updates to OrderedMap api+-- comp_insertAssocsMaybe++comp_insertMaybe mp (k,a,f) =+	assocsAsc $ insertMaybe f k a mp++comp_insertMaybe' mp (k,a,f) =+	assocsAsc $ insertMaybe' f k a mp++comp_delete mp k =+	assocsAsc $ delete k mp++comp_adjustWith mp (k,f) =+	assocsAsc $ adjustWith f k mp++comp_adjustWith' mp (k,f) =+	assocsAsc $ adjustWith' f k mp++comp_adjustMaybe mp (k,f) =+	assocsAsc $ adjustMaybe f k mp++comp_adjustMaybe' mp (k,f) =+	assocsAsc $ adjustMaybe' f k mp++-- Why dont tuple functors work properly?+-- Note that the type is more constrained than venn.+vennAssocs :: (OrderedMap map k, Ord k) => (map a, map a, map a) -> ([(k,a)],[(k,a)],[(k,a)])+vennAssocs (mpa,mpc,mpb) = (assocsAsc mpa,assocsAsc mpc,assocsAsc mpb)++comp2_venn (mp1,mp2) f =+	vennAssocs $ venn f mp1 mp2++comp2_venn' (mp1,mp2) f =+	vennAssocs $ venn' f mp1 mp2++comp2_vennMaybe (mp1,mp2) f =+	vennAssocs $ vennMaybe f mp1 mp2++-- Use venn to obtain disjoint maps - so relies on venn being correct+comp2_disjointUnion (mp1,mp2) () =+	assocsAsc $ disjointUnion left right `like` mp1 `like` mp2+	where	(left,_,right) = venn const mp1 mp2++comp2_union (mp1,mp2) f =+	assocsAsc $ union f mp1 mp2 `like` mp1 `like` mp2++comp2_union' (mp1,mp2) f =+	assocsAsc $ union' f mp1 mp2 `like` mp1 `like` mp2++comp2_unionMaybe (mp1,mp2) f =+	assocsAsc $ unionMaybe f mp1 mp2 `like` mp1 `like` mp2++comp2_unionMaybe' (mp1,mp2) f =+	assocsAsc $ unionMaybe' f mp1 mp2 `like` mp1 `like` mp2++comp2_intersection (mp1,mp2) f =+	assocsAsc $ intersection f mp1 mp2 `like` mp1 `like` mp2++comp2_intersection' (mp1,mp2) f =+	assocsAsc $ intersection' f mp1 mp2 `like` mp1 `like` mp2++comp2_intersectionMaybe (mp1,mp2) f =+	assocsAsc $ intersectionMaybe f mp1 mp2 `like` mp1 `like` mp2++comp2_intersectionMaybe' (mp1,mp2) f =+	assocsAsc $ intersectionMaybe' f mp1 mp2 `like` mp1 `like` mp2++comp2_difference (mp1,mp2) () =+	assocsAsc $ difference mp1 mp2 `like` mp1 `like` mp2++comp2_differenceMaybe (mp1,mp2) f =+	assocsAsc $ differenceMaybe f mp1 mp2 `like` mp1 `like` mp2++comp2_differenceMaybe' (mp1,mp2) f =+	assocsAsc $ differenceMaybe' f mp1 mp2 `like` mp1 `like` mp2++comp2_isSubsetOf (mp1,mp2) () =+	isSubsetOf mp1 mp2++comp2_isSubmapOf (mp1,mp2) f =+	isSubmapOf f mp1 mp2++comp_map mp f =+	assocsAsc $ G.map f mp `like` mp++comp_map' mp f =+	assocsAsc $ G.map' f mp `like` mp++comp_mapMaybe mp f =+	assocsAsc $ G.mapMaybe f mp `like` mp++comp_mapMaybe' mp f =+	assocsAsc $ G.mapMaybe' f mp `like` mp++comp_mapWithKey mp f =+	assocsAsc $ G.mapWithKey f mp `like` mp++comp_mapWithKey' mp f =+	assocsAsc $ G.mapWithKey' f mp `like` mp++comp_filter mp f =+	assocsAsc $ G.filter f mp++comp_insert mp (k,a) =+	assocsAsc $ insert k a mp++-- Dont compare folds because they depend on ordering++comp_size mp () =+	size mp++comp_insertAssocs mp as =+	assocsAsc $ insertAssocs as mp++comp_fromAssocs mp as =+	assocsAsc $ fromAssocs as `like` mp++comp_fromAssocsWith mp (f,as) =+	assocsAsc $ fromAssocsWith f as `like` mp++comp2_isProperSubsetOf (mp1,mp2) () =+	isProperSubsetOf mp1 mp2++comp2_isProperSubmapOfBy (mp1,mp2) f =+	isProperSubmapOfBy f mp1 mp2++-- comp_lookupM : Need to fix monad++comp_keys mp () =+	mapSortKeys mp $ keys mp++comp_elems mp () =+	mapSortKeys mp $ elems mp++comp_assocs mp () =+	assocsAsc mp++-- ### Testing OrderedMap methods ###++propO_keysAsc mp () =+	keysAsc mp == (L.map fst $ assocsAsc mp)++propO_keysDesc mp () =+	keysDesc mp == (L.map fst $ assocsDesc mp)++propO_elemsAsc mp () =+	elemsAsc mp == (L.map snd $ assocsAsc mp)++propO_elemsDesc mp () =+	elemsDesc mp == (L.map snd $ assocsDesc mp)++propO_assocsAsc mp () =+	let 	as = assocsAsc mp+	in	L.sortBy (\ (k1,_) (k2,_) -> compareKey mp k1 k2) as == as++propO_assocsDesc mp () =+	let 	as = assocsDesc mp+	in	L.sortBy (\ (k1,_) (k2,_) -> compareKey mp k2 k1) as == as++-- ### Strictness tests for OrderedMap ###++propO_lazy_foldKeysAsc mp ((k1,a1),(k2,a2)) =+	k1 /= k2 ==>+	not $ isBottom $ foldKeysAsc foldArg Nothing $ insertAssocs [(k1,a1),(k2,a2)] mp++propO_strict_foldKeysAsc' mp ((k1,a1),(k2,a2)) =+	k1 /= k2 ==>+	isBottom $ foldKeysAsc' foldArg Nothing $ insertAssocs [(k1,a1),(k2,a2)] mp++propO_lazy_foldKeysDesc mp ((k1,a1),(k2,a2)) =+	k1 /= k2 ==>+	not $ isBottom $ foldKeysDesc foldArg Nothing $ insertAssocs [(k1,a1),(k2,a2)] mp++propO_strict_foldKeysDesc' mp ((k1,a1),(k2,a2)) =+	k1 /= k2 ==>+	isBottom $ foldKeysDesc' foldArg Nothing $ insertAssocs [(k1,a1),(k2,a2)] mp++propO_lazy_foldElemsAsc mp ((k1,a1),(k2,a2)) =+	k1 /= k2 ==>+	not $ isBottom $ foldElemsAsc foldArg Nothing $ insertAssocs [(k1,a1),(k2,a2)] mp++propO_strict_foldElemsAsc' mp ((k1,a1),(k2,a2)) =+	k1 /= k2 ==>+	isBottom $ foldElemsAsc' foldArg Nothing $ insertAssocs [(k1,a1),(k2,a2)] mp++propO_lazy_foldElemsDesc mp ((k1,a1),(k2,a2)) =+	k1 /= k2 ==>+	not $ isBottom $ foldElemsDesc foldArg Nothing $ insertAssocs [(k1,a1),(k2,a2)] mp++propO_strict_foldElemsDesc' mp ((k1,a1),(k2,a2)) =+	k1 /= k2 ==>+	isBottom $ foldElemsDesc' foldArg Nothing $ insertAssocs [(k1,a1),(k2,a2)] mp++propO_lazy_foldAssocsAsc mp ((k1,a1),(k2,a2)) =+	k1 /= k2 ==>+	not $ isBottom $ foldAssocsAsc foldArgK Nothing $ insertAssocs [(k1,a1),(k2,a2)] mp++propO_strict_foldAssocsAsc' mp ((k1,a1),(k2,a2)) =+	k1 /= k2 ==>+	isBottom $ foldAssocsAsc' foldArgK Nothing $ insertAssocs [(k1,a1),(k2,a2)] mp++propO_lazy_foldAssocsDesc mp ((k1,a1),(k2,a2)) =+	k1 /= k2 ==>+	not $ isBottom $ foldAssocsDesc foldArgK Nothing $ insertAssocs [(k1,a1),(k2,a2)] mp++propO_strict_foldAssocsDesc' mp ((k1,a1),(k2,a2)) =+	k1 /= k2 ==>+	isBottom $ foldAssocsDesc' foldArgK Nothing $ insertAssocs [(k1,a1),(k2,a2)] mp++keyedLike :: OrderedMap map k => map a -> map b -> map a+keyedLike mp _ = mp++propO_nubAscWith mp as =+	(nubAscWith (empty `keyedLike` mp) as) == (mapSortKeys mp $ L.nub as)++propO_nubDescWith mp as =+	(nubDescWith (empty `keyedLike` mp) as) == (reverse $ mapSortKeys mp $ L.nub as)++propO_sortAscWith mp as =+	(sortAscWith (empty `keyedLike` mp) as) == (mapSortKeys mp as)++propO_sortDescWith mp as =+	(sortDescWith (empty `keyedLike` mp) as) == (reverse $ mapSortKeys mp as)++-- Most methods better tested by comparisons to SList++-- ### Comparisons to SList ###++-- comp_compareKey : Useless because of the newtyping required for SList++compO_fromAssocsAscWith mp (f,as) =+	assocsAsc $ fromAssocsAscWith f (mapSortAssocs mp as) `like` mp++compO_fromAssocsDescWith mp (f,as) =+	assocsAsc $ fromAssocsDescWith f (reverse $ mapSortAssocs mp as) `like` mp++compO_fromAssocsAscMaybe mp (f,as) =+	assocsAsc $ fromAssocsAscMaybe f (mapSortAssocs mp as) `like` mp++compO_fromAssocsDescMaybe mp (f,as) =+	assocsAsc $ fromAssocsDescMaybe f (reverse $ mapSortAssocs mp as) `like` mp++compO_insertAssocsAscWith mp (f,as) =+	assocsAsc $ insertAssocsAscWith f (mapSortAssocs mp as) mp++compO_insertAssocsDescWith mp (f,as) =+	assocsAsc $ insertAssocsDescWith f (reverse $ mapSortAssocs mp as) mp++compO_insertAssocsAscMaybe mp (f,as) =+	assocsAsc $ insertAssocsAscMaybe f (mapSortAssocs mp as) mp++compO_insertAssocsDescMaybe mp (f,as) =+	assocsAsc $ insertAssocsDescMaybe f (reverse $ mapSortAssocs mp as) mp++compO_foldElemsAsc mp (f,b) =+	foldElemsAsc f b mp `likeElem` mp++compO_foldElemsDesc mp (f,b) =+	foldElemsDesc f b mp `likeElem` mp++compO_foldElemsAsc' mp (f,b) =+	foldElemsAsc' f b mp `likeElem` mp++compO_foldElemsDesc' mp (f,b) =+	foldElemsDesc' f b mp `likeElem` mp++compO_foldKeysAsc mp (f,b) =+	foldKeysAsc f b mp `likeElem` mp++compO_foldKeysDesc mp (f,b) =+	foldKeysDesc f b mp `likeElem` mp++compO_foldKeysAsc' mp (f,b) =+	foldKeysAsc' f b mp `likeElem` mp++compO_foldKeysDesc' mp (f,b) =+	foldKeysDesc' f b mp `likeElem` mp++compO_foldAssocsAsc mp (f,b) =+	foldAssocsAsc f b mp `likeElem` mp++compO_foldAssocsDesc mp (f,b) =+	foldAssocsDesc f b mp `likeElem` mp++compO_foldAssocsAsc' mp (f,b) =+	foldAssocsAsc' f b mp `likeElem` mp++compO_foldAssocsDesc' mp (f,b) =+	foldAssocsDesc' f b mp `likeElem` mp++compO_elemsAsc mp () =+	elemsAsc mp++compO_elemsDesc mp () =+	elemsDesc mp++compO_keysAsc mp () =+	keysAsc mp++compO_keysDesc mp () =+	keysDesc mp++compO_assocsAsc mp () =+	assocsAsc mp++compO_assocsDesc mp () =+	assocsDesc mp++-- Partitions, sorts not yet implemented so not tested.++-- ### Testing OrdMap methods ###++-- prop_compareKey mp (k1,k2) =+-- 	compareKey mp k1 k2 == compare k1 k2++-- ### Scripts to collate tests ###++propList = testList "Test/GMap.hs" "prop_" "SimpleTest "+props = [(SimpleTest prop_lookup_empty,"prop_lookup_empty"),(SimpleTest prop_lookup_singleton,"prop_lookup_singleton"),(SimpleTest prop_insert_with,"prop_insert_with"),(SimpleTest prop_insert_without,"prop_insert_without"),(SimpleTest prop_insertWith_with,"prop_insertWith_with"),(SimpleTest prop_insertWith_without,"prop_insertWith_without"),(SimpleTest prop_insertWith'_with,"prop_insertWith'_with"),(SimpleTest prop_insertWith'_without,"prop_insertWith'_without"),(SimpleTest prop_insertMaybe_with,"prop_insertMaybe_with"),(SimpleTest prop_insertMaybe_without,"prop_insertMaybe_without"),(SimpleTest prop_insertMaybe'_with,"prop_insertMaybe'_with"),(SimpleTest prop_insertMaybe'_without,"prop_insertMaybe'_without"),(SimpleTest prop_delete_with,"prop_delete_with"),(SimpleTest prop_delete_without,"prop_delete_without"),(SimpleTest prop_adjustWith_with,"prop_adjustWith_with"),(SimpleTest prop_adjustWith_without,"prop_adjustWith_without"),(SimpleTest prop_adjustWith'_with,"prop_adjustWith'_with"),(SimpleTest prop_adjustWith'_without,"prop_adjustWith'_without"),(SimpleTest prop_adjustMaybe_with,"prop_adjustMaybe_with"),(SimpleTest prop_adjustMaybe_without,"prop_adjustMaybe_without"),(SimpleTest prop_adjustMaybe'_with,"prop_adjustMaybe'_with"),(SimpleTest prop_adjustMaybe'_without,"prop_adjustMaybe'_without"),(SimpleTest prop_isSubsetOf,"prop_isSubsetOf"),(SimpleTest prop_isSubmapOf,"prop_isSubmapOf"),(SimpleTest prop_map,"prop_map"),(SimpleTest prop_map',"prop_map'"),(SimpleTest prop_mapMaybe,"prop_mapMaybe"),(SimpleTest prop_mapMaybe',"prop_mapMaybe'"),(SimpleTest prop_mapWithKey,"prop_mapWithKey"),(SimpleTest prop_mapWithKey',"prop_mapWithKey'"),(SimpleTest prop_filter_in,"prop_filter_in"),(SimpleTest prop_filter_out,"prop_filter_out"),(SimpleTest prop_valid,"prop_valid"),(SimpleTest prop_lazy_alter,"prop_lazy_alter"),(SimpleTest prop_strict_alter',"prop_strict_alter'"),(SimpleTest prop_lazy_insertWith,"prop_lazy_insertWith"),(SimpleTest prop_strict_insertWith',"prop_strict_insertWith'"),(SimpleTest prop_lazy_insertMaybe,"prop_lazy_insertMaybe"),(SimpleTest prop_strict_insertMaybe',"prop_strict_insertMaybe'"),(SimpleTest prop_lazy_adjustWith,"prop_lazy_adjustWith"),(SimpleTest prop_strict_adjustWith',"prop_strict_adjustWith'"),(SimpleTest prop_lazy_adjustMaybe,"prop_lazy_adjustMaybe"),(SimpleTest prop_strict_adjustMaybe',"prop_strict_adjustMaybe'"),(SimpleTest prop_lazy_map,"prop_lazy_map"),(SimpleTest prop_strict_map',"prop_strict_map'"),(SimpleTest prop_lazy_mapMaybe,"prop_lazy_mapMaybe"),(SimpleTest prop_strict_mapMaybe',"prop_strict_mapMaybe'"),(SimpleTest prop_lazy_mapWithKey,"prop_lazy_mapWithKey"),(SimpleTest prop_strict_mapWithKey',"prop_strict_mapWithKey'"),(SimpleTest prop_lazy_foldKeys,"prop_lazy_foldKeys"),(SimpleTest prop_strict_foldKeys',"prop_strict_foldKeys'"),(SimpleTest prop_lazy_foldElems,"prop_lazy_foldElems"),(SimpleTest prop_strict_foldElems',"prop_strict_foldElems'"),(SimpleTest prop_lazy_foldAssocs,"prop_lazy_foldAssocs"),(SimpleTest prop_strict_foldAssocs',"prop_strict_foldAssocs'")]++compList = testList "Test/GMap.hs" "comp_" "compareTest "+comps = [(compareTest comp_empty,"comp_empty"),(compareTest comp_singleton,"comp_singleton"),(compareTest comp_pair,"comp_pair"),(compareTest comp_status,"comp_status"),(compareTest comp_nonEmpty,"comp_nonEmpty"),(compareTest comp_addSize,"comp_addSize"),(compareTest comp_lookup,"comp_lookup"),(compareTest comp_lookupCont,"comp_lookupCont"),(compareTest comp_alter,"comp_alter"),(compareTest comp_alter',"comp_alter'"),(compareTest comp_insertWith,"comp_insertWith"),(compareTest comp_insertWith',"comp_insertWith'"),(compareTest comp_insertMaybe,"comp_insertMaybe"),(compareTest comp_insertMaybe',"comp_insertMaybe'"),(compareTest comp_delete,"comp_delete"),(compareTest comp_adjustWith,"comp_adjustWith"),(compareTest comp_adjustWith',"comp_adjustWith'"),(compareTest comp_adjustMaybe,"comp_adjustMaybe"),(compareTest comp_adjustMaybe',"comp_adjustMaybe'"),(compareTest comp_map,"comp_map"),(compareTest comp_map',"comp_map'"),(compareTest comp_mapMaybe,"comp_mapMaybe"),(compareTest comp_mapMaybe',"comp_mapMaybe'"),(compareTest comp_mapWithKey,"comp_mapWithKey"),(compareTest comp_mapWithKey',"comp_mapWithKey'"),(compareTest comp_filter,"comp_filter"),(compareTest comp_insert,"comp_insert"),(compareTest comp_size,"comp_size"),(compareTest comp_insertAssocs,"comp_insertAssocs"),(compareTest comp_fromAssocs,"comp_fromAssocs"),(compareTest comp_fromAssocsWith,"comp_fromAssocsWith"),(compareTest comp_keys,"comp_keys"),(compareTest comp_elems,"comp_elems"),(compareTest comp_assocs,"comp_assocs")]++prop2List = testList "Test/GMap.hs" "prop2_" "SimpleTest2 "+prop2s = [(SimpleTest2 prop2_lazy_venn_left,"prop2_lazy_venn_left"),(SimpleTest2 prop2_lazy_venn_inter,"prop2_lazy_venn_inter"),(SimpleTest2 prop2_lazy_venn_right,"prop2_lazy_venn_right"),(SimpleTest2 prop2_strict_venn'_inter,"prop2_strict_venn'_inter"),(SimpleTest2 prop2_lazy_union,"prop2_lazy_union"),(SimpleTest2 prop2_strict_union',"prop2_strict_union'"),(SimpleTest2 prop2_lazy_unionMaybe,"prop2_lazy_unionMaybe"),(SimpleTest2 prop2_strict_unionMaybe',"prop2_strict_unionMaybe'"),(SimpleTest2 prop2_lazy_intersection,"prop2_lazy_intersection"),(SimpleTest2 prop2_strict_intersection',"prop2_strict_intersection'"),(SimpleTest2 prop2_lazy_intersectionMaybe,"prop2_lazy_intersectionMaybe"),(SimpleTest2 prop2_strict_intersectionMaybe',"prop2_strict_intersectionMaybe'"),(SimpleTest2 prop2_lazy_differenceMaybe,"prop2_lazy_differenceMaybe"),(SimpleTest2 prop2_strict_differenceMaybe',"prop2_strict_differenceMaybe'")]++comp2List = testList "Test/GMap.hs" "comp2_" "compareTest2 "+comp2s = [(compareTest2 comp2_venn,"comp2_venn"),(compareTest2 comp2_venn',"comp2_venn'"),(compareTest2 comp2_vennMaybe,"comp2_vennMaybe"),(compareTest2 comp2_disjointUnion,"comp2_disjointUnion"),(compareTest2 comp2_union,"comp2_union"),(compareTest2 comp2_union',"comp2_union'"),(compareTest2 comp2_unionMaybe,"comp2_unionMaybe"),(compareTest2 comp2_unionMaybe',"comp2_unionMaybe'"),(compareTest2 comp2_intersection,"comp2_intersection"),(compareTest2 comp2_intersection',"comp2_intersection'"),(compareTest2 comp2_intersectionMaybe,"comp2_intersectionMaybe"),(compareTest2 comp2_intersectionMaybe',"comp2_intersectionMaybe'"),(compareTest2 comp2_difference,"comp2_difference"),(compareTest2 comp2_differenceMaybe,"comp2_differenceMaybe"),(compareTest2 comp2_differenceMaybe',"comp2_differenceMaybe'"),(compareTest2 comp2_isSubsetOf,"comp2_isSubsetOf"),(compareTest2 comp2_isSubmapOf,"comp2_isSubmapOf"),(compareTest2 comp2_isProperSubsetOf,"comp2_isProperSubsetOf"),(compareTest2 comp2_isProperSubmapOfBy,"comp2_isProperSubmapOfBy")]++propOList = testList "Test/GMap.hs" "propO_" "SimpleTest "+propOs = [(SimpleTest propO_keysAsc,"propO_keysAsc"),(SimpleTest propO_keysDesc,"propO_keysDesc"),(SimpleTest propO_elemsAsc,"propO_elemsAsc"),(SimpleTest propO_elemsDesc,"propO_elemsDesc"),(SimpleTest propO_assocsAsc,"propO_assocsAsc"),(SimpleTest propO_assocsDesc,"propO_assocsDesc"),(SimpleTest propO_lazy_foldKeysAsc,"propO_lazy_foldKeysAsc"),(SimpleTest propO_strict_foldKeysAsc',"propO_strict_foldKeysAsc'"),(SimpleTest propO_lazy_foldKeysDesc,"propO_lazy_foldKeysDesc"),(SimpleTest propO_strict_foldKeysDesc',"propO_strict_foldKeysDesc'"),(SimpleTest propO_lazy_foldElemsAsc,"propO_lazy_foldElemsAsc"),(SimpleTest propO_strict_foldElemsAsc',"propO_strict_foldElemsAsc'"),(SimpleTest propO_lazy_foldElemsDesc,"propO_lazy_foldElemsDesc"),(SimpleTest propO_strict_foldElemsDesc',"propO_strict_foldElemsDesc'"),(SimpleTest propO_lazy_foldAssocsAsc,"propO_lazy_foldAssocsAsc"),(SimpleTest propO_strict_foldAssocsAsc',"propO_strict_foldAssocsAsc'"),(SimpleTest propO_lazy_foldAssocsDesc,"propO_lazy_foldAssocsDesc"),(SimpleTest propO_strict_foldAssocsDesc',"propO_strict_foldAssocsDesc'"),(SimpleTest propO_nubAscWith,"propO_nubAscWith"),(SimpleTest propO_nubDescWith,"propO_nubDescWith"),(SimpleTest propO_sortAscWith,"propO_sortAscWith"),(SimpleTest propO_sortDescWith,"propO_sortDescWith")]++compOList = testList "Test/GMap.hs" "compO_" "compareTest "+compOs = [(compareTest compO_fromAssocsAscWith,"compO_fromAssocsAscWith"),(compareTest compO_fromAssocsDescWith,"compO_fromAssocsDescWith"),(compareTest compO_fromAssocsAscMaybe,"compO_fromAssocsAscMaybe"),(compareTest compO_fromAssocsDescMaybe,"compO_fromAssocsDescMaybe"),(compareTest compO_insertAssocsAscWith,"compO_insertAssocsAscWith"),(compareTest compO_insertAssocsDescWith,"compO_insertAssocsDescWith"),(compareTest compO_insertAssocsAscMaybe,"compO_insertAssocsAscMaybe"),(compareTest compO_insertAssocsDescMaybe,"compO_insertAssocsDescMaybe"),(compareTest compO_foldElemsAsc,"compO_foldElemsAsc"),(compareTest compO_foldElemsDesc,"compO_foldElemsDesc"),(compareTest compO_foldElemsAsc',"compO_foldElemsAsc'"),(compareTest compO_foldElemsDesc',"compO_foldElemsDesc'"),(compareTest compO_foldKeysAsc,"compO_foldKeysAsc"),(compareTest compO_foldKeysDesc,"compO_foldKeysDesc"),(compareTest compO_foldKeysAsc',"compO_foldKeysAsc'"),(compareTest compO_foldKeysDesc',"compO_foldKeysDesc'"),(compareTest compO_foldAssocsAsc,"compO_foldAssocsAsc"),(compareTest compO_foldAssocsDesc,"compO_foldAssocsDesc"),(compareTest compO_foldAssocsAsc',"compO_foldAssocsAsc'"),(compareTest compO_foldAssocsDesc',"compO_foldAssocsDesc'"),(compareTest compO_elemsAsc,"compO_elemsAsc"),(compareTest compO_elemsDesc,"compO_elemsDesc"),(compareTest compO_keysAsc,"compO_keysAsc"),(compareTest compO_keysDesc,"compO_keysDesc"),(compareTest compO_assocsAsc,"compO_assocsAsc"),(compareTest compO_assocsDesc,"compO_assocsDesc")]++unorderedTests = props ++ prop2s ++ comps ++ comp2s -- Cant currently run tests on unordered maps. Easily changed if you complain at me+allTests = props ++ propOs ++ prop2s ++ comps ++ compOs ++ comp2s++-- ### Some ready made test types ###++testSList 		= undefined :: OList Int (Int,Int)+testUnitMap 		= undefined :: UnitMap Int+testEitherMap 		= undefined :: EitherMap (OList Int) (OList Bool) Int Bool Int+testMaybeMap 		= undefined :: MaybeMap (OList Int) Int Int+testOrdMap 		= undefined :: OrdMap Int Int+testEnumMap 		= undefined :: EnumMap Bool Int+testIntMap 		= undefined :: IntMap Int+testListMap 		= undefined :: ListMap (OList Int) Int Int+testListOrdMap 		= undefined :: ListMap (OrdMap Char) Char Int+testListIntMap 		= undefined :: ListMap IntMap Int Int+-- testSerialMap 		= undefined :: SerialMap Int Int+-- testSerialMap2 		= undefined :: SerialMap String Int -- !!! Define arbitrary for some more interesting serialisable types.+-- testCacheKeysSerialMap 	= undefined :: CacheKeys (SerialMap String) String Int+testTuple2Map 		= undefined :: Tuple2Map (OList Int) (EnumMap Bool) Int Bool Int+testTuple3Map 		= undefined :: Tuple3Map (OList Int) (EnumMap Bool) IntMap Int Bool Int Int+testTuple4Map 		= undefined :: Tuple4Map (OList Int) (EnumMap Bool) IntMap (OrdMap Char) Int Bool Int Char Int+testTuple5Map 		= undefined :: Tuple5Map (OList Int) (EnumMap Bool) IntMap (OrdMap Char) (OrdMap String) Int Bool Int Char String Int+testChoice2Map 		= undefined :: Choice2Map (OList Int) (EnumMap Bool) Int Bool Int+testChoice3Map 		= undefined :: Choice3Map (OList Int) (EnumMap Bool) IntMap Int Bool Int Int+testChoice4Map 		= undefined :: Choice4Map (OList Int) (EnumMap Bool) IntMap (OrdMap Char) Int Bool Int Char Int+testChoice5Map 		= undefined :: Choice5Map (OList Int) (EnumMap Bool) IntMap (OrdMap Char) (OrdMap String) Int Bool Int Char String Int+-- testBitMap              = undefined :: SafeBitMap Int+-- testUnrollMap           = undefined :: UnrollMap Int
+ src/Test/GMap/Utils.hs view
@@ -0,0 +1,144 @@+{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -fallow-overlapping-instances -fallow-incoherent-instances -XRank2Types -fno-monomorphism-restriction #-}++module Test.GMap.Utils where++import Test.QuickCheck++import Data.GMap+import Data.GMap.ChoiceMap+import qualified Data.List as L+import Control.Monad(liftM)++import Data.GMap.AssocList++import System.Random(newStdGen)++gen n g = do+	stdg <- newStdGen+	return $ generate n stdg g++-- eg use: (Just `on` (+))       is        (\a b -> Just (a + b))+on f g a b = f (g a b)++-- ### QuickCheck instances ###++instance Show (a->b) where+	show _ = "<function>"++instance (OrderedMap map k, Arbitrary k, Arbitrary a) => Arbitrary (map a) where+	arbitrary = liftM fromAssocs (arbitrary :: Gen [(k,a)])+	coarbitrary mp = coarbitrary (assocs mp)++instance (OrderedMap map k, Show k, Show a) => Show (map a) where+	show map = "fromAssocs " ++ (show $ assocs map)++instance Arbitrary Char where+    arbitrary = sized $ \n -> choose (minBound , maxBound `min` (toEnum n))+    coarbitrary c = variant (fromEnum c)++instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e) => Arbitrary (a,b,c,d,e) where+    arbitrary = do+    	(a,b,c,(d,e)) <- arbitrary+    	return (a,b,c,d,e)+    coarbitrary (a,b,c,d,e) = coarbitrary (a,b,c,(d,e))++instance (Arbitrary a, Arbitrary b) => Arbitrary (Choice2 a b) where+   arbitrary = oneof [C1of2 `fmap` arbitrary, C2of2 `fmap` arbitrary]+   coarbitrary choice = case choice of+   	C1of2 a -> coarbitrary a+   	C2of2 b -> coarbitrary b++instance (Arbitrary a, Arbitrary b, Arbitrary c) => Arbitrary (Choice3 a b c) where+   arbitrary = oneof [C1of3 `fmap` arbitrary, C2of3 `fmap` arbitrary, C3of3 `fmap` arbitrary]+   coarbitrary choice = case choice of+   	C1of3 a -> coarbitrary a+   	C2of3 b -> coarbitrary b+   	C3of3 c -> coarbitrary c++instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d) => Arbitrary (Choice4 a b c d) where+   arbitrary = oneof [C1of4 `fmap` arbitrary, C2of4 `fmap` arbitrary, C3of4 `fmap` arbitrary, C4of4 `fmap` arbitrary]+   coarbitrary choice = case choice of+   	C1of4 a -> coarbitrary a+   	C2of4 b -> coarbitrary b+   	C3of4 c -> coarbitrary c+   	C4of4 d -> coarbitrary d++instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e) => Arbitrary (Choice5 a b c d e) where+   arbitrary = oneof [C1of5 `fmap` arbitrary, C2of5 `fmap` arbitrary, C3of5 `fmap` arbitrary, C4of5 `fmap` arbitrary, C5of5 `fmap` arbitrary]+   coarbitrary choice = case choice of+   	C1of5 a -> coarbitrary a+   	C2of5 b -> coarbitrary b+   	C3of5 c -> coarbitrary c+   	C4of5 d -> coarbitrary d+   	C5of5 e -> coarbitrary e++-- These functions are used to pass types around as undefined arguments.+like = const :: a -> a -> a+likeElem = const :: OrderedMap map k => a -> map a -> a+likeMaybeElem = const :: OrderedMap map k => Maybe a -> map a -> Maybe a++-- Test type (allows specifying type of map used in tests)+data Test m1 m2 where+	-- A simple test - pass in a map and get out something testable+	SimpleTest :: Testable b => (m1 -> b) -> Test m1 m2+	-- A simple test that requires two maps. Used for set ops etc+	SimpleTest2 :: Testable b => ((m1,m1) -> b) -> Test m1 m2+	-- CompareTest the behaviour of two different maps+	CompareTest :: (Arbitrary a, Show a, Eq b) =>+		(m1 -> a -> b) -> (m2 -> a -> b) -> Test m1 m2+	CompareTest2 :: (Arbitrary a, Show a, Eq b) =>+		((m1,m1) -> a -> b) -> ((m2,m2) -> a -> b) -> Test m1 m2++compareTest :: (OrderedMap mp1 k, OrderedMap mp2 k, Arbitrary a, Show a, Eq b, Ord k) => (forall mp. (OrderedMap mp k, Eq k, Ord k) => (mp e) -> a -> b) -> Test (mp1 e) (mp2 e)+compareTest f = CompareTest f f+compareTest2 :: (OrderedMap mp1 k, OrderedMap mp2 k, Arbitrary a, Show a, Eq b, Ord k) => (forall mp. (OrderedMap mp k, Eq k, Ord k) => ((mp e),(mp e)) -> a -> b) -> Test (mp1 e) (mp2 e)+compareTest2 f = CompareTest2 f f++-- Unsurprisingly Tests are Testable+instance (OrderedMap mp1 k, OrderedMap mp2 k, Show (mp1 a), Show (mp2 a), Arbitrary k, Arbitrary a, Show k, Show a) => Testable (Test (mp1 a) (mp2 a)) where+	property (SimpleTest f) = property f+	property (SimpleTest2 f) = property f+	property (CompareTest f1 f2) = property (\ kas a -> f1 (fromAssocs kas) a == f2 (fromAssocs kas) a)+	property (CompareTest2 f1 f2) = property (\ kas1 kas2 a -> f1 (fromAssocs kas1, fromAssocs kas2) a == f2 (fromAssocs kas1, fromAssocs kas2) a)++-- Used to generate lists of tests by parsing the source file+-- Its unfortunate that its necessary, better introspection would make life easier+testList file prefix code = do+	source <- readFile file+	let props = L.filter (\l -> (L.isPrefixOf prefix l) && (not $ L.isPrefixOf (prefix ++ " ::") l)) $+		    L.map head $ L.filter (not.null) $ L.map words $ lines source+	let printProp prop = do+		putStr "("+		putStr (code ++ prop)+		putStr ",\""+		putStr prop+		putStr "\")"+	putStr "["+	printProp $ head props+	mapM_ (\prop -> do+		putStr ","+		printProp prop) $ tail props+	putStrLn "]"++config n = Config+	{ configMaxTest = n+	, configMaxFail = 1000+	, configSize    = (+ 3) . (`div` 2)+	, configEvery   = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]+	}++-- A list of named tests+type Tests m1 m2 = [(Test m1 m2, String)]++runTests :: (Testable (Test m1 m2)) => Tests m1 m2 -> Int -> IO ()+runTests tests n =+	mapM_ ( \ (prop,name) -> do+		putStr name+		putStr " : "+		check (config n) prop ) tests++-- Narrows the type of runTests using the type of the first argument+runAListTest :: (OrderedMap mp k,        Testable (Test (mp a) (AList k a))) => (mp a) -> Tests (mp a) (AList k a) -> Int -> IO ()+runSListTest :: (OrderedMap mp k, Testable (Test (mp a) (SList mp k a))) => (mp a) -> Tests (mp a) (SList mp k a) -> Int -> IO ()+runAListTest _ = runTests+runSListTest _ = runTests