module Data.Tree.View
( showTree
, drawTree
, Behavior (..)
, NodeInfo (..)
, htmlTree
, writeHtmlTree
) where
import Control.Monad.State
import Data.Traversable (traverse)
import Data.Tree (Tree (..))
import qualified Data.Tree as Tree
import System.IO
indentInit :: [String] -> [String]
indentInit [] = []
indentInit (s:ss) = (" ├╴" ++ s) : map (" │ " ++) ss
indentLast :: [String] -> [String]
indentLast [] = []
indentLast (s:ss) = (" └╴" ++ s) : map (" " ++) ss
indentChildren :: [[String]] -> [[String]]
indentChildren [] = []
indentChildren ns = map indentInit (init ns) ++ [indentLast (last ns)]
appLast :: [String] -> String -> [String]
appLast ss s = init ss ++ [last ss ++ s]
showTree' :: Tree String -> [String]
showTree' (Node n ns) = n : concat (indentChildren (map showTree' ns))
showTree :: Tree String -> String
showTree = unlines . showTree'
drawTree :: Tree String -> IO ()
drawTree = putStrLn . showTree
enumTree :: Tree a -> Tree (a,Int)
enumTree = flip evalState 0 . traverse count
where
count :: a -> State Int (a,Int)
count a = do
i <- get; put (i+1)
return (a,i)
data Behavior
= Fixed
| InitiallyCollapsed
| InitiallyExpanded
data NodeInfo = NodeInfo
{ nodeBehavior :: Behavior
, nodeName :: String
, nodeInfo :: String
}
escapeBrackets :: String -> String
escapeBrackets = concatMap fixBrack
where
fixBrack '<' = "<"
fixBrack '>' = ">"
fixBrack c = [c]
htmlNode :: (NodeInfo, Int) -> String
htmlNode (n,i) = concat
[ "<span id=\"node"
, show i
, "\" class=\"node "
, mode
, "\""
, onclick
, "title=\""
, nodeInfo n
, "\""
, ">"
, escapeBrackets $ nodeName n
, "</span>"
]
where
mode = case nodeBehavior n of
Fixed -> "fixed"
InitiallyCollapsed -> "interactive collapsed"
InitiallyExpanded -> "interactive expanded"
onclick = case nodeBehavior n of
Fixed -> " "
_ -> " onclick=\"toggle(event)\" "
showTreeHtml' :: Tree (NodeInfo, Int) -> [String]
showTreeHtml' (Node (n,i) []) = [htmlNode (n {nodeBehavior = Fixed}, i)]
showTreeHtml' (Node n ns)
= [ htmlNode n ++ "<span id=\"children_node" ++ show (snd n)
++ "\" class=" ++ display ++ ">"
]
++ appLast (concat (indentChildren (map showTreeHtml' ns))) "</span>"
where
display = case nodeBehavior $ fst n of
InitiallyCollapsed -> show "hidden"
_ -> show "shown"
htmlTree
:: Maybe FilePath
-> Tree NodeInfo
-> String
htmlTree css tree = unlines
$ lines templatePre1
++ lines cssLink
++ lines cssTempl
++ lines templatePre2
++ showTreeHtml' (enumTree tree)
++ lines templatePost
where
cssTempl = case css of
Nothing -> cssTemplate
_ -> ""
cssLink = case css of
Just file
-> " <link rel=\"stylesheet\" href=\""
++ file
++ "\" type=\"text/css\" />"
_ -> ""
writeHtmlTree
:: Maybe FilePath
-> FilePath
-> Tree NodeInfo
-> IO ()
writeHtmlTree css file tree = do
h <- openFile file WriteMode
hSetEncoding h utf8
hPutStr h $ htmlTree css $ tree
hClose h
templatePre1 =
"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n\
\<html xmlns=\"http://www.w3.org/1999/xhtml\">\n\
\\n\
\<head>\n\
\ <meta http-equiv=\"Content-Type\" content=\"text/html; charset=utf-8\"/>\n\
\ <title>Tree view</title>\n"
cssTemplate =
" <style type=\"text/css\">\n\
\ .node {\n\
\ }\n\
\ .interactive:hover {\n\
\ background-color: #CCC;\n\
\ }\n\
\ .collapsed {\n\
\ cursor: pointer;\n\
\ color: grey;\n\
\ font-weight: bold;\n\
\ }\n\
\ .expanded {\n\
\ cursor: pointer;\n\
\ color: #009;\n\
\ font-weight: bold;\n\
\ }\n\
\ .fixed {\n\
\ color: black;\n\
\ }\n\
\ </style>\n"
templatePre2 =
" <style type=\"text/css\">\n\
\ .shown {\n\
\ display: inline;\n\
\ }\n\
\ .hidden {\n\
\ display: none;\n\
\ }\n\
\ </style>\n\
\ <script type=\"text/javascript\">\n\
\ function toggle(e) {\n\
\ var node = e.srcElement == undefined ? e.target : e.srcElement;\n\
\ var id = node.getAttribute(\"id\");\n\
\ var children = document.getElementById(\"children_\" + id),\n\
\ cstyle = window.getComputedStyle(children),\n\
\ cdispay = cstyle.getPropertyValue(\"display\");\n\
\ if (cdispay == \"inline\") {\n\
\ document.getElementById(\"children_\" + id).className = \"hidden\";\n\
\ document.getElementById(id).className = \"node interactive collapsed\";\n\
\ } else {\n\
\ document.getElementById(\"children_\" + id).className = \"shown\";\n\
\ document.getElementById(id).className = \"node interactive expanded\";\n\
\ }\n\
\ }\n\
\ </script>\n\
\</head>\n\
\\n\
\<body>\n\
\<pre>\n"
templatePost =
"</pre>\n\
\</body>\n\
\\n\
\</html>\n"