できた

適当なままずるずると書き続けてコピーをキャンセルできるようにした。wxHaskell をいろいろ試しながらやってるのでどっか変なコードになってるかも。

-- {-# OPTIONS -Wall #-}
import Graphics.UI.WXCore
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 if there is no file or directory
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 FilePath -> 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 s
                      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)
                        
-- | main function
start :: MVar () -> ProgressDialog a -> FilePath -> FilePath -> IO ()
start stop f s t =
    do m <- newEmptyMVar
       putMVar m ""
       forkIO $ copyDir s t m
       fnum <- countFile s
       printer m 0 fnum
    where
      -- | print progressbar
      printer :: MVar FilePath -> Int -> Int -> IO ()
      printer m c e | c==e      = return ()
                    | otherwise =
                        do b <- isEmptyMVar stop
                           if b then do mes <- takeMVar m
                                        progressDialogUpdateWithMessage
                                            f (c*100`div`e) mes
                                        printer m (c+1) e
                                else return ()
-- | process gui action
guiQueue :: Chan (IO ()) -> IO Bool
guiQueue q = loop
    where loop = do b <- isEmptyChan q
                    if b then return False
                         else do join $ readChan q
                                 return True

main :: IO ()
main = run gui
gui = do m <- menuBarCreate 0
         f <- frameCreateTopFrame "file copy utility"
         windowSetBackgroundColour f white
         windowSetClientSize f (sz 200 60)
         q <- newChan
         windowOnIdle f $ guiQueue q

         stop <- newEmptyMVar
         p <- panelCreate f idAny rectNull 0
         startB <- buttonCreate p idAny "start copy" rectNull 0
         cancelB <- buttonCreate p idAny "exit" rectNull 0
         buttonOnCommand startB $ onStart q p f stop
         buttonOnCommand cancelB $ onExit f

         windowSetLayout p $ column 1 $ [widget startB, widget cancelB]
         frameSetMenuBar f m
         windowShow f
         windowRaise f
         return ()
onStart q p f stop =
    do windowHide f
       prg <- progressDialogCreate "now copying" "Now copying files..." 100 p 0
       windowSetClientSize prg (sz 400 100)
       cancelB <- buttonCreate prg idAny "Cancel" rectNull 0
       buttonOnCommand cancelB $ putMVar stop ()
       windowSetLayout prg $ column 1 $ [space 400 80, widget cancelB]
       writeChan q $ do start stop prg "min-caml"
                                       "tester"
                        windowDestroy prg
                        onExit f
       return ()
onExit f = do windowClose f True
              return ()