module HTk.Toolkit.FileDialog (
fileDialogStr,
newFileDialogStr,
fileDialog,
newFileDialog
) where
import System.Directory as Directory
import System.IO.Error
import qualified Data.List as List(sort)
import Control.Exception
import Util.FileNames
import Util.Messages
import Util.Computation
import Events.Events
import Events.Channels
import Events.Synchronized
import Reactor.ReferenceVariables
import HTk.Toplevel.HTk
import HTk.Toolkit.ModalDialog (modalDialog)
debugMsg :: String-> IO ()
debugMsg str = done
ioErrorWindow :: SomeException -> IO ()
ioErrorWindow excep =
warningMess ("Error while reading directory:\n"++
case fromException excep of
Just ioe ->
ioeGetErrorString ioe++"\n"++
case ioeGetFileName ioe of
Just fn -> "with file "++fn++"\n"
Nothing -> ""
Nothing -> "Exception: "++show excep++"\n"
)
tryGetFilesAndFolders :: FilePath -> Bool -> IO (Either SomeException
([FilePath], [FilePath]))
tryGetFilesAndFolders path showhidden =
do
debugMsg ("getting directory contents of " ++ path)
dc <- Control.Exception.try (getDirectoryContents path)
case dc of
Left exn -> do debugMsg "... error!"
return (Left exn)
Right dcontents -> do debugMsg "...ok\n"
c<- sort dcontents [] [] path
return (Right c)
where sort :: [FilePath] -> [FilePath] -> [FilePath] -> FilePath ->
IO ([FilePath], [FilePath])
sort (f : fs) files folders abs =
if f == "." || f == ".." || (hidden f && not showhidden) then
sort fs files folders abs
else
do
fileIsDir <- doesDirectoryExist (abs ++ f)
if fileIsDir
then
sort fs files ((f ++ "/") : folders) abs
else
sort fs (f : files) folders abs
sort _ files folders _ =
return (List.sort files,
if path == "/" then List.sort folders
else ".." : (List.sort folders))
hidden :: FilePath -> Bool
hidden f = head f == '.'
getFilesAndFolders :: FilePath -> Bool -> IO ([FilePath], [FilePath])
getFilesAndFolders path showhidden =
do dc <- tryGetFilesAndFolders path showhidden
case dc of
Left ioe-> do ioErrorWindow ioe
return ([], [".."])
Right cont-> return cont
dropLast :: FilePath -> FilePath
dropLast [] = []
dropLast path = dropLast' (tail (reverse path))
where dropLast' :: String -> String
dropLast' (c : cs) =
if c == '/' then reverse (c : cs) else dropLast' cs
dropLast' _ = []
updPathMenu :: MenuButton -> Ref (Maybe Menu) ->
FilePath -> Ref [FilePath] -> Ref [FilePath] ->
Ref FilePath -> ListBox FilePath ->
ListBox FilePath -> TkVariable String ->
Label -> Ref Bool -> IO ()
updPathMenu pathmenubutton menuref path foldersref filesref pathref
folderslb fileslb file_var status showhiddenref =
do
pathmenubutton # text path
m <- getRef menuref
case m of
Just m' -> destroy m'
_ -> done
pathmenu <- createMenu pathmenubutton False []
pathmenubutton # menu pathmenu
let paths = upperPaths path
mapM (createNewMenuItem pathmenu) paths
setRef menuref (Just pathmenu)
where upperPaths :: FilePath -> [FilePath]
upperPaths "/" = ["/"]
upperPaths p = p : upperPaths (dropLast p)
createNewMenuItem :: Menu -> FilePath -> IO ()
createNewMenuItem pathmenu fp =
do
item <- createMenuCommand pathmenu [text fp]
clickeditem <- clicked item
_ <- spawnEvent (forever (clickeditem >> always (selected fp)))
done
selected :: FilePath -> IO ()
selected fp =
do
status # text "Reading... "
showhidden <- getRef showhiddenref
success <- changeToFolder fp foldersref filesref
pathref folderslb fileslb file_var showhidden
(if success then
do
status # text "Reading...ready"
nupath <- getRef pathref
updPathMenu pathmenubutton menuref nupath foldersref
filesref pathref folderslb fileslb file_var status
showhiddenref
else
status # text "Permission denied!" >> done)
changeToFolder :: FilePath -> Ref [FilePath] -> Ref [FilePath] ->
Ref FilePath -> ListBox FilePath ->
ListBox FilePath -> TkVariable String -> Bool ->
IO Bool
changeToFolder path foldersref filesref pathref folderslb fileslb
file_var showhidden =
let path' = if path == "" then "/" else path
in do debugMsg "getting files and folders"
st <- tryGetFilesAndFolders path' showhidden
case st of
Right (files, folders) ->
do setRef pathref path
debugMsg "got files and folders"
setRef filesref files
setRef foldersref folders
fileslb # value files
folderslb # value folders
setTkVariable file_var ""
return True
Left excep ->
case fromException excep of
Just error | isPermissionError error -> return False
Nothing ->
do
ioErrorWindow excep
return False
up :: Ref [FilePath] -> Ref [FilePath] -> Ref FilePath ->
ListBox FilePath -> ListBox FilePath -> TkVariable String ->
Label -> Bool -> IO Bool
up foldersref filesref pathref folderslb fileslb file_var status
showhidden =
do
path <- getRef pathref
(if path /= "" && path /= "/" then
do
status # text "Reading... "
changeToFolder (dropLast path) foldersref filesref pathref
folderslb fileslb file_var showhidden
else return True)
selectedFolder :: Int -> Ref [FilePath] -> Ref [FilePath] ->
Ref FilePath -> ListBox FilePath ->
ListBox FilePath -> TkVariable String -> Bool ->
IO Bool
selectedFolder i foldersref filesref pathref folderslb fileslb file_var
showhidden =
do
folders <- getRef foldersref
path <- getRef pathref
let
trimmedPath = trimDir path
nupath = if (folders !! i) == ".."
then
dropLast trimmedPath
else
combineNames trimmedPath (folders !! i)
changeToFolder nupath foldersref filesref pathref folderslb fileslb
file_var showhidden
refresh :: Ref [FilePath] -> Ref [FilePath] -> Ref FilePath ->
ListBox FilePath -> ListBox FilePath -> Bool -> IO ()
refresh foldersref filesref pathref folderslb fileslb showhidden =
do
folders <- getRef foldersref
files <- getRef filesref
path <- getRef pathref
(files, folders) <- getFilesAndFolders path showhidden
setRef filesref files
setRef foldersref folders
folderslb # value folders
fileslb # value files
done
selectFile :: Int -> Ref [FilePath] -> TkVariable String -> IO ()
selectFile i filesref file_var =
do
files <- getRef filesref
setTkVariable file_var (files !! i)
createFolder :: Toplevel -> Ref (Maybe Toplevel) -> Ref (Maybe String) ->
IO ()
createFolder par childwindow ret =
synchronize par
(do
(w, h, x, y) <- getGeometry par
let w' = 400
h' = 100
main <- createToplevel [text "Create a new folder",
geometry (w', h',
x + (div w 2) (div w' 2),
y + (div h 2) (div h' 2))]
setRef childwindow (Just main)
(main_destr, main_destr_ub) <- bindSimple main Destroy
entnlab <- newFrame main []
lab <- newLabel entnlab [font (Lucida, 12::Int),
text "Enter name:"]
ent_var <- createTkVariable ""
ent <- newEntry entnlab [bg "white", width 40, variable ent_var]
:: IO (Entry String)
buttons <- newFrame main []
ok <- newButton buttons [text "Ok", width 12]
quit <- newButton buttons [text "Cancel", width 12]
pack entnlab [PadX 10, PadY 5]
pack lab []
pack ent [PadX 10, PadY 5]
pack buttons [PadX 10, PadY 5, Side AtBottom]
pack ok [PadX 5, Side AtLeft]
pack quit [PadX 5, Side AtLeft]
clickedok <- clicked ok
clickedquit <- clicked quit
let cleanUp :: IO ()
cleanUp = main_destr_ub >> setRef childwindow Nothing
listenDialog :: Event ()
listenDialog =
(clickedquit >> always (cleanUp >> destroy main))
+> (clickedok >> always (do
cleanUp
nm <- readTkVariable ent_var
setRef ret (Just nm)
destroy main))
+> (main_destr >> always (cleanUp))
modalDialog main True listenDialog)
confirmDeleteFile :: Toplevel -> FilePath -> Ref (Maybe Toplevel) ->
Ref Bool -> IO ()
confirmDeleteFile par fp childwindow ret =
synchronize par
(do
(w, h, x, y) <- getGeometry par
let w' = 400
h' = 100
main <- createToplevel [text "Delete file",
geometry (w', h',
x + (div w 2) (div w' 2),
y + (div h 2) (div h' 2))]
setRef childwindow (Just main)
(main_destr, main_destr_ub) <- bindSimple main Destroy
lab <- newLabel main
[font (Lucida, 12::Int),
text ("Do you really want to delete the file \n'" ++
fp ++ "' ?")]
pack lab [PadX 10, PadY 5]
buttons <- newFrame main []
pack buttons [PadX 10, PadY 5, Side AtBottom]
ok <- newButton buttons [text "Ok", width 15]
pack ok [PadX 5, Side AtLeft]
quit <- newButton buttons [text "Cancel", width 15]
pack quit [PadX 5, Side AtLeft]
clickedok <- clicked ok
clickedquit <- clicked quit
let cleanUp :: IO ()
cleanUp = main_destr_ub >> setRef childwindow Nothing
listenDialog :: Event ()
listenDialog =
(clickedok >> always (cleanUp >> setRef ret True >>
destroy main))
+> (clickedquit >> always (setRef ret False >> cleanUp >>
destroy main))
+> (main_destr >> always (cleanUp))
modalDialog main True listenDialog)
newFileDialogStr :: String
-> FilePath
-> IO (Event (Maybe FilePath))
newFileDialogStr title fp = do pr <- newRef fp
fileDialog' True title pr
fileDialogStr :: String
-> FilePath
-> IO (Event (Maybe FilePath))
fileDialogStr title fp = do pr <- newRef fp
fileDialog' False title pr
newFileDialog :: String
-> Ref FilePath
-> IO (Event (Maybe FilePath))
newFileDialog = fileDialog' True
fileDialog :: String
-> Ref FilePath
-> IO (Event (Maybe FilePath))
fileDialog = fileDialog' False
fileDialog' :: Bool
-> String
-> Ref FilePath
-> IO (Event (Maybe FilePath))
fileDialog' isNew title pathref =
do
fp <- getRef pathref
isDir <- doesDirectoryExist fp
let (path,fn) =
if isDir
then (if last fp == '/' then fp else fp ++ "/","")
else (\ (x,y) -> (x++"/",y)) (splitName fp)
setRef pathref path
childwindow <- newRef Nothing
main <- createToplevel [text title]
(main_destr, main_destr_ub) <- bindSimple main Destroy
let w' = 680
h' = 400
w <- getScreenWidth (Screen main)
h <- getScreenHeight (Screen main)
main # geometry (w', h', (div w 2) (div w' 2),
(div h 2) (div h' 2))
(files, folders) <- getFilesAndFolders path False
filesref <- newRef files
foldersref <- newRef folders
showhiddenref <- newRef False
actions <- newFrame main []
pathmenubutton <- newMenuButton actions [text path, width 50,
relief Raised]
upImg' <- upImg
refreshImg' <- refreshImg
newFolderImg' <- newFolderImg
deleteFileImg' <- deleteFileImg
upbutton <- newButton actions [photo upImg']
refreshbutton <- newButton actions [photo refreshImg']
newfolderbutton <- newButton actions [photo newFolderImg']
deletefilebutton <- newButton actions [photo deleteFileImg']
showHiddenFiles <- newCheckButton actions [text "hidden files"]
menuref <- newRef Nothing
boxesnmsg <- newFrame main []
boxes <- newFrame boxesnmsg []
folderslist <- newFrame boxes []
folderslb <- newListBox folderslist [value folders, size (35, 15),
bg "white",
font (Lucida, 12::Int)]
foldersscb <- newScrollBar folderslist []
fileslist <- newFrame boxes []
fileslb <- newListBox fileslist [value files, size (35, 15),
bg "white", font (Lucida, 12::Int)]
filesscb <- newScrollBar fileslist []
status <- newLabel boxesnmsg [text "Welcome", relief Raised,
font (Lucida, 12::Int), anchor Center]
file_var <- createTkVariable fn
fileEntry <- newEntry main [bg "white", variable file_var]
:: IO (Entry String)
buttons <- newFrame main []
ok <- newButton buttons [text "Ok", width 12]
quit <- newButton buttons [text "Cancel", width 12]
msgQ <- newChannel
pack actions [PadY 10]
pack pathmenubutton [PadX 10, Side AtLeft]
pack upbutton [PadX 2, Side AtLeft]
pack refreshbutton [PadX 2, Side AtLeft]
pack newfolderbutton [PadX 2, Side AtLeft]
pack deletefilebutton [PadX 2, Side AtLeft]
pack showHiddenFiles [PadX 10, Side AtLeft]
pack boxesnmsg [PadX 10, Expand On]
pack boxes [PadX 10, Fill X, Expand On]
pack folderslist [Side AtLeft, Expand Off]
pack folderslb [Side AtLeft]
pack foldersscb [Side AtRight, Fill Y]
pack fileslist [Side AtRight, Expand On]
folderslb # scrollbar Vertical foldersscb
pack fileslb [Side AtLeft]
pack filesscb [Side AtRight, Fill Y]
fileslb # scrollbar Vertical filesscb
pack status [PadX 10, PadY 3, Fill X, Expand On]
pack fileEntry [PadX 50, PadY 5, Fill X, Expand On]
pack buttons [PadY 5, PadX 30, Side AtRight]
updPathMenu pathmenubutton menuref path foldersref filesref pathref
folderslb fileslb file_var status showhiddenref
pack ok [PadX 5, Side AtLeft]
pack quit [PadX 5, Side AtRight]
clickeddeletefilebutton <- clicked deletefilebutton
clickedshowHiddenFiles <- clicked showHiddenFiles
clickedupbutton <- clicked upbutton
clickedrefreshbutton <- clicked refreshbutton
clickednewfolderbutton <- clicked newfolderbutton
clickedok <- clicked ok
clickedquit <- clicked quit
(fbpress, fbpress_ub) <- bindSimple folderslb (ButtonPress (Just 1))
(flpress, flpress_ub) <- bindSimple fileslb (ButtonPress (Just 1))
(enterName, en_ub) <- bindSimple fileEntry (KeyPress (Just (KeySym "Return")))
let cleanUp :: IO ()
cleanUp = flpress_ub >> fbpress_ub >> main_destr_ub
doFile :: Event ()
doFile =
always (
do
quit <- doFileInner
if quit
then
do
cleanUp
destroy main
else
sync listenDialog
)
doFileInner :: IO Bool
doFileInner =
do
file_nm <- readTkVariable file_var
path <- getRef pathref
let
trimmedPath = trimDir path
fullnm= case file_nm of
'/':_ -> file_nm
_ -> combineNames trimmedPath file_nm
fileIsDir <- doesDirectoryExist fullnm
let
sendFile = syncNoWait (send msgQ (Just fullnm))
reset = setTkVariable file_var ""
if fileIsDir
then
do
showhidden <- getRef showhiddenref
status # text "Reading... "
success <- changeToFolder fullnm foldersref
filesref pathref
folderslb fileslb
file_var showhidden
(if success then
do status # text "Reading...ready"
nupath <- getRef pathref
updPathMenu pathmenubutton
menuref nupath foldersref
filesref pathref folderslb
fileslb file_var status
showhiddenref
done
else
do status # text "Permission denied!"
done)
return False
else
do
fileExists <- doesFileExist fullnm
if fileExists
then
if isNew
then
do
proceed <- confirmMess
"File exists. Overwrite?"
if proceed then sendFile else reset
return proceed
else
do
sendFile
return True
else
if isNew
then
do
sendFile
return True
else
do
warningMess
("No such file or directory: "++
fullnm)
reset
return False
listenDialog :: Event ()
listenDialog =
(flpress >> always
(do
sel <- getSelection fileslb
:: IO (Maybe [Int])
case sel of
Just (i : _) ->
selectFile i filesref file_var
_ -> done) >>
listenDialog)
+> (fbpress >> always
(do
sel <- getSelection
folderslb :: IO (Maybe [Int])
case sel of
Just (i : _) ->
do
showhidden <- getRef showhiddenref
status # text "Reading... "
success <- selectedFolder i foldersref
filesref pathref
folderslb fileslb
file_var showhidden
(if success then
do
status # text "Reading...ready"
nupath <- getRef pathref
updPathMenu pathmenubutton
menuref nupath foldersref
filesref pathref folderslb
fileslb file_var status
showhiddenref
done
else
do status # text "Permission denied!"
done)
_ -> done) >>
listenDialog)
+> (clickedquit >> always (syncNoWait (send msgQ Nothing) >>
cleanUp >> destroy main))
+> (clickedok >> doFile)
+> (clickednewfolderbutton >>
always
(do
ret <- newRef Nothing
createFolder main childwindow ret
ret' <- getRef ret
case ret' of
Just nm ->
do
path <- getRef pathref
ok <- Control.Exception.try (Directory.createDirectory
(path ++ nm))
case ok of
Right _ ->
do
status #
text ("created folder " ++ nm)
showhidden <- getRef showhiddenref
refresh foldersref filesref pathref
folderslb fileslb showhidden
Left (_ :: SomeException) ->
status #
text
("Error: Couldn't create folder '" ++
nm ++ "'") >>
done
_ -> status #
text "cancelled folder creation" >> done) >>
listenDialog)
+> (clickedrefreshbutton >>
always (do
showhidden <- getRef showhiddenref
refresh foldersref filesref pathref
folderslb fileslb showhidden) >>
listenDialog)
+> (clickedupbutton >>
always (do
showhidden <- getRef showhiddenref
success <- up foldersref filesref pathref
folderslb fileslb file_var status
showhidden
(if success then
do
status # text "Reading...ready"
nupath <- getRef pathref
updPathMenu pathmenubutton menuref nupath
foldersref filesref pathref folderslb
fileslb file_var status showhiddenref
done
else status # text "Permission denied!" >>
done)) >>
listenDialog)
+> (do clickedshowHiddenFiles
always (do s <- getRef showhiddenref
setRef showhiddenref (not s)
status # text "Reading... "
refresh foldersref filesref pathref folderslb
fileslb (not s)
status # text "Reading...ready"
done)
listenDialog)
+> (do
enterName
doFile
)
+> (clickeddeletefilebutton >>
always
(do
nm <- readTkVariable file_var
(if nm == "" then
status # text "no file selected" >> done
else
do
ret <- newRef False
path <- getRef pathref
confirmDeleteFile main (path ++ nm) childwindow
ret
ret' <- getRef ret
(if ret' then
do
ok <- Control.Exception.try (removeFile (path ++ nm))
case ok of
Right _ ->
do
status #
text ("file '" ++ nm ++ "' deleted")
showhidden <- getRef showhiddenref
refresh foldersref filesref pathref
folderslb fileslb showhidden
Left (_ :: SomeException) ->
status #
text
("Error: Could not delete file '" ++
nm ++ "'") >> done
else status # text "cancelled file deletion" >>
done))) >>
listenDialog)
_ <- spawnEvent listenDialog
_ <- spawnEvent (main_destr >> always (do
mchildwindow <- getRef childwindow
case mchildwindow of
Just win -> destroy win
_ -> done
cleanUp
syncNoWait (send msgQ Nothing)))
return (receive msgQ)
upImg = newImage [imgData GIF
"R0lGODlhFAAUAKEAAP//////AAAAAP///yH5BAEAAAMALAAAAAAUABQAAAJAnI+py+0Po1Si2iiC3gLZn21iN4TiWXGdeWqfu7bqW5WyG6RZvbOjyculWkOhTQh6wY7I5I95Q5GSVNChWp0oCgA7"]
refreshImg = newImage [imgData GIF
"R0lGODlhFAAUAIQAAPj4+Pz8/Pv7+/b29gYGBvX19ZiYmPr6+oCAgAgICAcHB/Pz8/n5+QUFBYiIiJaWlv39/f7+/v///wAAAP///////////////////////////////////////////////yH5BAEAAB8ALAAAAAAUABQAAAU74CeOZGmeaKqu4+Q+rOjOLvuSz6TWccuXOlOC9vvMTgoaiXgiFInF1unYkwVRDdNtB4XFqNWweEwWhQAAOw=="]
newFolderImg = newImage [imgData GIF
"R0lGODlhFAAUAKEAAAAAAP//////AP///yH5BAEAAAMALAAAAAAUABQAAAI5nI+pywjzXlOgzlXlPRHSbG2AQJYaBGblKkgjC6/WG8dzXd84rO9y5GP1gi0gkTQMhlLMJqcJ3TQKADs="]
deleteFileImg = newImage [imgData GIF
"R0lGODlhFAAUAKEAAP////8AAP///////yH5BAEAAAAALAAAAAAUABQAAAIyhI+py+0WUnShTmBplVvZi2ShyHSY2WTk84HP6Wrt+8HxaNaLju/rgYIEOZwbcPhKPgoAOw=="]