{-# LANGUAGE ViewPatterns #-}
module Summoner.Tree
( TreeFs (..)
, traverseTree
, pathToTree
, insertTree
, showBoldTree
, showTree
) where
import System.Directory (createDirectoryIfMissing, withCurrentDirectory)
import System.FilePath (splitDirectories)
import Summoner.Ansi (boldCode, resetCode)
data TreeFs
= Dir FilePath [TreeFs]
| File FilePath Text
deriving stock (Generic, Show, Eq, Ord)
traverseTree :: TreeFs -> IO ()
traverseTree (File name content) = writeFileText name content
traverseTree (Dir name children) = do
createDirectoryIfMissing False name
withCurrentDirectory name $ for_ children traverseTree
pathToTree :: FilePath -> Text -> TreeFs
pathToTree path content =
let pathParts = splitDirectories path
in case pathParts of
[] -> Dir path []
x:xs -> go x xs
where
go :: FilePath -> [FilePath] -> TreeFs
go p [] = File p content
go p (x:xs) = Dir p [go x xs]
insertTree :: TreeFs -> [TreeFs] -> [TreeFs]
insertTree node [] = [node]
insertTree node (x:xs) = case (node, x) of
(Dir _ _, File _ _) -> x : insertTree node xs
(File _ _, Dir _ _) -> x : insertTree node xs
(File nodePath _, File curPath _)
| nodePath == curPath -> node : xs
| otherwise -> x : insertTree node xs
(Dir nodePath nodeChildren, Dir curPath curChildren)
| nodePath == curPath ->
Dir nodePath (foldr insertTree curChildren nodeChildren) : xs
| otherwise -> x : insertTree node xs
showBoldTree :: TreeFs -> Text
showBoldTree = showTree True
showTree
:: Bool
-> TreeFs
-> Text
showTree isBold = unlines . showOne " " "" ""
where
showOne :: Text -> Text -> Text -> TreeFs -> [Text]
showOne leader tie arm (File fp _) = [leader <> arm <> tie <> toText fp]
showOne leader tie arm (Dir fp (sortWith treeFp -> trees)) =
nodeRep : showChildren trees (leader <> extension)
where
nodeRep :: Text
nodeRep = leader <> arm <> tie <> boldDir (fp <> "/")
where
boldDir :: FilePath -> Text
boldDir str = toText $
if isBold
then boldCode <> str <> resetCode
else str
extension :: Text
extension = case arm of "" -> ""; "└" -> " "; _ -> "│ "
showChildren :: [TreeFs] -> Text -> [Text]
showChildren children leader =
let arms = replicate (length children - 1) "├" <> ["└"]
in concat (zipWith (showOne leader "── ") arms children)
treeFp :: TreeFs -> FilePath
treeFp (Dir fp _) = fp
treeFp (File fp _) = fp