dependent-map (empty) → 0.1
raw patch · 5 files changed
+1642/−0 lines, 5 filesdep +basedep +containersdep +dependent-sumsetup-changed
Dependencies added: base, containers, dependent-sum
Files
- LICENSE +94/−0
- Setup.lhs +5/−0
- dependent-map.cabal +27/−0
- src/Data/Dependent/Map.hs +1166/−0
- src/Data/Dependent/Map/Internal.hs +350/−0
+ LICENSE view
@@ -0,0 +1,94 @@+This library (dependent-maps) is derived from code from the +containers library. I have no idea which, if any, of the following+licenses apply, so I've copied them all. Any modifications by myself+I release into the public domain, because in my opinion the concept of+owning information (ownership being a prerequisite to licensing) is +pretty silly in the first place. And, from a practical standpoint,+the proliferation of legalese that must be attached to every piece of+software of any appreciable size is actually quite obscene already.++-----------------------------------------------------------------------------++This library (libraries/containers) is derived from code from several+sources: ++ * Code from the GHC project which is largely (c) The University of+ Glasgow, and distributable under a BSD-style license (see below),++ * Code from the Haskell 98 Report which is (c) Simon Peyton Jones+ and freely redistributable (but see the full license for+ restrictions).++ * Code from the Haskell Foreign Function Interface specification,+ which is (c) Manuel M. T. Chakravarty and freely redistributable+ (but see the full license for restrictions).++The full text of these licenses is reproduced below. All of the+licenses are BSD-style or compatible.++-----------------------------------------------------------------------------++The Glasgow Haskell Compiler License++Copyright 2004, The University Court of the University of Glasgow. +All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.+ +- Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation+and/or other materials provided with the distribution.+ +- Neither name of the University nor the names of its contributors may be+used to endorse or promote products derived from this software without+specific prior written permission. ++THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF+GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH+DAMAGE.++-----------------------------------------------------------------------------++Code derived from the document "Report on the Programming Language+Haskell 98", is distributed under the following license:++ Copyright (c) 2002 Simon Peyton Jones++ The authors intend this Report to belong to the entire Haskell+ community, and so we grant permission to copy and distribute it for+ any purpose, provided that it is reproduced in its entirety,+ including this Notice. Modified versions of this Report may also be+ copied and distributed for any purpose, provided that the modified+ version is clearly presented as such, and that it does not claim to+ be a definition of the Haskell 98 Language.++-----------------------------------------------------------------------------++Code derived from the document "The Haskell 98 Foreign Function+Interface, An Addendum to the Haskell 98 Report" is distributed under+the following license:++ Copyright (c) 2002 Manuel M. T. Chakravarty++ The authors intend this Report to belong to the entire Haskell+ community, and so we grant permission to copy and distribute it for+ any purpose, provided that it is reproduced in its entirety,+ including this Notice. Modified versions of this Report may also be+ copied and distributed for any purpose, provided that the modified+ version is clearly presented as such, and that it does not claim to+ be a definition of the Haskell 98 Foreign Function Interface.++-----------------------------------------------------------------------------
+ Setup.lhs view
@@ -0,0 +1,5 @@+#!/usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain+
+ dependent-map.cabal view
@@ -0,0 +1,27 @@+name: dependent-map+version: 0.1+stability: provisional++cabal-version: >= 1.6+build-type: Simple++author: James Cook <mokus@deepbondi.net>+maintainer: James Cook <mokus@deepbondi.net>+license: OtherLicense+license-file: LICENSE+homepage: https://github.com/mokus0/dependent-map++category: Data, Dependent Types+synopsis: Dependent finite maps (partial dependent products)+description: Dependent finite maps (partial dependent products)++source-repository head+ type: git+ location: git://github.com/mokus0/dependent-map.git++Library+ hs-source-dirs: src+ ghc-options: -fwarn-unused-imports -fwarn-unused-binds+ exposed-modules: Data.Dependent.Map+ other-modules: Data.Dependent.Map.Internal+ build-depends: base >= 3 && < 5, containers, dependent-sum
+ src/Data/Dependent/Map.hs view
@@ -0,0 +1,1166 @@+{-# LANGUAGE GADTs, RankNTypes #-}+module Data.Dependent.Map+ ( DMap+ , DSum(..), Key(..)+ , GCompare(..), GOrdering(..)+ + -- * Operators+ , (!), (\\)++ -- * Query+ , null+ , size+ , member+ , notMember+ , lookup+ , findWithDefault+ + -- * Construction+ , empty+ , singleton++ -- ** Insertion+ , insert+ , insertWith+ , insertWith'+ , insertWithKey+ , insertWithKey'+ , insertLookupWithKey+ , insertLookupWithKey'+ + -- ** Delete\/Update+ , delete+ , adjust+ , adjustWithKey+ , update+ , updateWithKey+ , updateLookupWithKey+ , alter++ -- * Combine++ -- ** Union+ , union + , unionWithKey+ , unions+ , unionsWithKey++ -- ** Difference+ , difference+ , differenceWithKey+ + -- ** Intersection+ , intersection + , intersectionWithKey++ -- * Traversal+ -- ** Map+ , mapWithKey+ , mapAccumLWithKey+ , mapAccumRWithKey+ , mapKeysWith+ , mapKeysMonotonic++ -- ** Fold+ , foldWithKey+ , foldrWithKey+ , foldlWithKey+ -- , foldlWithKey'++ -- * Conversion+ , keys+ , assocs+ + -- ** Lists+ , toList+ , fromList+ , fromListWithKey++ -- ** Ordered lists+ , toAscList+ , toDescList+ , fromAscList+ , fromAscListWithKey+ , fromDistinctAscList++ -- * Filter + , filter+ , filterWithKey+ , partitionWithKey++ , mapMaybeWithKey+ , mapEitherWithKey++ , split + , splitLookup ++ -- * Submap+ , isSubmapOf, isSubmapOfBy+ , isProperSubmapOf, isProperSubmapOfBy++ -- * Indexed + , lookupIndex+ , findIndex+ , elemAt+ , updateAt+ , deleteAt++ -- * Min\/Max+ , findMin+ , findMax+ , deleteMin+ , deleteMax+ , deleteFindMin+ , deleteFindMax+ , updateMinWithKey+ , updateMaxWithKey+ , minViewWithKey+ , maxViewWithKey+ + -- * Debugging+ , showTree+ , showTreeWith+ , valid+ ) where++import Prelude hiding (null, lookup)+import Data.Dependent.Map.Internal++import Data.Dependent.Sum+import Data.GADT.Compare+import Data.Maybe (isJust)+import Data.Monoid+import Data.Typeable+import Text.Read++instance (GCompare k) => Monoid (DMap k) where+ mempty = empty+ mappend = union+ mconcat = unions++{--------------------------------------------------------------------+ Operators+--------------------------------------------------------------------}+infixl 9 !,\\ --++-- | /O(log n)/. Find the value at a key.+-- Calls 'error' when the element can not be found.+--+-- > fromList [(5,'a'), (3,'b')] ! 1 Error: element not in the map+-- > fromList [(5,'a'), (3,'b')] ! 5 == 'a'++(!) :: GCompare k => DMap k -> k v -> v+m ! k = find k m++-- | Same as 'difference'.+(\\) :: GCompare k => DMap k -> DMap k -> DMap k+m1 \\ m2 = difference m1 m2++-- #if __GLASGOW_HASKELL__+-- +-- {--------------------------------------------------------------------+-- A Data instance +-- --------------------------------------------------------------------}+-- +-- -- This instance preserves data abstraction at the cost of inefficiency.+-- -- We omit reflection services for the sake of data abstraction.+-- +-- instance (Data k, Data a, GCompare k) => Data (DMap k) where+-- gfoldl f z m = z fromList `f` toList m+-- toConstr _ = error "toConstr"+-- gunfold _ _ = error "gunfold"+-- dataTypeOf _ = mkNoRepType "Data.Map.Map"+-- dataCast2 f = gcast2 f+-- +-- #endif++{--------------------------------------------------------------------+ Query+--------------------------------------------------------------------}++-- | /O(log n)/. Is the key a member of the map? See also 'notMember'.+member :: GCompare k => k a -> DMap k -> Bool+member k = isJust . lookup k++-- | /O(log n)/. Is the key not a member of the map? See also 'member'.+notMember :: GCompare k => k v -> DMap k -> Bool+notMember k m = not (member k m)++-- | /O(log n)/. Find the value at a key.+-- Calls 'error' when the element can not be found.+-- Consider using 'lookup' when elements may not be present.+find :: GCompare k => k v -> DMap k -> v+find k m = case lookup k m of+ Nothing -> error "DMap.find: element not in the map"+ Just v -> v++-- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns+-- the value at key @k@ or returns default value @def@+-- when the key is not in the map.+findWithDefault :: GCompare k => v -> k v -> DMap k -> v+findWithDefault def k m = case lookup k m of+ Nothing -> def+ Just v -> v++{--------------------------------------------------------------------+ Insertion+--------------------------------------------------------------------}++-- | /O(log n)/. Insert a new key and value in the map.+-- If the key is already present in the map, the associated value is+-- replaced with the supplied value. 'insert' is equivalent to+-- @'insertWith' 'const'@.+insert :: GCompare k => k v -> v -> DMap k -> DMap k+insert kx x = kx `seq` go+ where+ go Tip = singleton kx x+ go (Bin sz ky y l r) = case gcompare kx ky of+ GLT -> balance ky y (go l) r+ GGT -> balance ky y l (go r)+ GEQ -> Bin sz kx x l r++-- | /O(log n)/. Insert with a function, combining new value and old value.+-- @'insertWith' f key value mp@ +-- will insert the entry @key :=> value@ into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert the entry @key :=> f new_value old_value@.+insertWith :: GCompare k => (v -> v -> v) -> k v -> v -> DMap k -> DMap k+insertWith f = insertWithKey (\_ x' y' -> f x' y')++-- | Same as 'insertWith', but the combining function is applied strictly.+-- This is often the most desirable behavior.+insertWith' :: GCompare k => (v -> v -> v) -> k v -> v -> DMap k -> DMap k+insertWith' f = insertWithKey' (\_ x' y' -> f x' y')++-- | /O(log n)/. Insert with a function, combining key, new value and old value.+-- @'insertWithKey' f key value mp@ +-- will insert the entry @key :=> value@ into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert the entry @key :=> f key new_value old_value@.+-- Note that the key passed to f is the same key passed to 'insertWithKey'.+insertWithKey :: GCompare k => (k v -> v -> v -> v) -> k v -> v -> DMap k -> DMap k+insertWithKey f kx x = kx `seq` go+ where+ go Tip = singleton kx x+ go (Bin sy ky y l r) =+ case gcompare kx ky of+ GLT -> balance ky y (go l) r+ GGT -> balance ky y l (go r)+ GEQ -> Bin sy kx (f kx x y) l r++-- | Same as 'insertWithKey', but the combining function is applied strictly.+insertWithKey' :: GCompare k => (k v -> v -> v -> v) -> k v -> v -> DMap k -> DMap k+insertWithKey' f kx x = kx `seq` go+ where+ go Tip = singleton kx $! x+ go (Bin sy ky y l r) =+ case gcompare kx ky of+ GLT -> balance ky y (go l) r+ GGT -> balance ky y l (go r)+ GEQ -> let x' = f kx x y in seq x' (Bin sy kx x' l r)++-- | /O(log n)/. Combines insert operation with old value retrieval.+-- The expression (@'insertLookupWithKey' f k x map@)+-- is a pair where the first element is equal to (@'lookup' k map@)+-- and the second element equal to (@'insertWithKey' f k x map@).+insertLookupWithKey :: GCompare k => (k v -> v -> v -> v) -> k v -> v -> DMap k+ -> (Maybe v, DMap k)+insertLookupWithKey f kx x = kx `seq` go+ where+ go Tip = (Nothing, singleton kx x)+ go (Bin sy ky y l r) =+ case gcompare kx ky of+ GLT -> let (found, l') = go l+ in (found, balance ky y l' r)+ GGT -> let (found, r') = go r+ in (found, balance ky y l r')+ GEQ -> (Just y, Bin sy kx (f kx x y) l r)++-- | /O(log n)/. A strict version of 'insertLookupWithKey'.+insertLookupWithKey' :: GCompare k => (k v -> v -> v -> v) -> k v -> v -> DMap k+ -> (Maybe v, DMap k)+insertLookupWithKey' f kx x = kx `seq` go+ where+ go Tip = x `seq` (Nothing, singleton kx x)+ go (Bin sy ky y l r) =+ case gcompare kx ky of+ GLT -> let (found, l') = go l+ in (found, balance ky y l' r)+ GGT -> let (found, r') = go r+ in (found, balance ky y l r')+ GEQ -> let x' = f kx x y in x' `seq` (Just y, Bin sy kx x' l r)++{--------------------------------------------------------------------+ Deletion+ [delete] is the inlined version of [deleteWith (\k x -> Nothing)]+--------------------------------------------------------------------}++-- | /O(log n)/. Delete a key and its value from the map. When the key is not+-- a member of the map, the original map is returned.+delete :: GCompare k => k v -> DMap k -> DMap k+delete k = k `seq` go+ where+ go Tip = Tip+ go (Bin _ kx x l r) =+ case gcompare k kx of+ GLT -> balance kx x (go l) r+ GGT -> balance kx x l (go r)+ GEQ -> glue l r++-- | /O(log n)/. Update a value at a specific key with the result of the provided function.+-- When the key is not+-- a member of the map, the original map is returned.+adjust :: GCompare k => (v -> v) -> k v -> DMap k -> DMap k+adjust f = adjustWithKey (\_ x -> f x)++-- | /O(log n)/. Adjust a value at a specific key. When the key is not+-- a member of the map, the original map is returned.+adjustWithKey :: GCompare k => (k v -> v -> v) -> k v -> DMap k -> DMap k+adjustWithKey f = updateWithKey (\k' x' -> Just (f k' x'))++-- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@+-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+update :: GCompare k => (v -> Maybe v) -> k v -> DMap k -> DMap k+update f = updateWithKey (\_ x -> f x)++-- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the+-- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing',+-- the element is deleted. If it is (@'Just' y@), the key @k@ is bound+-- to the new value @y@.+updateWithKey :: GCompare k => (k v -> v -> Maybe v) -> k v -> DMap k -> DMap k+updateWithKey f k = k `seq` go+ where+ go Tip = Tip+ go (Bin sx kx x l r) =+ case gcompare k kx of+ GLT -> balance kx x (go l) r+ GGT -> balance kx x l (go r)+ GEQ -> case f kx x of+ Just x' -> Bin sx kx x' l r+ Nothing -> glue l r++-- | /O(log n)/. Lookup and update. See also 'updateWithKey'.+-- The function returns changed value, if it is updated.+-- Returns the original key value if the map entry is deleted. +updateLookupWithKey :: GCompare k => (k v -> v -> Maybe v) -> k v -> DMap k -> (Maybe v,DMap k)+updateLookupWithKey f k = k `seq` go+ where+ go Tip = (Nothing,Tip)+ go (Bin sx kx x l r) =+ case gcompare k kx of+ GLT -> let (found,l') = go l in (found,balance kx x l' r)+ GGT -> let (found,r') = go r in (found,balance kx x l r') + GEQ -> case f kx x of+ Just x' -> (Just x',Bin sx kx x' l r)+ Nothing -> (Just x,glue l r)++-- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.+-- 'alter' can be used to insert, delete, or update a value in a 'Map'.+-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.+alter :: GCompare k => (Maybe v -> Maybe v) -> k v -> DMap k -> DMap k+alter f k = k `seq` go+ where+ go Tip = case f Nothing of+ Nothing -> Tip+ Just x -> singleton k x++ go (Bin sx kx x l r) = case gcompare k kx of+ GLT -> balance kx x (go l) r+ GGT -> balance kx x l (go r)+ GEQ -> case f (Just x) of+ Just x' -> Bin sx kx x' l r+ Nothing -> glue l r++{--------------------------------------------------------------------+ Indexing+--------------------------------------------------------------------}++-- | /O(log n)/. Return the /index/ of a key. The index is a number from+-- /0/ up to, but not including, the 'size' of the map. Calls 'error' when+-- the key is not a 'member' of the map.+findIndex :: GCompare k => k v -> DMap k -> Int+findIndex k t+ = case lookupIndex k t of+ Nothing -> error "Map.findIndex: element is not in the map"+ Just idx -> idx++-- | /O(log n)/. Lookup the /index/ of a key. The index is a number from+-- /0/ up to, but not including, the 'size' of the map.+lookupIndex :: GCompare k => k v -> DMap k -> Maybe Int+lookupIndex k = k `seq` go 0+ where+ go idx Tip = idx `seq` Nothing+ go idx (Bin _ kx _ l r)+ = idx `seq` case gcompare k kx of+ GLT -> go idx l+ GGT -> go (idx + size l + 1) r + GEQ -> Just (idx + size l)++-- | /O(log n)/. Retrieve an element by /index/. Calls 'error' when an+-- invalid index is used.+elemAt :: Int -> DMap k -> DSum k+elemAt _ Tip = error "Map.elemAt: index out of range"+elemAt i (Bin _ kx x l r)+ = case compare i sizeL of+ LT -> elemAt i l+ GT -> elemAt (i-sizeL-1) r+ EQ -> kx :=> x+ where+ sizeL = size l++-- | /O(log n)/. Update the element at /index/. Calls 'error' when an+-- invalid index is used.+updateAt :: (forall v. k v -> v -> Maybe v) -> Int -> DMap k -> DMap k+updateAt f i0 t = i0 `seq` go i0 t+ where+ go _ Tip = error "Map.updateAt: index out of range"+ go i (Bin sx kx x l r) = case compare i sizeL of+ LT -> balance kx x (go i l) r+ GT -> balance kx x l (go (i-sizeL-1) r)+ EQ -> case f kx x of+ Just x' -> Bin sx kx x' l r+ Nothing -> glue l r+ where + sizeL = size l++-- | /O(log n)/. Delete the element at /index/.+-- Defined as (@'deleteAt' i map = 'updateAt' (\k x -> 'Nothing') i map@).+deleteAt :: Int -> DMap k -> DMap k+deleteAt i m+ = updateAt (\_ _ -> Nothing) i m+++{--------------------------------------------------------------------+ Minimal, Maximal+--------------------------------------------------------------------}++-- | /O(log n)/. The minimal key of the map. Calls 'error' is the map is empty.+findMin :: DMap k -> DSum k+findMin (Bin _ kx x Tip _) = kx :=> x+findMin (Bin _ _ _ l _) = findMin l+findMin Tip = error "Map.findMin: empty map has no minimal element"++-- | /O(log n)/. The maximal key of the map. Calls 'error' is the map is empty.+findMax :: DMap k -> DSum k+findMax (Bin _ kx x _ Tip) = kx :=> x+findMax (Bin _ _ _ _ r) = findMax r+findMax Tip = error "Map.findMax: empty map has no maximal element"++-- | /O(log n)/. Delete the minimal key. Returns an empty map if the map is empty.+deleteMin :: DMap k -> DMap k+deleteMin (Bin _ _ _ Tip r) = r+deleteMin (Bin _ kx x l r) = balance kx x (deleteMin l) r+deleteMin Tip = Tip++-- | /O(log n)/. Delete the maximal key. Returns an empty map if the map is empty.+deleteMax :: DMap k -> DMap k+deleteMax (Bin _ _ _ l Tip) = l+deleteMax (Bin _ kx x l r) = balance kx x l (deleteMax r)+deleteMax Tip = Tip++-- | /O(log n)/. Update the value at the minimal key.+updateMinWithKey :: (forall v. k v -> v -> Maybe v) -> DMap k -> DMap k+updateMinWithKey f = go+ where+ go (Bin sx kx x Tip r) = case f kx x of+ Nothing -> r+ Just x' -> Bin sx kx x' Tip r+ go (Bin _ kx x l r) = balance kx x (go l) r+ go Tip = Tip++-- | /O(log n)/. Update the value at the maximal key.+updateMaxWithKey :: (forall v. k v -> v -> Maybe v) -> DMap k -> DMap k+updateMaxWithKey f = go+ where+ go (Bin sx kx x l Tip) = case f kx x of+ Nothing -> l+ Just x' -> Bin sx kx x' l Tip+ go (Bin _ kx x l r) = balance kx x l (go r)+ go Tip = Tip++-- | /O(log n)/. Retrieves the minimal (key :=> value) entry of the map, and+-- the map stripped of that element, or 'Nothing' if passed an empty map.+minViewWithKey :: DMap k -> Maybe (DSum k, DMap k)+minViewWithKey Tip = Nothing+minViewWithKey x = Just (deleteFindMin x)++-- | /O(log n)/. Retrieves the maximal (key :=> value) entry of the map, and+-- the map stripped of that element, or 'Nothing' if passed an empty map.+maxViewWithKey :: DMap k -> Maybe (DSum k, DMap k)+maxViewWithKey Tip = Nothing+maxViewWithKey x = Just (deleteFindMax x)++{--------------------------------------------------------------------+ Union. +--------------------------------------------------------------------}++-- | The union of a list of maps:+-- (@'unions' == 'Prelude.foldl' 'union' 'empty'@).+unions :: GCompare k => [DMap k] -> DMap k+unions ts+ = foldlStrict union empty ts++-- | The union of a list of maps, with a combining operation:+-- (@'unionsWithKey' f == 'Prelude.foldl' ('unionWithKey' f) 'empty'@).+unionsWithKey :: GCompare k => (forall v. k v -> v -> v -> v) -> [DMap k] -> DMap k+unionsWithKey f ts+ = foldlStrict (unionWithKey f) empty ts++-- | /O(n+m)/.+-- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@. +-- It prefers @t1@ when duplicate keys are encountered,+-- i.e. (@'union' == 'unionWith' 'const'@).+-- The implementation uses the efficient /hedge-union/ algorithm.+-- Hedge-union is more efficient on (bigset \``union`\` smallset).+union :: GCompare k => DMap k -> DMap k -> DMap k+union Tip t2 = t2+union t1 Tip = t1+union t1 t2 = hedgeUnionL (const LT) (const GT) t1 t2++-- left-biased hedge union+hedgeUnionL :: GCompare k+ => (Key k -> Ordering) -> (Key k -> Ordering) -> DMap k -> DMap k+ -> DMap k+hedgeUnionL _ _ t1 Tip+ = t1+hedgeUnionL cmplo cmphi Tip (Bin _ kx x l r)+ = join kx x (filterGt cmplo l) (filterLt cmphi r)+hedgeUnionL cmplo cmphi (Bin _ kx x l r) t2+ = join kx x (hedgeUnionL cmplo cmpkx l (trim cmplo cmpkx t2)) + (hedgeUnionL cmpkx cmphi r (trim cmpkx cmphi t2))+ where+ cmpkx k = compare (Key kx) k++{--------------------------------------------------------------------+ Union with a combining function+--------------------------------------------------------------------}++-- | /O(n+m)/.+-- Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.+-- Hedge-union is more efficient on (bigset \``union`\` smallset).+unionWithKey :: GCompare k => (forall v. k v -> v -> v -> v) -> DMap k -> DMap k -> DMap k+unionWithKey _ Tip t2 = t2+unionWithKey _ t1 Tip = t1+unionWithKey f t1 t2 = hedgeUnionWithKey f (const LT) (const GT) t1 t2++hedgeUnionWithKey :: GCompare k+ => (forall v. k v -> v -> v -> v)+ -> (Key k -> Ordering) -> (Key k -> Ordering)+ -> DMap k -> DMap k+ -> DMap k+hedgeUnionWithKey _ _ _ t1 Tip+ = t1+hedgeUnionWithKey _ cmplo cmphi Tip (Bin _ kx x l r)+ = join kx x (filterGt cmplo l) (filterLt cmphi r)+hedgeUnionWithKey f cmplo cmphi (Bin _ kx x l r) t2+ = join kx newx (hedgeUnionWithKey f cmplo cmpkx l lt) + (hedgeUnionWithKey f cmpkx cmphi r gt)+ where+ cmpkx k = compare (Key kx) k+ lt = trim cmplo cmpkx t2+ (found,gt) = trimLookupLo (Key kx) cmphi t2+ newx = case found of+ Nothing -> x+ Just (ky :=> y) -> case geq kx ky of+ Just Refl -> f kx x y+ Nothing -> error "DMap.union: inconsistent GEq instance"++{--------------------------------------------------------------------+ Difference+--------------------------------------------------------------------}++-- | /O(n+m)/. Difference of two maps. +-- Return elements of the first map not existing in the second map.+-- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.+difference :: GCompare k => DMap k -> DMap k -> DMap k+difference Tip _ = Tip+difference t1 Tip = t1+difference t1 t2 = hedgeDiff (const LT) (const GT) t1 t2++hedgeDiff :: GCompare k+ => (Key k -> Ordering) -> (Key k -> Ordering) -> DMap k -> DMap k+ -> DMap k+hedgeDiff _ _ Tip _+ = Tip+hedgeDiff cmplo cmphi (Bin _ kx x l r) Tip + = join kx x (filterGt cmplo l) (filterLt cmphi r)+hedgeDiff cmplo cmphi t (Bin _ kx _ l r) + = merge (hedgeDiff cmplo cmpkx (trim cmplo cmpkx t) l) + (hedgeDiff cmpkx cmphi (trim cmpkx cmphi t) r)+ where+ cmpkx k = compare (Key kx) k ++-- | /O(n+m)/. Difference with a combining function. When two equal keys are+-- encountered, the combining function is applied to the key and both values.+-- If it returns 'Nothing', the element is discarded (proper set difference). If+-- it returns (@'Just' y@), the element is updated with a new value @y@. +-- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.+differenceWithKey :: GCompare k => (forall v. k v -> v -> v -> Maybe v) -> DMap k -> DMap k -> DMap k+differenceWithKey _ Tip _ = Tip+differenceWithKey _ t1 Tip = t1+differenceWithKey f t1 t2 = hedgeDiffWithKey f (const LT) (const GT) t1 t2++hedgeDiffWithKey :: GCompare k+ => (forall v. k v -> v -> v -> Maybe v)+ -> (Key k -> Ordering) -> (Key k -> Ordering)+ -> DMap k -> DMap k+ -> DMap k+hedgeDiffWithKey _ _ _ Tip _+ = Tip+hedgeDiffWithKey _ cmplo cmphi (Bin _ kx x l r) Tip+ = join kx x (filterGt cmplo l) (filterLt cmphi r)+hedgeDiffWithKey f cmplo cmphi t (Bin _ kx x l r) + = case found of+ Nothing -> merge tl tr+ Just (ky :=> y) -> + case geq kx ky of+ Nothing -> error "DMap.difference: inconsistent GEq instance"+ Just Refl ->+ case f ky y x of+ Nothing -> merge tl tr+ Just z -> join ky z tl tr+ where+ cmpkx k = compare (Key kx) k + lt = trim cmplo cmpkx t+ (found,gt) = trimLookupLo (Key kx) cmphi t+ tl = hedgeDiffWithKey f cmplo cmpkx lt l+ tr = hedgeDiffWithKey f cmpkx cmphi gt r++++{--------------------------------------------------------------------+ Intersection+--------------------------------------------------------------------}++-- | /O(n+m)/. Intersection of two maps.+-- Return data in the first map for the keys existing in both maps.+-- (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@).+intersection :: GCompare k => DMap k -> DMap k -> DMap k+intersection m1 m2+ = intersectionWithKey (\_ x _ -> x) m1 m2++-- | /O(n+m)/. Intersection with a combining function.+-- Intersection is more efficient on (bigset \``intersection`\` smallset).+intersectionWithKey :: GCompare k => (forall v. k v -> v -> v -> v) -> DMap k -> DMap k -> DMap k+intersectionWithKey _ Tip _ = Tip+intersectionWithKey _ _ Tip = Tip+intersectionWithKey f t1@(Bin s1 k1 x1 l1 r1) t2@(Bin s2 k2 x2 l2 r2) =+ if s1 >= s2 then+ let (lt,found,gt) = splitLookupWithKey k2 t1+ tl = intersectionWithKey f lt l2+ tr = intersectionWithKey f gt r2+ in case found of+ Just (k,x) -> join k (f k x x2) tl tr+ Nothing -> merge tl tr+ else let (lt,found,gt) = splitLookup k1 t2+ tl = intersectionWithKey f l1 lt+ tr = intersectionWithKey f r1 gt+ in case found of+ Just x -> join k1 (f k1 x1 x) tl tr+ Nothing -> merge tl tr++++{--------------------------------------------------------------------+ Submap+--------------------------------------------------------------------}+-- | /O(n+m)/.+-- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' 'eqTagged')@).+--+isSubmapOf :: (GCompare k,EqTag k) => DMap k -> DMap k -> Bool+isSubmapOf m1 m2 = isSubmapOfBy eqTagged m1 m2++{- | /O(n+m)/.+ The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if+ all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when+ applied to their respective keys and values.+-}+isSubmapOfBy :: GCompare k => (forall v. k v -> k v -> v -> v -> Bool) -> DMap k -> DMap k -> Bool+isSubmapOfBy f t1 t2+ = (size t1 <= size t2) && (submap' f t1 t2)++submap' :: GCompare k => (forall v. k v -> k v -> v -> v -> Bool) -> DMap k -> DMap k -> Bool+submap' _ Tip _ = True+submap' _ _ Tip = False+submap' f (Bin _ kx x l r) t+ = case found of+ Nothing -> False+ Just (ky, y) -> f kx ky x y && submap' f l lt && submap' f r gt+ where+ (lt,found,gt) = splitLookupWithKey kx t++-- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal). +-- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' 'eqTagged'@).+isProperSubmapOf :: (GCompare k, EqTag k) => DMap k -> DMap k -> Bool+isProperSubmapOf m1 m2+ = isProperSubmapOfBy eqTagged m1 m2++{- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).+ The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when+ @m1@ and @m2@ are not equal,+ all keys in @m1@ are in @m2@, and when @f@ returns 'True' when+ applied to their respective keys and values. +-}+isProperSubmapOfBy :: GCompare k => (forall v. k v -> k v -> v -> v -> Bool) -> DMap k -> DMap k -> Bool+isProperSubmapOfBy f t1 t2+ = (size t1 < size t2) && (submap' f t1 t2)++{--------------------------------------------------------------------+ Filter and partition+--------------------------------------------------------------------}++-- | /O(n)/. Filter all keys\/values that satisfy the predicate.+filterWithKey :: GCompare k => (forall v. k v -> v -> Bool) -> DMap k -> DMap k+filterWithKey p = go+ where+ go Tip = Tip+ go (Bin _ kx x l r)+ | p kx x = join kx x (go l) (go r)+ | otherwise = merge (go l) (go r)++-- | /O(n)/. Partition the map according to a predicate. The first+-- map contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+partitionWithKey :: GCompare k => (forall v. k v -> v -> Bool) -> DMap k -> (DMap k,DMap k)+partitionWithKey _ Tip = (Tip,Tip)+partitionWithKey p (Bin _ kx x l r)+ | p kx x = (join kx x l1 r1,merge l2 r2)+ | otherwise = (merge l1 r1,join kx x l2 r2)+ where+ (l1,l2) = partitionWithKey p l+ (r1,r2) = partitionWithKey p r++-- | /O(n)/. Map keys\/values and collect the 'Just' results.+mapMaybeWithKey :: GCompare k => (forall v. k v -> v -> Maybe v) -> DMap k -> DMap k+mapMaybeWithKey f = go+ where+ go Tip = Tip+ go (Bin _ kx x l r) = case f kx x of+ Just y -> join kx y (go l) (go r)+ Nothing -> merge (go l) (go r)++-- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.+mapEitherWithKey :: GCompare k =>+ (forall v. k v -> v -> Either v v) -> DMap k -> (DMap k, DMap k)+mapEitherWithKey _ Tip = (Tip, Tip)+mapEitherWithKey f (Bin _ kx x l r) = case f kx x of+ Left y -> (join kx y l1 r1, merge l2 r2)+ Right z -> (merge l1 r1, join kx z l2 r2)+ where+ (l1,l2) = mapEitherWithKey f l+ (r1,r2) = mapEitherWithKey f r++{--------------------------------------------------------------------+ Mapping+--------------------------------------------------------------------}++-- | /O(n)/. Map a function over all values in the map.+mapWithKey :: (forall v. k v -> v -> v) -> DMap k -> DMap k+mapWithKey f = go+ where+ go Tip = Tip+ go (Bin sx kx x l r) = Bin sx kx (f kx x) (go l) (go r)++-- | /O(n)/. The function 'mapAccumLWithKey' threads an accumulating+-- argument throught the map in ascending order of keys.+mapAccumLWithKey :: (forall v. a -> k v -> v -> (a,v)) -> a -> DMap k -> (a,DMap k)+mapAccumLWithKey f = go+ where+ go a Tip = (a,Tip)+ go a (Bin sx kx x l r) =+ let (a1,l') = go a l+ (a2,x') = f a1 kx x+ (a3,r') = go a2 r+ in (a3,Bin sx kx x' l' r')++-- | /O(n)/. The function 'mapAccumRWithKey' threads an accumulating+-- argument through the map in descending order of keys.+mapAccumRWithKey :: (forall v. a -> k v -> v -> (a,v)) -> a -> DMap k -> (a, DMap k)+mapAccumRWithKey f = go+ where+ go a Tip = (a,Tip)+ go a (Bin sx kx x l r) =+ let (a1,r') = go a r+ (a2,x') = f a1 kx x+ (a3,l') = go a2 l+ in (a3,Bin sx kx x' l' r')++-- | /O(n*log n)/.+-- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.+-- +-- The size of the result may be smaller if @f@ maps two or more distinct+-- keys to the same new key. In this case the associated values will be+-- combined using @c@.+mapKeysWith :: GCompare k2 => (forall v. k2 v -> v -> v -> v) -> (forall v. k1 v -> k2 v) -> DMap k1 -> DMap k2+mapKeysWith c f = fromListWithKey c . map fFirst . toList+ where fFirst (x :=> y) = (f x :=> y)+++-- | /O(n)/.+-- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@+-- is strictly monotonic.+-- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@.+-- /The precondition is not checked./+-- Semi-formally, we have:+-- +-- > and [x < y ==> f x < f y | x <- ls, y <- ls] +-- > ==> mapKeysMonotonic f s == mapKeys f s+-- > where ls = keys s+--+-- This means that @f@ maps distinct original keys to distinct resulting keys.+-- This function has better performance than 'mapKeys'.+mapKeysMonotonic :: (forall v. k1 v -> k2 v) -> DMap k1 -> DMap k2+mapKeysMonotonic _ Tip = Tip+mapKeysMonotonic f (Bin sz k x l r) =+ Bin sz (f k) x (mapKeysMonotonic f l) (mapKeysMonotonic f r)++{--------------------------------------------------------------------+ Folds +--------------------------------------------------------------------}++-- | /O(n)/. Fold the keys and values in the map, such that+-- @'foldWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.+--+-- This is identical to 'foldrWithKey', and you should use that one instead of+-- this one. This name is kept for backward compatibility.+foldWithKey :: (forall v. k v -> v -> b -> b) -> b -> DMap k -> b+foldWithKey = foldrWithKey+{-# DEPRECATED foldWithKey "Use foldrWithKey instead" #-}++-- | /O(n)/. Post-order fold. The function will be applied from the lowest+-- value to the highest.+foldrWithKey :: (forall v. k v -> v -> b -> b) -> b -> DMap k -> b+foldrWithKey f = go+ where+ go z Tip = z+ go z (Bin _ kx x l r) = go (f kx x (go z r)) l++-- | /O(n)/. Pre-order fold. The function will be applied from the highest+-- value to the lowest.+foldlWithKey :: (forall v. b -> k v -> v -> b) -> b -> DMap k -> b+foldlWithKey f = go+ where+ go z Tip = z+ go z (Bin _ kx x l r) = go (f (go z l) kx x) r++{-+-- | /O(n)/. A strict version of 'foldlWithKey'.+foldlWithKey' :: (b -> k -> a -> b) -> b -> DMap k -> b+foldlWithKey' f = go+ where+ go z Tip = z+ go z (Bin _ kx x l r) = z `seq` go (f (go z l) kx x) r+-}++{--------------------------------------------------------------------+ List variations +--------------------------------------------------------------------}++-- | /O(n)/. Return all keys of the map in ascending order.+--+-- > keys (fromList [(5,"a"), (3,"b")]) == [3,5]+-- > keys empty == []++keys :: DMap k -> [Key k]+keys m+ = [Key k | (k :=> _) <- assocs m]++-- | /O(n)/. Return all key\/value pairs in the map in ascending key order.+assocs :: DMap k -> [DSum k]+assocs m+ = toList m++{--------------------------------------------------------------------+ Lists + use [foldlStrict] to reduce demand on the control-stack+--------------------------------------------------------------------}++-- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'.+-- If the list contains more than one value for the same key, the last value+-- for the key is retained.+fromList :: GCompare k => [DSum k] -> DMap k +fromList xs + = foldlStrict ins empty xs+ where+ ins :: GCompare k => DMap k -> DSum k -> DMap k+ ins t (k :=> x) = insert k x t++-- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'.+fromListWithKey :: GCompare k => (forall v. k v -> v -> v -> v) -> [DSum k] -> DMap k +fromListWithKey f xs + = foldlStrict (ins f) empty xs+ where+ ins :: GCompare k => (forall v. k v -> v -> v -> v) -> DMap k -> DSum k -> DMap k+ ins f t (k :=> x) = insertWithKey f k x t++-- | /O(n)/. Convert to a list of key\/value pairs.+toList :: DMap k -> [DSum k]+toList t = toAscList t++-- | /O(n)/. Convert to an ascending list.+toAscList :: DMap k -> [DSum k]+toAscList t = foldrWithKey (\k x xs -> (k :=> x):xs) [] t++-- | /O(n)/. Convert to a descending list.+toDescList :: DMap k -> [DSum k]+toDescList t = foldlWithKey (\xs k x -> (k :=> x):xs) [] t++{--------------------------------------------------------------------+ Building trees from ascending/descending lists can be done in linear time.+ + Note that if [xs] is ascending that: + fromAscList xs == fromList xs+ fromAscListWith f xs == fromListWith f xs+--------------------------------------------------------------------}++-- | /O(n)/. Build a map from an ascending list in linear time.+-- /The precondition (input list is ascending) is not checked./+fromAscList :: GEq k => [DSum k] -> DMap k +fromAscList xs+ = fromAscListWithKey (\_ x _ -> x) xs++-- | /O(n)/. Build a map from an ascending list in linear time with a+-- combining function for equal keys.+-- /The precondition (input list is ascending) is not checked./+fromAscListWithKey :: GEq k => (forall v. k v -> v -> v -> v) -> [DSum k] -> DMap k +fromAscListWithKey f xs+ = fromDistinctAscList (combineEq f xs)+ where+ -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]+ combineEq _ xs'+ = case xs' of+ [] -> []+ [x] -> [x]+ (x:xx) -> combineEq' f x xx++ combineEq' :: GEq k => (forall v. k v -> v -> v -> v) -> DSum k -> [DSum k] -> [DSum k]+ combineEq' f z [] = [z]+ combineEq' f z@(kz :=> zz) (x@(kx :=> xx):xs') =+ case geq kx kz of+ Just Refl -> let yy = f kx xx zz in combineEq' f (kx :=> yy) xs'+ Nothing -> z : combineEq' f x xs'+++-- | /O(n)/. Build a map from an ascending list of distinct elements in linear time.+-- /The precondition is not checked./+fromDistinctAscList :: [DSum k] -> DMap k +fromDistinctAscList xs+ = build const (length xs) xs+ where+ -- 1) use continutations so that we use heap space instead of stack space.+ -- 2) special case for n==5 to build bushier trees. + + build :: (DMap k -> [DSum k] -> b) -> Int -> [DSum k] -> b+ build c 0 xs' = c Tip xs'+ build c 5 xs' = case xs' of+ ((k1:=>x1):(k2:=>x2):(k3:=>x3):(k4:=>x4):(k5:=>x5):xx) + -> c (bin k4 x4 (bin k2 x2 (singleton k1 x1) (singleton k3 x3)) (singleton k5 x5)) xx+ _ -> error "fromDistinctAscList build"+ build c n xs' = seq nr $ build (buildR nr c) nl xs'+ where+ nl = n `div` 2+ nr = n - nl - 1++ buildR :: Int -> (DMap k -> [DSum k] -> b) -> DMap k -> [DSum k] -> b+ buildR n c l ((k:=>x):ys) = build (buildB l k x c) n ys+ buildR _ _ _ [] = error "fromDistinctAscList buildR []"+ + buildB :: DMap k -> k v -> v -> (DMap k -> a -> b) -> DMap k -> a -> b+ buildB l k x c r zs = c (bin k x l r) zs+ ++{--------------------------------------------------------------------+ Split+--------------------------------------------------------------------}++-- | /O(log n)/. The expression (@'split' k map@) is a pair @(map1,map2)@ where+-- the keys in @map1@ are smaller than @k@ and the keys in @map2@ larger than @k@.+-- Any key equal to @k@ is found in neither @map1@ nor @map2@.+split :: GCompare k => k v -> DMap k -> (DMap k,DMap k)+split k = go+ where+ go Tip = (Tip, Tip)+ go (Bin _ kx x l r) = case gcompare k kx of+ GLT -> let (lt,gt) = go l in (lt,join kx x gt r)+ GGT -> let (lt,gt) = go r in (join kx x l lt,gt)+ GEQ -> (l,r)++-- | /O(log n)/. The expression (@'splitLookup' k map@) splits a map just+-- like 'split' but also returns @'lookup' k map@.+splitLookup :: GCompare k => k v -> DMap k -> (DMap k,Maybe v,DMap k)+splitLookup k = go+ where+ go Tip = (Tip,Nothing,Tip)+ go (Bin _ kx x l r) = case gcompare k kx of+ GLT -> let (lt,z,gt) = go l in (lt,z,join kx x gt r)+ GGT -> let (lt,z,gt) = go r in (join kx x l lt,z,gt)+ GEQ -> (l,Just x,r)++-- | /O(log n)/.+splitLookupWithKey :: GCompare k => k v -> DMap k -> (DMap k,Maybe (k v, v),DMap k)+splitLookupWithKey k = go+ where+ go Tip = (Tip,Nothing,Tip)+ go (Bin _ kx x l r) = case gcompare k kx of+ GLT -> let (lt,z,gt) = go l in (lt,z,join kx x gt r)+ GGT -> let (lt,z,gt) = go r in (join kx x l lt,z,gt)+ GEQ -> (l,Just (kx, x),r)++{--------------------------------------------------------------------+ Eq converts the tree to a list. In a lazy setting, this + actually seems one of the faster methods to compare two trees + and it is certainly the simplest :-)+--------------------------------------------------------------------}+instance EqTag k => Eq (DMap k) where+ t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2)++{--------------------------------------------------------------------+ Ord +--------------------------------------------------------------------}++instance OrdTag k => Ord (DMap k) where+ compare m1 m2 = compare (toAscList m1) (toAscList m2)++{--------------------------------------------------------------------+ Read+--------------------------------------------------------------------}++instance (GCompare f, ReadTag f) => Read (DMap f) where+ readPrec = parens $ prec 10 $ do+ Ident "fromList" <- lexP+ xs <- readPrec+ return (fromList xs)++ readListPrec = readListPrecDefault++{--------------------------------------------------------------------+ Show+--------------------------------------------------------------------}+instance ShowTag k => Show (DMap k) where+ showsPrec p m = showParen (p>10)+ ( showString "fromList "+ . showsPrec 11 (toList m)+ )++-- | /O(n)/. Show the tree that implements the map. The tree is shown+-- in a compressed, hanging format. See 'showTreeWith'.+showTree :: ShowTag k => DMap k -> String+showTree m+ = showTreeWith showElem True False m+ where+ showElem :: ShowTag k => k v -> v -> String+ showElem k x = show (k :=> x)+++{- | /O(n)/. The expression (@'showTreeWith' showelem hang wide map@) shows+ the tree that implements the map. Elements are shown using the @showElem@ function. If @hang@ is+ 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If+ @wide@ is 'True', an extra wide version is shown.+-}+showTreeWith :: (forall v. k v -> v -> String) -> Bool -> Bool -> DMap k -> String+showTreeWith showelem hang wide t+ | hang = (showsTreeHang showelem wide [] t) ""+ | otherwise = (showsTree showelem wide [] [] t) ""++showsTree :: (forall v. k v -> v -> String) -> Bool -> [String] -> [String] -> DMap k -> ShowS+showsTree showelem wide lbars rbars t+ = case t of+ Tip -> showsBars lbars . showString "|\n"+ Bin _ kx x Tip Tip+ -> showsBars lbars . showString (showelem kx x) . showString "\n" + Bin _ kx x l r+ -> showsTree showelem wide (withBar rbars) (withEmpty rbars) r .+ showWide wide rbars .+ showsBars lbars . showString (showelem kx x) . showString "\n" .+ showWide wide lbars .+ showsTree showelem wide (withEmpty lbars) (withBar lbars) l++showsTreeHang :: (forall v. k v -> v -> String) -> Bool -> [String] -> DMap k -> ShowS+showsTreeHang showelem wide bars t+ = case t of+ Tip -> showsBars bars . showString "|\n" + Bin _ kx x Tip Tip+ -> showsBars bars . showString (showelem kx x) . showString "\n" + Bin _ kx x l r+ -> showsBars bars . showString (showelem kx x) . showString "\n" . + showWide wide bars .+ showsTreeHang showelem wide (withBar bars) l .+ showWide wide bars .+ showsTreeHang showelem wide (withEmpty bars) r++showWide :: Bool -> [String] -> String -> String+showWide wide bars + | wide = showString (concat (reverse bars)) . showString "|\n" + | otherwise = id++showsBars :: [String] -> ShowS+showsBars bars+ = case bars of+ [] -> id+ _ -> showString (concat (reverse (tail bars))) . showString node++node :: String+node = "+--"++withBar, withEmpty :: [String] -> [String]+withBar bars = "| ":bars+withEmpty bars = " ":bars++{--------------------------------------------------------------------+ Typeable+--------------------------------------------------------------------}++instance Typeable1 f => Typeable (DMap f) where+ typeOf ds = mkTyConApp dMapCon [typeOfT]+ where+ dMapCon = mkTyCon "Data.Dependent.Map.DMap"+ typeOfT = typeOf1 $ (undefined :: DMap f -> f a) ds+ ++{--------------------------------------------------------------------+ Assertions+--------------------------------------------------------------------}++-- | /O(n)/. Test if the internal map structure is valid.+valid :: GCompare k => DMap k -> Bool+valid t+ = balanced t && ordered t && validsize t++ordered :: GCompare k => DMap k -> Bool+ordered t+ = bounded (const True) (const True) t+ where+ bounded :: GCompare k => (Key k -> Bool) -> (Key k -> Bool) -> DMap k -> Bool+ bounded lo hi t'+ = case t' of+ Tip -> True+ Bin _ kx _ l r -> (lo (Key kx)) && (hi (Key kx)) && bounded lo (< Key kx) l && bounded (> Key kx) hi r++-- | Exported only for "Debug.QuickCheck"+balanced :: DMap k -> Bool+balanced t+ = case t of+ Tip -> True+ Bin _ _ _ l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&+ balanced l && balanced r++validsize :: DMap k -> Bool+validsize t+ = (realsize t == Just (size t))+ where+ realsize t'+ = case t' of+ Tip -> Just 0+ Bin sz _ _ l r -> case (realsize l,realsize r) of+ (Just n,Just m) | n+m+1 == sz -> Just sz+ _ -> Nothing+{--------------------------------------------------------------------+ Utilities+--------------------------------------------------------------------}+foldlStrict :: (a -> b -> a) -> a -> [b] -> a+foldlStrict f = go+ where+ go z [] = z+ go z (x:xs) = z `seq` go (f z x) xs+
+ src/Data/Dependent/Map/Internal.hs view
@@ -0,0 +1,350 @@+{-# LANGUAGE GADTs #-}+module Data.Dependent.Map.Internal where++import Data.Dependent.Sum+import Data.GADT.Compare+import Data.GADT.Show++-- |A 'Key' is just a wrapper for the true key type @f@ which hides+-- the associated value type and presents the key's GADT-level 'GCompare' +-- instance as a vanilla 'Ord' instance so it can be used in cases where we+-- don't care about the associated value.+data Key f where Key :: !(f a) -> Key f+instance GEq f => Eq (Key f) where+ Key a == Key b = maybe False (const True) (geq a b)+instance GCompare f => Ord (Key f) where+ compare (Key a) (Key b) = weakenOrdering (gcompare a b)++instance GShow f => Show (Key f) where+ showsPrec p (Key k) = showParen (p>10)+ ( showString "Key "+ . gshowsPrec 11 k+ )+instance GRead f => Read (Key f) where+ readsPrec p = readParen (p>10) $ \s ->+ [ (withTag Key, rest')+ | let (con, rest) = splitAt 4 s+ , con == "Key "+ , (withTag, rest') <- greadsPrec 11 rest+ ]++-- |Dependent maps: f is a GADT-like thing with a facility for +-- rediscovering its type parameter, elements of which function as identifiers+-- tagged with the type of the thing they identify. Real GADTs are one+-- useful instantiation of @f@, as are 'Tag's from "Data.Dependent.Tag".+--+-- Semantically, @'DMap' f@ is equivalent to a set of @'DSum' f@ where no two+-- elements have the same tag.+--+-- More informally, 'DMap' is to dependent products as 'M.Map' is to @(->)@.+-- Thus it could also be thought of as a partial (in the sense of \"partial+-- function\") dependent product.+data DMap k where+ Tip :: DMap k+ Bin ::+ { sz :: !Int+ , key :: !(k v)+ , value :: v+ , left :: !(DMap k)+ , right :: !(DMap k)+ } -> DMap k++{--------------------------------------------------------------------+ Construction+--------------------------------------------------------------------}++-- | /O(1)/. The empty map.+--+-- > empty == fromList []+-- > size empty == 0+empty :: DMap k+empty = Tip++-- | /O(1)/. A map with a single element.+--+-- > singleton 1 'a' == fromList [(1, 'a')]+-- > size (singleton 1 'a') == 1+singleton :: k v -> v -> DMap k+singleton k x = Bin 1 k x Tip Tip++{--------------------------------------------------------------------+ Query+--------------------------------------------------------------------}++-- | /O(1)/. Is the map empty?+null :: DMap k -> Bool+null Tip = True+null Bin{} = False++-- | /O(1)/. The number of elements in the map.+size :: DMap k -> Int+size Tip = 0+size Bin{sz = n} = n++-- | /O(log n)/. Lookup the value at a key in the map.+--+-- The function will return the corresponding value as @('Just' value)@,+-- or 'Nothing' if the key isn't in the map.+lookup :: GCompare k => k v -> DMap k -> Maybe v+lookup k = k `seq` go+ where+ go Tip = Nothing+ go (Bin _ kx x l r) = + case gcompare k kx of+ GLT -> go l+ GGT -> go r+ GEQ -> Just x++lookupAssoc :: GCompare k => Key k -> DMap k -> Maybe (DSum k)+lookupAssoc (Key k) = k `seq` go+ where+ go Tip = Nothing+ go (Bin _ kx x l r) =+ case gcompare k kx of+ GLT -> go l+ GGT -> go r+ GEQ -> Just (kx :=> x)++{--------------------------------------------------------------------+ Utility functions that maintain the balance properties of the tree.+ All constructors assume that all values in [l] < [k] and all values+ in [r] > [k], and that [l] and [r] are valid trees.+ + In order of sophistication:+ [Bin sz k x l r] The type constructor.+ [bin k x l r] Maintains the correct size, assumes that both [l]+ and [r] are balanced with respect to each other.+ [balance k x l r] Restores the balance and size.+ Assumes that the original tree was balanced and+ that [l] or [r] has changed by at most one element.+ [join k x l r] Restores balance and size. ++ Furthermore, we can construct a new tree from two trees. Both operations+ assume that all values in [l] < all values in [r] and that [l] and [r]+ are valid:+ [glue l r] Glues [l] and [r] together. Assumes that [l] and+ [r] are already balanced with respect to each other.+ [merge l r] Merges two trees and restores balance.++ Note: in contrast to Adam's paper, we use (<=) comparisons instead+ of (<) comparisons in [join], [merge] and [balance]. + Quickcheck (on [difference]) showed that this was necessary in order + to maintain the invariants. It is quite unsatisfactory that I haven't + been able to find out why this is actually the case! Fortunately, it + doesn't hurt to be a bit more conservative.+--------------------------------------------------------------------}++{--------------------------------------------------------------------+ Join +--------------------------------------------------------------------}+join :: GCompare k => k v -> v -> DMap k -> DMap k -> DMap k+join kx x Tip r = insertMin kx x r+join kx x l Tip = insertMax kx x l+join kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz)+ | delta*sizeL <= sizeR = balance kz z (join kx x l lz) rz+ | delta*sizeR <= sizeL = balance ky y ly (join kx x ry r)+ | otherwise = bin kx x l r+++-- insertMin and insertMax don't perform potentially expensive comparisons.+insertMax,insertMin :: k v -> v -> DMap k -> DMap k+insertMax kx x t+ = case t of+ Tip -> singleton kx x+ Bin _ ky y l r+ -> balance ky y l (insertMax kx x r)+ +insertMin kx x t+ = case t of+ Tip -> singleton kx x+ Bin _ ky y l r+ -> balance ky y (insertMin kx x l) r+ +{--------------------------------------------------------------------+ [merge l r]: merges two trees.+--------------------------------------------------------------------}+merge :: DMap k -> DMap k -> DMap k+merge Tip r = r+merge l Tip = l+merge l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry)+ | delta*sizeL <= sizeR = balance ky y (merge l ly) ry+ | delta*sizeR <= sizeL = balance kx x lx (merge rx r)+ | otherwise = glue l r++{--------------------------------------------------------------------+ [glue l r]: glues two trees together.+ Assumes that [l] and [r] are already balanced with respect to each other.+--------------------------------------------------------------------}+glue :: DMap k -> DMap k -> DMap k+glue Tip r = r+glue l Tip = l+glue l r + | size l > size r = case deleteFindMax l of (km :=> m,l') -> balance km m l' r+ | otherwise = case deleteFindMin r of (km :=> m,r') -> balance km m l r'++-- | /O(log n)/. Delete and find the minimal element.+--+-- > deleteFindMin (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((3,"b"), fromList[(5,"a"), (10,"c")]) +-- > deleteFindMin Error: can not return the minimal element of an empty map++deleteFindMin :: DMap k -> (DSum k, DMap k)+deleteFindMin t + = case t of+ Bin _ k x Tip r -> (k :=> x ,r)+ Bin _ k x l r -> let (km,l') = deleteFindMin l in (km,balance k x l' r)+ Tip -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip)++-- | /O(log n)/. Delete and find the maximal element.+--+-- > deleteFindMax (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((10,"c"), fromList [(3,"b"), (5,"a")])+-- > deleteFindMax empty Error: can not return the maximal element of an empty map++deleteFindMax :: DMap k -> (DSum k, DMap k)+deleteFindMax t+ = case t of+ Bin _ k x l Tip -> (k :=> x,l)+ Bin _ k x l r -> let (km,r') = deleteFindMax r in (km,balance k x l r')+ Tip -> (error "Map.deleteFindMax: can not return the maximal element of an empty map", Tip)+++{--------------------------------------------------------------------+ [balance l x r] balances two trees with value x.+ The sizes of the trees should balance after decreasing the+ size of one of them. (a rotation).++ [delta] is the maximal relative difference between the sizes of+ two trees, it corresponds with the [w] in Adams' paper.+ [ratio] is the ratio between an outer and inner sibling of the+ heavier subtree in an unbalanced setting. It determines+ whether a double or single rotation should be performed+ to restore balance. It is correspondes with the inverse+ of $\alpha$ in Adam's article.++ Note that:+ - [delta] should be larger than 4.646 with a [ratio] of 2.+ - [delta] should be larger than 3.745 with a [ratio] of 1.534.+ + - A lower [delta] leads to a more 'perfectly' balanced tree.+ - A higher [delta] performs less rebalancing.++ - Balancing is automatic for random data and a balancing+ scheme is only necessary to avoid pathological worst cases.+ Almost any choice will do, and in practice, a rather large+ [delta] may perform better than smaller one.++ Note: in contrast to Adam's paper, we use a ratio of (at least) [2]+ to decide whether a single or double rotation is needed. Allthough+ he actually proves that this ratio is needed to maintain the+ invariants, his implementation uses an invalid ratio of [1].+--------------------------------------------------------------------}+delta,ratio :: Int+delta = 4+ratio = 2++balance :: k v -> v -> DMap k -> DMap k -> DMap k+balance k x l r+ | sizeL + sizeR <= 1 = Bin sizeX k x l r+ | sizeR >= delta*sizeL = rotateL k x l r+ | sizeL >= delta*sizeR = rotateR k x l r+ | otherwise = Bin sizeX k x l r+ where+ sizeL = size l+ sizeR = size r+ sizeX = sizeL + sizeR + 1++-- rotate+rotateL :: k v -> v -> DMap k -> DMap k -> DMap k+rotateL k x l r@(Bin _ _ _ ly ry)+ | size ly < ratio*size ry = singleL k x l r+ | otherwise = doubleL k x l r+rotateL _ _ _ Tip = error "rotateL Tip"++rotateR :: k v -> v -> DMap k -> DMap k -> DMap k+rotateR k x l@(Bin _ _ _ ly ry) r+ | size ry < ratio*size ly = singleR k x l r+ | otherwise = doubleR k x l r+rotateR _ _ Tip _ = error "rotateR Tip"++-- basic rotations+singleL, singleR :: k v -> v -> DMap k -> DMap k -> DMap k+singleL k1 x1 t1 (Bin _ k2 x2 t2 t3) = bin k2 x2 (bin k1 x1 t1 t2) t3+singleL _ _ _ Tip = error "singleL Tip"+singleR k1 x1 (Bin _ k2 x2 t1 t2) t3 = bin k2 x2 t1 (bin k1 x1 t2 t3)+singleR _ _ Tip _ = error "singleR Tip"++doubleL, doubleR :: k v -> v -> DMap k -> DMap k -> DMap k+doubleL k1 x1 t1 (Bin _ k2 x2 (Bin _ k3 x3 t2 t3) t4) = bin k3 x3 (bin k1 x1 t1 t2) (bin k2 x2 t3 t4)+doubleL _ _ _ _ = error "doubleL"+doubleR k1 x1 (Bin _ k2 x2 t1 (Bin _ k3 x3 t2 t3)) t4 = bin k3 x3 (bin k2 x2 t1 t2) (bin k1 x1 t3 t4)+doubleR _ _ _ _ = error "doubleR"++{--------------------------------------------------------------------+ The bin constructor maintains the size of the tree+--------------------------------------------------------------------}+bin :: k v -> v -> DMap k -> DMap k -> DMap k+bin k x l r+ = Bin (size l + size r + 1) k x l r++{--------------------------------------------------------------------+ Utility functions that return sub-ranges of the original+ tree. Some functions take a comparison function as argument to+ allow comparisons against infinite values. A function [cmplo k]+ should be read as [compare lo k].++ [trim cmplo cmphi t] A tree that is either empty or where [cmplo k == LT]+ and [cmphi k == GT] for the key [k] of the root.+ [filterGt cmp t] A tree where for all keys [k]. [cmp k == LT]+ [filterLt cmp t] A tree where for all keys [k]. [cmp k == GT]++ [split k t] Returns two trees [l] and [r] where all keys+ in [l] are <[k] and all keys in [r] are >[k].+ [splitLookup k t] Just like [split] but also returns whether [k]+ was found in the tree.+--------------------------------------------------------------------}++{--------------------------------------------------------------------+ [trim lo hi t] trims away all subtrees that surely contain no+ values between the range [lo] to [hi]. The returned tree is either+ empty or the key of the root is between @lo@ and @hi@.+--------------------------------------------------------------------}+trim :: (Key k -> Ordering) -> (Key k -> Ordering) -> DMap k -> DMap k+trim _ _ Tip = Tip+trim cmplo cmphi t@(Bin _ kx _ l r)+ = case cmplo (Key kx) of+ LT -> case cmphi (Key kx) of+ GT -> t+ _ -> trim cmplo cmphi l+ _ -> trim cmplo cmphi r+ +trimLookupLo :: GCompare k => Key k -> (Key k -> Ordering) -> DMap k -> (Maybe (DSum k), DMap k)+trimLookupLo _ _ Tip = (Nothing,Tip)+trimLookupLo lo cmphi t@(Bin _ kx x l r)+ = case compare lo (Key kx) of+ LT -> case cmphi (Key kx) of+ GT -> (lookupAssoc lo t, t)+ _ -> trimLookupLo lo cmphi l+ GT -> trimLookupLo lo cmphi r+ EQ -> (Just (kx :=> x),trim (compare lo) cmphi r)+++{--------------------------------------------------------------------+ [filterGt k t] filter all keys >[k] from tree [t]+ [filterLt k t] filter all keys <[k] from tree [t]+--------------------------------------------------------------------}+filterGt :: GCompare k => (Key k -> Ordering) -> DMap k -> DMap k+filterGt cmp = go+ where+ go Tip = Tip+ go (Bin _ kx x l r) = case cmp (Key kx) of+ LT -> join kx x (go l) r+ GT -> go r+ EQ -> r++filterLt :: GCompare k => (Key k -> Ordering) -> DMap k -> DMap k+filterLt cmp = go+ where+ go Tip = Tip+ go (Bin _ kx x l r) = case cmp (Key kx) of+ LT -> go l+ GT -> join kx x l (go r)+ EQ -> l