ディレクトリ階層を平たくする

私のワーキングディレクトリは ~/work/2010/12/30/ のように日付による階層になっている.
過去1ヶ月とか過去1年のファイルを一覧したいことがあるので,階層を平たくするスクリプトをでっちあげた.

module Main where

import Control.Applicative
import Data.List
import System.Directory
import System.FilePath
import System.Posix.Files

main :: IO ()
main = mapM_ (createSymbolicLink <*> flatten) =<< getPaths "."

getPaths :: FilePath -> IO [FilePath]
getPaths topdir
 =   getUsefulContents topdir 
 >>= mapM (\ name -> do { let path = topdir </> name
                        ; isDirectory <- doesDirectoryExist path
                        ; if isDirectory then getPaths path else return [path]
                        })
 >>= return . concat

getUsefulContents :: FilePath -> IO [FilePath]
getUsefulContents = (return . sort . filter (`notElem` [".",".."]) =<<)
                  . getDirectoryContents

flatten :: FilePath -> FilePath
flatten = concat . dropWhile ("."==) . splitDirectories