{-

Directory-tree-printing example: housecleaned, slow-yet-truly-lazy version
Tom Moertel <tom@moertel.com>
2007-03-22

See http://blog.moertel.com/articles/tag/directory_tree_series
(Look for Part 3)

Compile:  ghc -O2 -o tlist-slow-lazy-final --make tlist-slow-lazy-final.hs

Usage: ./tlist-slow-lazy-final [directory...]

NOTE:  If you run this program on a large directory hierarchy,
       prepare to wait.  It takes 0.1 second to process each
       file-system node it encounters.  (See fsVisit, below.)

-}

module Main (main) where

import Control.Monad 
import Data.List (isPrefixOf, sort)
import Data.Tree
import System.Directory
import System.Environment

import System.Posix.Unistd (usleep)

import LazyIO


-- Some convenient type synonyms

type Path       = String           -- path
type DentName   = String           -- directory-entry name
type DirNode    = (Path, DentName) -- directory-path/dentname pair
type DirTree    = Tree DentName    -- file-system tree


-- High-level program logic:  get args and print a tree for each

main :: IO ()
main = do
    args <- getArgs
    mapM_ traverseAndPrint (if null args then ["."] else args)

traverseAndPrint :: Path -> IO ()
traverseAndPrint path =
    putStr . showTree =<< fsTraverse root path
  where
    root = if "/" `isPrefixOf` path then "" else "."


-- Effectful tree-builder for file-system hierarchies

fsTraverse :: Path -> DentName -> IO DirTree
fsTraverse p n = runLazy (unfoldTreeM fsTraverseStep (p,n))

fsTraverseStep :: DirNode -> LazyIO (DentName, [DirNode])
fsTraverseStep dnode@(path, node) = do
    name     <- deferIO (fsVisit dnode)
    children <- deferIO (fsGetChildren (path ++ "/" ++ node))
    return (name, children)

fsVisit :: DirNode -> IO DentName
fsVisit (_, node) = do
    usleep 100000
    return node


-- Helper to get traversable directory entries

fsGetChildren :: Path -> IO [DirNode]
fsGetChildren path = do
    contents <- getDirectoryContents path `catch` const (return [])
    let visibles = sort . filter (`notElem` [".", ".."]) $ contents
    print visibles
    return (map ((,) path) visibles)


-- Purely functional tree-to-string formatting

showTree :: Tree String -> String
showTree t = unlines (showNode "" "" "" t)

showNode :: String -> String -> String -> Tree String -> [String]
showNode leader tie arm node =
    nodeRep : showChildren node (leader ++ extension)
  where
    nodeRep   = leader ++ arm ++ tie ++ rootLabel node
    extension = case arm of ""  -> ""; "`" -> "    "; _   -> "|   "

showChildren :: Tree String -> String -> [String]
showChildren node leader =
    let children = subForest node
        arms     = replicate (length children - 1) "|" ++ ["`"]
    in  concat (zipWith (showNode leader "-- ") arms children)