diff --git a/src/Data/Tree/View.hs b/src/Data/Tree/View.hs
--- a/src/Data/Tree/View.hs
+++ b/src/Data/Tree/View.hs
@@ -1,6 +1,7 @@
module Data.Tree.View
( showTree
, drawTree
+ , Behavior (..)
, NodeInfo (..)
, htmlTree
, writeHtmlTree
@@ -12,6 +13,7 @@
import Data.Traversable (traverse)
import Data.Tree (Tree (..))
import qualified Data.Tree as Tree
+import System.IO
@@ -60,58 +62,136 @@
i <- get; put (i+1)
return (a,i)
+data Behavior
+ = Fixed -- ^ Non-collapsible
+ | InitiallyCollapsed
+ | InitiallyExpanded
+
-- | A tree node
data NodeInfo = NodeInfo
- { 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.
+ { 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)
- = ""
- ++ nodeName n
- ++ ""
+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 []) = [htmlNode n]
+showTreeHtml' (Node (n,i) []) = [htmlNode (n {nodeBehavior = Fixed}, i)]
showTreeHtml' (Node n ns)
- = [htmlNode n ++ ""]
+ = [ 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 :: Tree NodeInfo -> String
-htmlTree tree = unlines $ lines template1 ++ showTreeHtml' (enumTree tree) ++ lines template2
+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 :: FilePath -> Tree NodeInfo -> IO ()
-writeHtmlTree file = writeFile file . htmlTree
+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
-template1 =
+templatePre1 =
"\n\
\\n\
\\n\
\\n\
\ \n\
- \ Tree view\n\
- \ \n"
+
+templatePre2 =
+ " \n\
\ \n\
@@ -134,7 +214,7 @@
\\n\
\
\n"
-template2 =
+templatePost =
"
\n\
\\n\
\\n\
diff --git a/tree-view.cabal b/tree-view.cabal
--- a/tree-view.cabal
+++ b/tree-view.cabal
@@ -1,5 +1,5 @@
name: tree-view
-version: 0.4
+version: 0.5
synopsis: Render trees as foldable HTML and Unicode art
description: Render trees as foldable HTML and Unicode art
.