Data/Map/Internal/Debug.hs

    {-# LANGUAGE CPP #-}
    #include "containers.h"

    module Data.Map.Internal.Debug where

    import Data.Map.Internal (Map (..), size, delta)
    import Control.Monad (guard)

    -- | /O(n)/. Show the tree that implements the map. The tree is shown
    -- in a compressed, hanging format. See 'showTreeWith'.
    showTree :: (Show k,Show a) => Map k a -> String
    showTree m
      = showTreeWith showElem True False m
      where
        showElem k x  = show k ++ ":=" ++ show 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.

    >  Map> let t = fromDistinctAscList [(x,()) | x <- [1..5]]
    >  Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True False t
    >  (4,())
    >  +--(2,())
    >  |  +--(1,())
    >  |  +--(3,())
    >  +--(5,())
    >
    >  Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True True t
    >  (4,())
    >  |
    >  +--(2,())
    >  |  |
    >  |  +--(1,())
    >  |  |
    >  |  +--(3,())
    >  |
    >  +--(5,())
    >
    >  Map> putStrLn $ showTreeWith (\k x -> show (k,x)) False True t
    >  +--(5,())
    >  |
    >  (4,())
    >  |
    >  |  +--(3,())
    >  |  |
    >  +--(2,())
    >     |
    >     +--(1,())

    -}
    showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String
    showTreeWith showelem hang wide t
      | hang      = (showsTreeHang showelem wide [] t) ""
      | otherwise = (showsTree showelem wide [] [] t) ""

    showsTree :: (k -> a -> String) -> Bool -> [String] -> [String] -> Map k a -> 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 :: (k -> a -> String) -> Bool -> [String] -> Map k a -> 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

    {--------------------------------------------------------------------
      Assertions
    --------------------------------------------------------------------}
    -- | /O(n)/. Test if the internal map structure is valid.
    --
    -- > valid (fromAscList [(3,"b"), (5,"a")]) == True
    -- > valid (fromAscList [(5,"a"), (3,"b")]) == False

    valid :: Ord k => Map k a -> Bool
    valid t
      = balanced t && ordered t && validsize t

    -- | Test if the keys are ordered correctly.
    ordered :: Ord a => Map a b -> Bool
    ordered t
      = bounded (const True) (const True) t
      where
        bounded lo hi t'
          = case t' of
              Tip              -> True
              Bin _ kx _ l r  -> (lo kx) && (hi kx) && bounded lo (<kx) l && bounded (>kx) hi r

    -- | Test if a map obeys the balance invariants.
    balanced :: Map k a -> 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

    -- | Test if each node of a map reports its size correctly.
    validsize :: Map a b -> Bool
    validsize t = case slowSize t of
          Nothing -> False
          Just _ -> True
      where
        slowSize Tip = Just 0
        slowSize (Bin sz _ _ l r) = do
                ls <- slowSize l
                rs <- slowSize r
                guard (sz == ls + rs + 1)
                return sz