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))

-- | Show a 'Tree' using Unicode art
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'

-- | 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 :: 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  -- ^ Non-collapsible
    | InitiallyCollapsed
    | InitiallyExpanded

-- | A tree node
data NodeInfo = NodeInfo
    { NodeInfo -> Behavior
nodeBehavior :: Behavior
    , NodeInfo -> String
nodeName     :: String  -- ^ Node name (to be displayed in the HTML tree view)
    , NodeInfo -> String
nodeInfo     :: String  -- ^ Additional information (to be displayed when hovering the mouse over
                              --   the node). This field may contain line breaks.
    }

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
"&lt;"
    fixBrack Char
'>' = String
"&gt;"
    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"

-- | Convert a 'Tree' to HTML with foldable nodes
htmlTree
    :: Maybe FilePath  -- ^ Path/URL to external CSS file
    -> Tree NodeInfo   -- ^ Tree to render
    -> 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
""

-- | 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 :: 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"