Обход дерева каталогов в ширину не ленив

Question

Я пытаюсь пройти по дереву каталогов. Наивный обход в глубину, кажется, не производит данные ленивым способом и исчерпывает память. Затем я попробовал подход в ширину, который показывает ту же проблему - он использует всю доступную память, а затем вылетает.

код у меня есть:

getFilePathBreadtFirst :: FilePath -> IO [FilePath]
getFilePathBreadtFirst fp = do
  fileinfo <- getInfo fp 
  res :: [FilePath]  <- if isReadableDirectory fileinfo
          then do
                children  <- getChildren fp 
                lower    <-  mapM getFilePathBreadtFirst children  
                return (children ++  concat lower)
           else return [fp]        -- should only return the files? 
  return res 

getChildren :: FilePath -> IO [FilePath]
getChildren path = do 
          names <- getUsefulContents path
          let namesfull = map (path </>) names
          return namesfull

testBF fn = do  -- crashes for /home/frank, does not go to swap 
  fps <- getFilePathBreadtFirst fn
  putStrLn $ unlines fps

Я думаю, что весь код является линейным или хвостовым рекурсивным, и я ожидаю, что список имен файлов начинается сразу, но на самом деле это не так. Где ошибка в моем коде и моем мышлении? Где я потерял ленивые оценки?

Answer 1

Я буду использовать три отдельных трюка, чтобы решить ваш вопрос.

• Трюк 1: Используйте pipes библиотека для потоковой передачи имен файлов одновременно с обходом дерева.
• Трюк 2: Используйте StateT (Seq FilePath) трансформатор для достижения первого обхода в ширину.
• Трюк 3: Используйте MaybeT трансформатор, чтобы избежать ручной рекурсии при записи цикла и выхода.

Следующий код объединяет эти три уловки в одном стеке монадных преобразователей.

import Control.Monad
import Control.Monad.Trans
import Control.Monad.Trans.Maybe
import Control.Monad.State.Lazy
import Control.Pipe
import Data.Sequence
import System.FilePath.Posix
import System.Directory

loop :: (Monad m) => MaybeT m a -> m ()
loop = liftM (maybe () id) . runMaybeT . forever

quit :: (Monad m) => MaybeT m a
quit = mzero

getUsefulContents :: FilePath -> IO [FilePath]
getUsefulContents path
  = fmap (filter (`notElem` [".", ".."])) $ getDirectoryContents path

permissible :: FilePath -> IO Bool
permissible file
  = fmap (\p -> readable p && searchable p) $ getPermissions file

traverseTree :: FilePath -> Producer FilePath IO ()
traverseTree path = (`evalStateT` empty) $ loop $ do
    -- All code past this point uses the following monad transformer stack:
    -- MaybeT (StateT (Seq FilePath) (Producer FilePath IO)) ()
    let liftState = lift
        liftPipe  = lift . lift
        liftIO    = lift . lift . lift
    liftState $ modify (|> path)
    forever $ do
        x <- liftState $ gets viewl
        case x of
            EmptyL    -> quit
            file :< s -> do
                liftState $ put s
                liftPipe $ yield file
                p <- liftIO $ doesDirectoryExist file
                when p $ do
                    names <- liftIO $ getUsefulContents file
                    -- allowedNames <- filterM permissible names
                    let namesfull = map (path </>) names
                    liftState $ forM_ namesfull $ \name -> modify (|> name)

Это создает генератор имен файлов в ширину, которые можно использовать одновременно с обходом дерева. Вы потребляете значения, используя:

printer :: (Show a) => Consumer a IO r
printer = forever $ do
    a <- await
    lift $ print a

>>> runPipe $ printer <+< traverseTree path
<Prints file names as it traverses the tree>

Вы даже можете выбрать не требовать все значения:

-- Demand only 'n' elements
take' :: (Monad m) => Int -> Pipe a a m ()
take' n = replicateM_ n $ do
    a <- await
    yield a

>> runPipe $ printer <+< take' 3 <+< traverseTree path
<Prints only three files>

Что еще более важно, этот последний пример будет проходить по дереву столько, сколько необходимо для генерации трех файлов, а затем остановится. Это позволяет избежать расточительного обхода всего дерева, когда все, что вам нужно - это 3 результата!

Чтобы узнать больше о pipes библиотека трюк, обратитесь к учебнику по трубам на Control.Pipes.Tutorial,

Чтобы узнать больше о хитрости цикла, прочитайте этот пост в блоге.

Я не смог найти хорошую ссылку для трюка в очереди для первого обхода, но я знаю, что он где-то там. Если кто-то знает хорошую ссылку для этого, просто отредактируйте мой ответ, чтобы добавить его.

Answer 2

Я разделил управление трубой и обход дерева. вот сначала код для канала (по сути код gonzales - спасибо!):

traverseTree :: FilePath -> Producer FilePath IO ()
-- ^ traverse a tree in breadth first fashion using an external doBF function 
traverseTree path = (`evalStateT` empty) $ loop $ do
-- All code past this point uses the following monad transformer stack:
-- MaybeT (StateT (Seq FilePath) (Producer FilePath IO)) ()
let liftState = lift
    liftPipe  = lift . lift
    liftIO    = lift . lift . lift
liftState $ modify (|> path)
forever $ do
    x <- liftState $ gets viewl
    case x of
        EmptyL    -> quit
        file :< s -> do
            (yieldval, nextInputs) <- liftIO $ doBF file 
            liftState $ put s
            liftPipe $ yield yieldval
            liftState $ forM_ nextInputs $ \name -> modify (|> name)

следующий код для обхода дерева:

doBF :: FilePath -> IO (FilePath, [FilePath])
doBF file = do 
    finfo <- getInfo file
    let p =  isReadableDirectoryNotLink finfo
    namesRes <- if p then do
        names :: [String] <- liftIO $ getUsefulContents file
        let namesSorted = sort names
        let namesfull = map (file </>) namesSorted
        return namesfull
        else return []          
    return (file, namesRes) 

Я надеюсь заменить doBF аналогичной функцией, чтобы сначала пересечь глубину. я предполагал, что мог бы сделать traverseTree более общим, и не только для FilePath ~ String, но я не вижу, в каком классе находится пустая функция для последовательностей. может быть в целом полезным.