wxHaskell のサンプル

プログレスバーを出す感じにしてみた。またしても投げやり。けど 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 :: ProgressDialog a -> FilePath -> FilePath -> IO ()
start 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 mes <- takeMVar m
                           progressDialogUpdateWithMessage f (c*100`div`e) mes
                           printer m (c+1) e
-- | 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 100)
         q <- newChan
         windowOnIdle f $ guiQueue q

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

         windowSetLayout p $ column 1 $ [widget startB,widget cancelB]
         frameSetMenuBar f m
         windowShow f
         windowRaise f
         return ()
onStart q p f = do prg <- progressDialogCreate "now copying" "Now copying files..." 100 p 0
                   windowSetClientSize prg (sz 400 30)
                   forkOS $ writeChan q $ do start prg "min-caml"
                                                       "test"
                                             windowDestroy prg
                                             return ()
                   windowEnable f
                   return ()
onExit f = do windowClose f True
              return ()