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))
-- | Show a 'Tree' using Unicode art
showTree :: Tree String -> String
showTree = unlines . showTree'
-- | Draw a 'Tree' on the terminal using Unicode art
--
-- Example:
--
-- > *Data.Tree.View> drawTree $ Node "Add" [Node "Sub" [Node "3" [], Node "Mul" [Node "1" [], Node "2" []]], Node "4" []]
-- > Add
-- > ├╴Sub
-- > │ ├╴3
-- > │ └╴Mul
-- > │ ├╴1
-- > │ └╴2
-- > └╴4
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 -- ^ Non-collapsible
| InitiallyCollapsed
| InitiallyExpanded
-- | A tree node
data NodeInfo = NodeInfo
{ nodeBehavior :: Behavior
, nodeName :: String -- ^ Node name (to be displayed in the HTML tree view)
, nodeInfo :: String -- ^ Additional information (to be displayed when hovering the mouse over
-- the node). This field may contain line breaks.
}
escapeBrackets :: String -> String
escapeBrackets = concatMap fixBrack
where
fixBrack '<' = "<"
fixBrack '>' = ">"
fixBrack c = [c]
htmlNode :: (NodeInfo, Int) -> String
htmlNode (n,i) = concat
[ ""
, escapeBrackets $ nodeName n
, ""
]
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 ++ ""
]
++ appLast (concat (indentChildren (map showTreeHtml' ns))) ""
where
display = case nodeBehavior $ fst n of
InitiallyCollapsed -> show "hidden"
_ -> show "shown"
-- | Convert a 'Tree' to HTML with foldable nodes
htmlTree
:: Maybe FilePath -- ^ Path/URL to external CSS file
-> Tree NodeInfo -- ^ Tree to render
-> 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
-> " "
_ -> ""
-- | Convert a 'Tree' to an HTML file with foldable nodes
writeHtmlTree
:: Maybe FilePath -- ^ Path/URL to external CSS file
-> FilePath -- ^ Output file
-> Tree NodeInfo -- ^ Tree to render
-> IO ()
writeHtmlTree css file tree = do
h <- openFile file WriteMode
hSetEncoding h utf8
hPutStr h $ htmlTree css $ tree
hClose h
templatePre1 =
"\n\
\\n\
\\n\
\\n\
\ \n\
\ Tree view\n"
cssTemplate =
" \n"
templatePre2 =
" \n\
\ \n\
\\n\
\\n\
\\n\
\\n"
templatePost =
"
\n\
\\n\
\\n\
\\n"