1{-# LANGUAGE CPP #-} 2#include "containers.h" 3 4module Data.Map.Internal.Debug where 5 6import Data.Map.Internal (Map (..), size, delta) 7import Control.Monad (guard) 8 9-- | /O(n)/. Show the tree that implements the map. The tree is shown 10-- in a compressed, hanging format. See 'showTreeWith'. 11showTree :: (Show k,Show a) => Map k a -> String 12showTree m 13 = showTreeWith showElem True False m 14 where 15 showElem k x = show k ++ ":=" ++ show x 16 17 18{- | /O(n)/. The expression (@'showTreeWith' showelem hang wide map@) shows 19 the tree that implements the map. Elements are shown using the @showElem@ function. If @hang@ is 20 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If 21 @wide@ is 'True', an extra wide version is shown. 22 23> Map> let t = fromDistinctAscList [(x,()) | x <- [1..5]] 24> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True False t 25> (4,()) 26> +--(2,()) 27> | +--(1,()) 28> | +--(3,()) 29> +--(5,()) 30> 31> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True True t 32> (4,()) 33> | 34> +--(2,()) 35> | | 36> | +--(1,()) 37> | | 38> | +--(3,()) 39> | 40> +--(5,()) 41> 42> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) False True t 43> +--(5,()) 44> | 45> (4,()) 46> | 47> | +--(3,()) 48> | | 49> +--(2,()) 50> | 51> +--(1,()) 52 53-} 54showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String 55showTreeWith showelem hang wide t 56 | hang = (showsTreeHang showelem wide [] t) "" 57 | otherwise = (showsTree showelem wide [] [] t) "" 58 59showsTree :: (k -> a -> String) -> Bool -> [String] -> [String] -> Map k a -> ShowS 60showsTree showelem wide lbars rbars t 61 = case t of 62 Tip -> showsBars lbars . showString "|\n" 63 Bin _ kx x Tip Tip 64 -> showsBars lbars . showString (showelem kx x) . showString "\n" 65 Bin _ kx x l r 66 -> showsTree showelem wide (withBar rbars) (withEmpty rbars) r . 67 showWide wide rbars . 68 showsBars lbars . showString (showelem kx x) . showString "\n" . 69 showWide wide lbars . 70 showsTree showelem wide (withEmpty lbars) (withBar lbars) l 71 72showsTreeHang :: (k -> a -> String) -> Bool -> [String] -> Map k a -> ShowS 73showsTreeHang showelem wide bars t 74 = case t of 75 Tip -> showsBars bars . showString "|\n" 76 Bin _ kx x Tip Tip 77 -> showsBars bars . showString (showelem kx x) . showString "\n" 78 Bin _ kx x l r 79 -> showsBars bars . showString (showelem kx x) . showString "\n" . 80 showWide wide bars . 81 showsTreeHang showelem wide (withBar bars) l . 82 showWide wide bars . 83 showsTreeHang showelem wide (withEmpty bars) r 84 85showWide :: Bool -> [String] -> String -> String 86showWide wide bars 87 | wide = showString (concat (reverse bars)) . showString "|\n" 88 | otherwise = id 89 90showsBars :: [String] -> ShowS 91showsBars bars 92 = case bars of 93 [] -> id 94 _ -> showString (concat (reverse (tail bars))) . showString node 95 96node :: String 97node = "+--" 98 99withBar, withEmpty :: [String] -> [String] 100withBar bars = "| ":bars 101withEmpty bars = " ":bars 102 103{-------------------------------------------------------------------- 104 Assertions 105--------------------------------------------------------------------} 106-- | /O(n)/. Test if the internal map structure is valid. 107-- 108-- > valid (fromAscList [(3,"b"), (5,"a")]) == True 109-- > valid (fromAscList [(5,"a"), (3,"b")]) == False 110 111valid :: Ord k => Map k a -> Bool 112valid t 113 = balanced t && ordered t && validsize t 114 115-- | Test if the keys are ordered correctly. 116ordered :: Ord a => Map a b -> Bool 117ordered t 118 = bounded (const True) (const True) t 119 where 120 bounded lo hi t' 121 = case t' of 122 Tip -> True 123 Bin _ kx _ l r -> (lo kx) && (hi kx) && bounded lo (<kx) l && bounded (>kx) hi r 124 125-- | Test if a map obeys the balance invariants. 126balanced :: Map k a -> Bool 127balanced t 128 = case t of 129 Tip -> True 130 Bin _ _ _ l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) && 131 balanced l && balanced r 132 133-- | Test if each node of a map reports its size correctly. 134validsize :: Map a b -> Bool 135validsize t = case slowSize t of 136 Nothing -> False 137 Just _ -> True 138 where 139 slowSize Tip = Just 0 140 slowSize (Bin sz _ _ l r) = do 141 ls <- slowSize l 142 rs <- slowSize r 143 guard (sz == ls + rs + 1) 144 return sz 145