LIB/GTK: rewrite to use more atomic operations/data structures

This is a little bit less fancy, but avoids lazy IO. It depends a
little bit more on FilePath, but that also allows for a more general
interface.

src/GUI/Gtk/Callbacks.hs

@@ -1,3 +1,197 @@
 {-# OPTIONS_HADDOCK ignore-exports #-}
 
-module GUI.Gtk.Callbacks (startGUI) where
+module GUI.Gtk.Callbacks where
+
+
+import Control.Applicative
+  (
+    (<$>)
+  , (<*>)
+  )
+import Control.Concurrent.STM
+  (
+    TVar
+  , newTVarIO
+  , readTVarIO
+  )
+import Control.Monad.IO.Class
+  (
+    liftIO
+  )
+import Data.DirTree
+import Graphics.UI.Gtk
+import GUI.Gtk.Data
+import GUI.Gtk.Dialogs
+import GUI.Gtk.Utils
+import IO.File
+import IO.Utils
+import System.Directory
+  (
+    doesFileExist
+  , doesDirectoryExist
+  )
+import System.FilePath
+  (
+    isAbsolute
+  , (</>)
+  )
+import System.Glib.UTFString
+  (
+    glibToString
+  )
+
+
+import qualified Data.IntMap.Lazy as IM
+
+
+
+
+    -----------------
+    --[ Callbacks ]--
+    -----------------
+
+
+-- |Set callbacks, on hotkeys, events and stuff.
+--
+-- Interaction with mutable references:
+--
+-- * 'settings mygui' modifies
+-- * 'fsState' reads
+setCallbacks :: MyGUI -> MyView -> IO ()
+setCallbacks mygui myview = do
+  _ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
+    [Control] <- eventModifier
+    "q"       <- fmap glibToString eventKeyName
+    liftIO mainQuit
+  _ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
+    [Control] <- eventModifier
+    "h"       <- fmap glibToString eventKeyName
+    liftIO $ modifyTVarIO (settings mygui)
+                          (\x -> x { showHidden = not . showHidden $ x})
+             >> (refreshTreeView' mygui myview =<< readTVarIO (fsState myview))
+  _ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
+    [Alt] <- eventModifier
+    "Up"  <- fmap glibToString eventKeyName
+    liftIO $ upDir mygui myview
+  _ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
+    "Delete"  <- fmap glibToString eventKeyName
+    liftIO $ withRow mygui myview del
+  _ <- treeView mygui `on` rowActivated $ (\_ _ -> withRow mygui myview open)
+  _ <- menubarFileQuit mygui `on` menuItemActivated $ mainQuit
+  _ <- urlBar mygui `on` entryActivated $ urlGoTo mygui myview
+  _ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
+    [Control] <- eventModifier
+    "c"       <- fmap glibToString eventKeyName
+    liftIO $ withRow mygui myview copyInit
+  _ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
+    [Control] <- eventModifier
+    "v"       <- fmap glibToString eventKeyName
+    liftIO $ copyFinal mygui myview
+  return ()
+
+
+-- |Go to the url given at the 'urlBar' and visualize it in the given
+-- treeView.
+urlGoTo :: MyGUI -> MyView -> IO ()
+urlGoTo mygui myview = do
+  fp <- entryGetText (urlBar mygui)
+  let abs = isAbsolute fp
+  exists <- (||) <$> doesDirectoryExist fp <*> doesFileExist fp
+  -- TODO: more explicit error handling?
+  refreshTreeView mygui myview (Just fp)
+
+
+-- |Supposed to be used with 'withRow'. Opens a file or directory.
+--
+-- Interaction with mutable references:
+--
+-- * 'fsState' reads
+open :: Row -> MyGUI -> MyView -> IO ()
+open row mygui myview = do
+  fS <- readTVarIO $ fsState myview
+  case IM.lookup row (dirTree fS) of
+    Just dt@(Dir n _) -> do
+      newP <- readPath (anchor fS </> n)
+      refreshTreeView' mygui myview newP
+    Just dt@(File n _) ->
+      withErrorDialog $ openFile (anchor fS </> n)
+    _ -> return ()
+
+
+-- |Supposed to be used with 'withRow'. Deletes a file or directory.
+--
+-- Interaction with mutable references:
+--
+-- * 'fsState' reads
+del :: Row -> MyGUI -> MyView -> IO ()
+del row mygui myview = do
+  fS <- readTVarIO $ fsState myview
+  case dirLookup fS row of
+    dt@(Dir n _)   -> do
+      let fp = anchor fS </> n
+      subADT <- readPath fp
+      let cmsg  = "Really delete directory \"" ++ fp ++ "\"?"
+          cmsg2 = "Directory \"" ++ fp ++
+                  "\" is not empty! Delete all contents?"
+      withConfirmationDialog cmsg $
+        if IM.null (dirTree subADT)
+          then withErrorDialog (deleteDir fp
+                                >> refreshTreeView mygui myview Nothing)
+          else withConfirmationDialog cmsg2 $ withErrorDialog
+                 (deleteDirRecursive fp
+                  >> refreshTreeView mygui myview Nothing)
+    dt@(File _ _) -> do
+      let fp   = subDirName fS row
+          cmsg = "Really delete file \"" ++ fp ++ "\"?"
+      withConfirmationDialog cmsg
+        $ withErrorDialog (deleteFile fp
+                            >> refreshTreeView mygui myview Nothing)
+
+
+-- |Supposed to be used with 'withRow'. Initializes a file copy operation.
+--
+-- Interaction with mutable references:
+--
+-- * 'operationBuffer' writes
+-- * 'fsState' reads
+copyInit :: Row -> MyGUI -> MyView -> IO ()
+copyInit row mygui myview = do
+  fsState <- readTVarIO $ fsState myview
+  writeTVarIO (operationBuffer myview) (FCopy . CP1 $ subDirName fsState row)
+
+
+-- |Finalizes a file copy operation.
+--
+-- Interaction with mutable references:
+--
+-- * 'operationBuffer' reads
+-- * 'fsState' reads
+copyFinal :: MyGUI -> MyView -> IO ()
+copyFinal mygui myview = do
+  op <- readTVarIO (operationBuffer myview)
+  case op of
+    FCopy (CP1 sourceDir) -> do
+      curDir   <- anchor <$> readTVarIO (fsState myview)
+      let cmsg = "Really copy file \"" ++ sourceDir
+                 ++ "\"" ++ " to \"" ++ curDir ++ "\"?"
+      withConfirmationDialog cmsg $ do
+        copyMode <- showCopyModeChooserDialog
+        withErrorDialog ((runFileOp . FCopy . CC sourceDir curDir $ copyMode)
+                         >> refreshTreeView mygui myview Nothing)
+    _ -> return ()
+
+
+-- |Go up one directory and visualize it in the treeView.
+--
+-- Interaction with mutable references:
+--
+-- * 'rawModel' reads
+-- * 'sortedModel' reads
+-- * 'fsState' reads
+upDir :: MyGUI -> MyView -> IO ()
+upDir mygui myview = do
+  rawModel'    <- readTVarIO $ rawModel myview
+  sortedModel' <- readTVarIO $ sortedModel myview
+  fS           <- readTVarIO $ fsState myview
+  newP <- readPath (baseDir . anchor $ fS)
+  refreshTreeView' mygui myview newP