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