In [ ]:

    

{-# LANGUAGE OverloadedStrings #-}
import qualified Data.Map as M
import IHaskell.Display
import Data.Text(Text)
import Text.Printf
data Tree itemType = ConstTree (M.Map itemType (Tree itemType)) deriving(Show)
leaf = ConstTree M.empty
constTree = ConstTree . M.fromList
unConstTree (ConstTree tree)= tree
treeSize (ConstTree tree) = M.fold (\y x -> x + treeSize y) 1 tree
leafNumbers (ConstTree tree) | M.null tree = 1
                             | otherwise   = M.fold (+) 0 $ M.map leafNumbers tree
numOfFirstChildren = M.size . unConstTree
isEmpty = M.null . unConstTree
listChildren = M.toList . unConstTree
exampleTree:: Tree Text
exampleTree = constTree [("Father", constTree [("Me", constTree [("Daughter", leaf),("Son", leaf)]),("Sibling", leaf)])]


    

In [ ]:

    

{-# LANGUAGE OverloadedStrings #-}

import Text.Blaze.Svg11 ((!))
import Data.Text(Text)
import Control.Monad(forM_)
import qualified Text.Blaze.Svg11 as S
import qualified Text.Blaze.Svg11.Attributes as A
import Text.Blaze.Svg.Renderer.String (renderSvg)

nodesize = 10
nodecolor = "#000000"
padding = 2

svgDoc :: Tree Text-> S.Svg
svgDoc origTree = S.docTypeSvg ! A.version "1.1" ! A.width "300" ! A.height "1000" $ renderforest origTree 0 0


-- html $ renderSvg svgDoc
node :: Text -> Int -> Int -> S.Markup
node name x y =  S.rect ! A.height (S.toValue nodesize)
                        ! A.width "100"
                             ! A.strokeWidth "1" 
                             ! A.stroke nodecolor
                             ! A.x (S.toValue $ x * (padding + 100))
                             ! A.y (S.toValue $ y * (padding + nodesize))

rendertree :: Text -> Tree Text -> Int -> Int -> S.Markup

rendertree name tree x y = do 
    node name x y
    renderforest tree (x + 1) y

renderforest tree x y = 
    forM_ (zip (formerChildrenSums tree) $ listChildren tree) $ \(offset, (value, child)) ->
        rendertree value child x (offset + y)
        
formerChildrenSums tree = [sum $ map (leafNumbers.snd) $ take n (listChildren tree)| n <-[0..]]


    

In [ ]:

    

{-# LANGUAGE FlexibleInstances #-}
instance IHaskellDisplay (Tree Text) where
   display raw_tree = return $ Display [html $ renderSvg $ svgDoc raw_tree]