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 :: [String] -> [String]
indentInit [] = []
indentInit (String
s:[String]
ss) = (String
" ├╴" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
" │ " String -> String -> String
forall a. [a] -> [a] -> [a]
++) [String]
ss
indentLast :: [String] -> [String]
indentLast :: [String] -> [String]
indentLast [] = []
indentLast (String
s:[String]
ss) = (String
" └╴" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++) [String]
ss
indentChildren :: [[String]] -> [[String]]
indentChildren :: [[String]] -> [[String]]
indentChildren [] = []
indentChildren [[String]]
ns = ([String] -> [String]) -> [[String]] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map [String] -> [String]
indentInit ([[String]] -> [[String]]
forall a. [a] -> [a]
init [[String]]
ns) [[String]] -> [[String]] -> [[String]]
forall a. [a] -> [a] -> [a]
++ [[String] -> [String]
indentLast ([[String]] -> [String]
forall a. [a] -> a
last [[String]]
ns)]
appLast :: [String] -> String -> [String]
appLast :: [String] -> String -> [String]
appLast [String]
ss String
s = [String] -> [String]
forall a. [a] -> [a]
init [String]
ss [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [[String] -> String
forall a. [a] -> a
last [String]
ss String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s]
showTree' :: Tree String -> [String]
showTree' :: Tree String -> [String]
showTree' (Node String
n Forest String
ns) = String
n String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [[String]]
indentChildren ((Tree String -> [String]) -> Forest String -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map Tree String -> [String]
showTree' Forest String
ns))
showTree :: Tree String -> String
showTree :: Tree String -> String
showTree = [String] -> String
unlines ([String] -> String)
-> (Tree String -> [String]) -> Tree String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree String -> [String]
showTree'
drawTree :: Tree String -> IO ()
drawTree :: Tree String -> IO ()
drawTree = String -> IO ()
putStrLn (String -> IO ())
-> (Tree String -> String) -> Tree String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree String -> String
showTree
enumTree :: Tree a -> Tree (a,Int)
enumTree :: Tree a -> Tree (a, Int)
enumTree = (State Int (Tree (a, Int)) -> Int -> Tree (a, Int))
-> Int -> State Int (Tree (a, Int)) -> Tree (a, Int)
forall a b c. (a -> b -> c) -> b -> a -> c
flip State Int (Tree (a, Int)) -> Int -> Tree (a, Int)
forall s a. State s a -> s -> a
evalState Int
0 (State Int (Tree (a, Int)) -> Tree (a, Int))
-> (Tree a -> State Int (Tree (a, Int))) -> Tree a -> Tree (a, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> StateT Int Identity (a, Int))
-> Tree a -> State Int (Tree (a, Int))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> StateT Int Identity (a, Int)
forall a. a -> State Int (a, Int)
count
where
count :: a -> State Int (a,Int)
count :: a -> State Int (a, Int)
count a
a = do
Int
i <- StateT Int Identity Int
forall s (m :: * -> *). MonadState s m => m s
get; Int -> StateT Int Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
(a, Int) -> State Int (a, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,Int
i)
data Behavior
= Fixed
| InitiallyCollapsed
| InitiallyExpanded
data NodeInfo = NodeInfo
{ NodeInfo -> Behavior
nodeBehavior :: Behavior
, NodeInfo -> String
nodeName :: String
, NodeInfo -> String
nodeInfo :: String
}
escapeBrackets :: String -> String
escapeBrackets :: String -> String
escapeBrackets = (Char -> String) -> String -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
fixBrack
where
fixBrack :: Char -> String
fixBrack Char
'<' = String
"<"
fixBrack Char
'>' = String
">"
fixBrack Char
c = [Char
c]
htmlNode :: (NodeInfo, Int) -> String
htmlNode :: (NodeInfo, Int) -> String
htmlNode (NodeInfo
n,Int
i) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ String
"<span id=\"node"
, Int -> String
forall a. Show a => a -> String
show Int
i
, String
"\" class=\"node "
, String
mode
, String
"\""
, String
onclick
, String
"title=\""
, NodeInfo -> String
nodeInfo NodeInfo
n
, String
"\""
, String
">"
, String -> String
escapeBrackets (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ NodeInfo -> String
nodeName NodeInfo
n
, String
"</span>"
]
where
mode :: String
mode = case NodeInfo -> Behavior
nodeBehavior NodeInfo
n of
Behavior
Fixed -> String
"fixed"
Behavior
InitiallyCollapsed -> String
"interactive collapsed"
Behavior
InitiallyExpanded -> String
"interactive expanded"
onclick :: String
onclick = case NodeInfo -> Behavior
nodeBehavior NodeInfo
n of
Behavior
Fixed -> String
" "
Behavior
_ -> String
" onclick=\"toggle(event)\" "
showTreeHtml' :: Tree (NodeInfo, Int) -> [String]
showTreeHtml' :: Tree (NodeInfo, Int) -> [String]
showTreeHtml' (Node (NodeInfo
n,Int
i) []) = [(NodeInfo, Int) -> String
htmlNode (NodeInfo
n {nodeBehavior :: Behavior
nodeBehavior = Behavior
Fixed}, Int
i)]
showTreeHtml' (Node (NodeInfo, Int)
n [Tree (NodeInfo, Int)]
ns)
= [ (NodeInfo, Int) -> String
htmlNode (NodeInfo, Int)
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"<span id=\"children_node" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ((NodeInfo, Int) -> Int
forall a b. (a, b) -> b
snd (NodeInfo, Int)
n)
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" class=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
display String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">"
]
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String] -> String -> [String]
appLast ([[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [[String]]
indentChildren ((Tree (NodeInfo, Int) -> [String])
-> [Tree (NodeInfo, Int)] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map Tree (NodeInfo, Int) -> [String]
showTreeHtml' [Tree (NodeInfo, Int)]
ns))) String
"</span>"
where
display :: String
display = case NodeInfo -> Behavior
nodeBehavior (NodeInfo -> Behavior) -> NodeInfo -> Behavior
forall a b. (a -> b) -> a -> b
$ (NodeInfo, Int) -> NodeInfo
forall a b. (a, b) -> a
fst (NodeInfo, Int)
n of
Behavior
InitiallyCollapsed -> String -> String
forall a. Show a => a -> String
show String
"hidden"
Behavior
_ -> String -> String
forall a. Show a => a -> String
show String
"shown"
htmlTree
:: Maybe FilePath
-> Tree NodeInfo
-> String
htmlTree :: Maybe String -> Tree NodeInfo -> String
htmlTree Maybe String
css Tree NodeInfo
tree = [String] -> String
unlines
([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
templatePre1
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ String -> [String]
lines String
cssLink
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ String -> [String]
lines String
cssTempl
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ String -> [String]
lines String
templatePre2
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Tree (NodeInfo, Int) -> [String]
showTreeHtml' (Tree NodeInfo -> Tree (NodeInfo, Int)
forall a. Tree a -> Tree (a, Int)
enumTree Tree NodeInfo
tree)
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ String -> [String]
lines String
templatePost
where
cssTempl :: String
cssTempl = case Maybe String
css of
Maybe String
Nothing -> String
cssTemplate
Maybe String
_ -> String
""
cssLink :: String
cssLink = case Maybe String
css of
Just String
file
-> String
" <link rel=\"stylesheet\" href=\""
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
file
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" type=\"text/css\" />"
Maybe String
_ -> String
""
writeHtmlTree
:: Maybe FilePath
-> FilePath
-> Tree NodeInfo
-> IO ()
writeHtmlTree :: Maybe String -> String -> Tree NodeInfo -> IO ()
writeHtmlTree Maybe String
css String
file Tree NodeInfo
tree = do
Handle
h <- String -> IOMode -> IO Handle
openFile String
file IOMode
WriteMode
Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
utf8
Handle -> String -> IO ()
hPutStr Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe String -> Tree NodeInfo -> String
htmlTree Maybe String
css (Tree NodeInfo -> String) -> Tree NodeInfo -> String
forall a b. (a -> b) -> a -> b
$ Tree NodeInfo
tree
Handle -> IO ()
hClose Handle
h
templatePre1 :: String
templatePre1 =
String
"<!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 :: String
cssTemplate =
String
" <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 :: String
templatePre2 =
String
" <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 :: String
templatePost =
String
"</pre>\n\
\</body>\n\
\\n\
\</html>\n"