-- --------------------------------------------------------------------------- $Source: /repository/uni/htk/examples/gengui/MaingenericBrowser.hs,v $---- HTk - a GUI toolkit for Haskell  -  (c) Universitaet Bremen---- $Revision: 1.3 $ from $Date: 2002/05/30 15:00:17 $  -- Last modification by $Author: ger $---- -----------------------------------------------------------------------module Main(main) whereimport HTkimport Nameimport CItemimport ReferenceVariablesimport GenericBrowserimport Directoryimport IOExts(unsafePerformIO)import Posiximport Char(toLower)-- ------------------------------------------------------------------------- file types-- -----------------------------------------------------------------------type FileType = (String,          -- comment                 String)          -- image filenamefileTypes :: [([String], FileType)]fileTypes = [(["hs", "lhs"], ("Haskell source file", "haskell.gif")),             (["hi"], ("Haskell Interface File", "haskelli.gif")),             (["gif"], ("GIF image", "image.gif")),             (["jpg"], ("JPG image", "image.gif")),             (["png"], ("PNG image", "image.gif")),             (["tif", "tiff"], ("TIFF image", "image.gif")),             (["bmp"], ("BMP image", "image.gif")),             (["tex"], ("TeX file", "tex.gif")),             (["bib"], ("BibTeX file", "bib.gif")),             (["ps"], ("PostScript", "postscript.gif")),             (["tar"], ("TAR archive", "archive.gif")),             (["gz"], ("GZ archive", "archive.gif")),             (["zip"], ("ZIP archive", "archive.gif")),             (["rar"], ("RAR archive", "archive.gif")),             (["html", "htm"], ("Hypertext document", "html.gif"))]unknown :: FileTypeunknown = ("Unknown", "unknown.gif")folder :: FileTypefolder = ("Folder", "folder.gif")getFileTypeByExtension :: String -> FileTypegetFileTypeByExtension ext =  let getFileTypeByExtension' ((exts, ft) : tps) =        if any ((==) ext) exts then ft else getFileTypeByExtension' tps      getFileTypeByExtension' _ = unknown  in getFileTypeByExtension' fileTypes-- ------------------------------------------------------------------------- util-- -----------------------------------------------------------------------type Id = Intidref = unsafePerformIO (newRef 0){-# NOINLINE idref #-} newID :: IO IdnewID = do id <- getRef idref           setRef idref (id + 1)           return id-- ------------------------------------------------------------------------- filesystem functionality-- -----------------------------------------------------------------------readDir :: FilePath -> IO [FileObject]readDir dir =  do     ret <- try (do dc <- getDirectoryContents dir                    let dc' = filter (\f -> f /= "." && f /= ".." &&                                      not (hidden f)) dc                    mapM (toFileObject dir) dc')     case ret of Right objs -> return objs                 Left _ -> return []hidden :: FilePath -> Boolhidden ('.':_) = Truehidden _ = FalseisFolder :: FilePath -> FilePath -> IO BoolisFolder dir nm = doesDirectoryExist (dir ++ "/" ++ nm)getFileType :: FilePath -> FileTypegetFileType nm =  let extension nm = if any ((==) '.') nm then                       reverse (extension' (reverse nm))                     else ""      extension' (c : cs) = if c == '.' then [] else c : extension' cs      extension' _ = ""      ext = map toLower (extension nm)  in getFileTypeByExtension exttoFileObject :: FilePath -> FilePath -> IO FileObjecttoFileObject dir nm =  do obj_fid <- newID     obj_fname <- newRef nm     obj_fdir <- newRef dir     obj_is_folder <- isFolder dir nm     let ft@(_, img_path) = if obj_is_folder then folder                            else getFileType nm     obj_filetype <- newRef ft     icon <- newImage [filename ("images/" ++ img_path)]     obj_icon <- newRef icon     return (FileObject { fid       = obj_fid,                          fname     = obj_fname,                          fdir      = obj_fdir,                          filetype  = obj_filetype,                          icon      = obj_icon,                          is_folder = obj_is_folder })-- ------------------------------------------------------------------------- file objects-- -----------------------------------------------------------------------data FileObject = FileObject { fid       :: Id,                               fname     :: Ref FilePath,                               fdir      :: Ref FilePath,                               filetype  :: Ref FileType,                               icon      :: Ref Image,                               is_folder :: Bool }instance Eq FileObject where  obj1 == obj2 = fid obj1 == fid obj2instance CItem FileObject where  getName obj = getFileObjectName obj  getIcon obj = getFileObjectIcon objinstance GBObject FileObject where  isObjectNode = return . is_folder  getChildren obj = do                       path <- getFileObjectFullPath obj                       readDir path-- ------------------------------------------------------------------------- selectors-- -----------------------------------------------------------------------getFileObjectId :: FileObject -> IdgetFileObjectId obj = fid objgetFileObjectFileName :: FileObject -> IO FilePathgetFileObjectFileName obj = getRef (fname obj)getFileObjectDirectory :: FileObject -> IO FilePathgetFileObjectDirectory obj = getRef (fdir obj)getFileObjectFullPath :: FileObject -> IO FilePathgetFileObjectFullPath obj =  do dir <- getFileObjectDirectory obj     nm <- getFileObjectFileName obj     return (dir ++ "/" ++ nm)getFileObjectName :: FileObject -> IO NamegetFileObjectName obj =  do nm <- getFileObjectFileName obj     return (createName nm)getFileObjectIcon :: FileObject -> IO ImagegetFileObjectIcon obj = getRef (icon obj)getFileObjectFileType :: FileObject -> IO FileTypegetFileObjectFileType obj = getRef (filetype obj)isFileObjectFolder :: FileObject -> BoolisFileObjectFolder obj = is_folder obj-- ------------------------------------------------------------------------- main-- -----------------------------------------------------------------------getRootObjects :: IO [FileObject]getRootObjects = readDir "/"main :: IO ()main = do htk <- initHTk [size(800, 500), text "GenericBrowser example"]          root_objs <- getRootObjects          (gb :: GenericBrowser FileObject) <-            newGenericBrowser htk root_objs []          (action, _) <- bindGenericBrowserEv gb          spawnEvent (forever (do ev <- action                                  always (printEv ev)))          pack gb [Fill Both, Expand On]          bottom <- newFrame htk []          quit <- newButton bottom [text "Quit"]          clicked_quit <- clicked quit          spawnEvent (clicked_quit >>> destroy htk)          pack quit [Side AtBottom, Fill X, PadY 5, PadX 50]          pack bottom [Side AtBottom, Fill X]          finishHTkprintEv :: GenericBrowserEvent FileObject -> IO ()printEv ev = case ev of               SelectedInTreeList Nothing -> putStrLn "no selection (treelist)"               SelectedInTreeList _ -> putStrLn "selection (treelist)"               FocusedInTreeList _ -> putStrLn "focus (treelist)"               Dropped _ -> putStrLn "drop (notepad)"               SelectedInNotepad _ -> putStrLn "selection (notepad)"               DeselectedInNotepad _ -> putStrLn "deselection (notepad)"               Doubleclick _ -> putStrLn "doubleclick (notepad)"               Rightclick _ -> putStrLn "rightclick (notepad)"               _ -> done