plot binary tree like a boss

tree.hs

import Data.Maybe (fromMaybe)
import Data.List (intercalate)

data Tree a = Tree {left :: Tree a, right :: Tree a, val :: a}
            | Nil deriving (Eq)

instance (Eq a, Show a) => Show (Tree a) where
        show = toString

genPosTree :: (Show a, Eq a) => Tree a -> Int -> Tree (a, Int, Int, Maybe Int, Maybe Int)
genPosTree Nil _ = Nil
genPosTree (Tree lt rt v) w =
        let (lt', lp, w') = if lt == Nil
                                then (Nil, Nothing, w)
                                else let lt' = genPosTree lt w
                                         (__, lp, w', _, _) = val lt'
                                     in  (lt', Just lp, w')
            (rt', rp, w'') = if rt == Nil
                                 then (Nil, Nothing, w'+1)
                                 else let rt' = genPosTree rt (w'+2)
                                          (__, rp, w'', _, _) = val rt'
                                      in  (rt', Just rp, w'')
            tp = ((fromMaybe w lp + fromMaybe (w'+1) rp) `div` 2)
            w''' = max w'' (tp + (length . show) v)
        in  Tree lt' rt' (v, tp, w''', lp, rp)

valToStr :: Show a => Int -> [Tree (a, Int, Int, Maybe Int, Maybe Int)] -> String
valToStr l (Tree _ _ (v, p, _,  _, _):xs) =
    let more = replicate (p - l) ' ' ++ show v
    in  more ++ valToStr (l + length more) xs
valToStr _ [] = ""

posToDiag :: Show a => Int -> [Tree (a, Int, Int, Maybe Int, Maybe Int)] -> String
posToDiag l (Tree lt rt (v, tp0, _, lp, rp):xs) =
    let -- modify position to show in middle
        tp = tp0 + ((`div`2) . length . show $ v)
        -- left
        more = case lp of Nothing -> ""
                          Just p -> let (Tree _ _ (v, _, _, _, _)) = lt
                                        lp' = p + ((`div`2) . length . show $ v)
                                    in  replicate (lp' - l) ' ' ++ "." ++
                                        replicate (tp - (lp'+1)) '-' ++ "^"
        l' = l + length more
        -- right
        more' = case rp of Nothing -> ""
                           Just p -> let (Tree _ _ (v, _, _, _, _)) = rt
                                         rp' = p + ((`div`2) . length . show $ v)
                                     in  (if l' == tp+1
                                             then ""
                                             else replicate (tp - l') ' ' ++ "^")
                                         ++ replicate (rp' - (tp+1)) '-' ++ "."
    in  more ++ more' ++ posToDiag (l' + length more') xs
posToDiag _ [] = ""

bfsToStr :: (Eq a, Show a) => [Tree (a, Int, Int, Maybe Int, Maybe Int)] -> [String]
bfsToStr [] = []
bfsToStr l = let childs = filter (Nil /=) . concatMap (\t -> [left t, right t]) $ l
             in  valToStr 0 l : posToDiag 0 l : bfsToStr childs

toString :: (Eq a, Show a) => Tree a -> String
toString t = intercalate "\n" . filter (not . null) . bfsToStr $ [t']
    where t' = genPosTree t 0

main :: IO ()
main = do
        let t = Tree (Tree (Tree Nil Nil 444444444) 
                            (Tree (Tree Nil Nil 9) Nil 7)
                            2)
                      (Tree Nil (Tree Nil Nil 7777777) 3)
                      1
        print $ genPosTree t 0
        print t

{- outputs:
        1
   .----^----.
   2         3
.--^---.     ^.
4      7      7
      .^
      9
     .^
    10
-}