content: {-# LANGUAGE FlexibleContexts #-}
  {-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-}
  module Map.Internal.Debug where
  
  import Key
  import 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 Key, Show a) => Map 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 :: (Key -> a -> String) -> Bool -> Bool -> Map a -> String
  showTreeWith showelem hang wide t
    | hang      = (showsTreeHang showelem wide [] t) ""
    | otherwise = (showsTree showelem wide [] [] t) ""
  
  showsTree :: (Key -> a -> String) -> Bool -> [String] -> [String] -> Map 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 :: (Key -> a -> String) -> Bool -> [String] -> Map 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 :: Map a -> Bool
  valid t = balanced t && ordered t && validsize t
  
  -- | Test if the keys are ordered correctly.
  ordered :: Map 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 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 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
  