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 ()