Convert to cabal.project
[packages/containers.git] / containers / src / Data / Map / Internal / Debug.hs
1 {-# LANGUAGE CPP #-}
2 #include "containers.h"
3
4 module Data.Map.Internal.Debug where
5
6 import Data.Map.Internal (Map (..), size, delta)
7 import 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'.
11 showTree :: (Show k,Show a) => Map k a -> String
12 showTree 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 -}
54 showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String
55 showTreeWith showelem hang wide t
56 | hang = (showsTreeHang showelem wide [] t) ""
57 | otherwise = (showsTree showelem wide [] [] t) ""
58
59 showsTree :: (k -> a -> String) -> Bool -> [String] -> [String] -> Map k a -> ShowS
60 showsTree 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
72 showsTreeHang :: (k -> a -> String) -> Bool -> [String] -> Map k a -> ShowS
73 showsTreeHang 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
85 showWide :: Bool -> [String] -> String -> String
86 showWide wide bars
87 | wide = showString (concat (reverse bars)) . showString "|\n"
88 | otherwise = id
89
90 showsBars :: [String] -> ShowS
91 showsBars bars
92 = case bars of
93 [] -> id
94 _ -> showString (concat (reverse (tail bars))) . showString node
95
96 node :: String
97 node = "+--"
98
99 withBar, withEmpty :: [String] -> [String]
100 withBar bars = "| ":bars
101 withEmpty 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
111 valid :: Ord k => Map k a -> Bool
112 valid t
113 = balanced t && ordered t && validsize t
114
115 -- | Test if the keys are ordered correctly.
116 ordered :: Ord a => Map a b -> Bool
117 ordered 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.
126 balanced :: Map k a -> Bool
127 balanced 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.
134 validsize :: Map a b -> Bool
135 validsize 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