ファイルコピー

突然だけど、ちゃんと活動していることを示す(誰に？)ためにコードを貼付けておく。
ディレクトリを指定するとコピーするというだけの投げやりプログラム。ソースもいろいろ投げやり。動けばなんでもいーや的な。1週間以内にはこれが GUI っぽくなる予定です。

{-# OPTIONS -Wall #-}
import Control.Monad
import Control.Monad.Reader
import Control.Concurrent
import System
import System.Directory
import System.IO

-- | True when given string starts with '.'
startsWithDot ('.':_) = True
startsWithDot _       = False
-- | True given
doesntExist :: FilePath -> IO Bool
doesntExist p = do b1 <- doesDirectoryExist p
                   b2 <- doesFileExist p
                   return $ not $ b1 || b2
-- | count number of files in given path
countFile :: FilePath -> IO Int
countFile p =
    do b1 <- doesFileExist p
       b2 <- doesDirectoryExist p
       case (b1, b2) of
         (True, False) -> return 1
         (False, True) ->
             do c <- getDirectoryContents p
                let c' = map ((p++"/")++) $ filter (not . startsWithDot) c
                liftM sum $ mapM countFile c'
         _             -> error $ "file not found: "++p
-- | copy directory recursively
--   both of the arguments are directoryname
copyDir :: FilePath -> FilePath -> MVar () -> IO ()
copyDir s t m =
    do b1 <- doesDirectoryExist s
       b2 <- doesntExist t
       if b1 && b2 then runReaderT copy (dropSep s, dropSep t)
                   else error $ "File or Directory already exists: "++t
    where dropSep s | last s == '/' = init s
                    | otherwise     = s
          copy :: ReaderT (FilePath, FilePath) IO ()
          copy = do (s,t) <- ask
                    b <- liftIO $ doesFileExist s
                    if b
                      then liftIO $ copyFile s t >> putMVar m ()
                      else do c <- liftIO $ getDirectoryContents s
                              liftIO $ createDirectory t
                              mapM_ (\c -> local (addDir c) copy)
                                        $ filter (not . startsWithDot) c
          addDir c (s,t) = (s++"/"++c,t++"/"++c)
-- | print progressbar
printer :: MVar () -> Int -> [Int] -> IO ()
printer _ _ [] = putChar '\n'
printer m c (x:xs) = do takeMVar m
                        if c == x then do putChar '*'
                                          hFlush stdout
                                          printer m (c+1) xs
                                  else printer m (c+1) (x:xs)
                        
-- | main function
start :: FilePath -> FilePath -> IO ()
start s t = do m <- newEmptyMVar
               putMVar m ()
               forkIO $ copyDir s t m
               fnum <- countFile s
               let one = fnum `div` 20
               putStrLn $ "0      :********************:"++show fnum
               putStr     "copying:" >> hFlush stdout
               let meter = let x = takeWhile (<fnum) [one,one+one..]
                           in  if length x < 20 then x++[fnum]
                                                else init x++[fnum]
               printer m 0 meter
main :: IO ()
main = getArgs >>= \[s,t] -> start s t

Main> start "ghc-6.6.1" "test"
0      :********************:2265
copying:********************
Main>