LIB: add TODO

.gitignore

@@ -1,15 +1,7 @@
-*.hp
-*.old
-*.prof
-*~
-.cabal-sandbox/
-.ghc.environment.*
-.liquid/
-.stack-work/
-3rdparty/hpath
-cabal.sandbox.config
-dist-newstyle/
 dist/
-hscope.out
+.cabal-sandbox/
-.ghcup
+cabal.sandbox.config
-/bin/
+*~
+*.hp
+*.prof
+*.old

.travis.yml

@@ -1,68 +0,0 @@
-# See https://github.com/hvr/multi-ghc-travis for more information
-
-language: c
-
-sudo: required
-dist: trusty
-
-matrix:
-  include:
-    - env: CABALVER=1.24 GHCVER=8.0.1
-      addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}}
-    - env: CABALVER=2.0 GHCVER=8.2.2
-      addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.2], sources: [hvr-ghc]}}
-    - env: CABALVER=2.2 GHCVER=8.4.1
-      addons: {apt: {packages: [cabal-install-2.2,ghc-8.4.1], sources: [hvr-ghc]}}
-    - env: CABALVER=head GHCVER=head
-      addons: {apt: {packages: [cabal-install-head,ghc-head,libgtk2.0-dev,libgtk-3-dev],  sources: [hvr-ghc]}}
-
-  allow_failures:
-    - env: CABALVER=head GHCVER=head
-
-env:
-  global:
-    - secure: "qAzj5tgAghFIfO6R/+Hdc5KcFhwXKNXMICNH7VLmqLzmYxk1UEkpi6hgX/f1bP5mLd07D+0IaeGFIUIWQOp+F/Du1NiX3yGbFuTt/Ja4I0K4ooCQc0w9uYLv8epxzp3VEOEI5sVCSpSomFjr7V0jwwTcBbxGUvv1VaGkJwAexRxCHuwU23KD0toECkVDsOMN/Gg2Ue/r2o+MsGx1/B9WMF0g6+zWlnrYfYZXWetl0DwATK5lZTa/21THdMrbuPX0fijGXTywvURDpCd3wIdfx9n7jPO2Gp2rcxPL/WkcIpzI211g4hEiheS+AlVyW39+C4i4MKaNK8YC+/5DRl/YHrFc7n3SZPDh+RMs6r3DS41RyRhQhz8DE0Pg4zfe/WUX4+h72TijCZ1zduh146rofwku/IGtCz5cuel+7cmTPk9ZyENYnH0ZMftkZjor9J/KamcMsN4zfaQBNJuIM3Kg8HVts3ymNIWrJ1LUn41MNt1eBDDvOWxZaHrjLyATRCFYvMr4RE01pqYKnWZ9RFfzVaYjD0QQWPWAXcCtkcAHSR6T0NxAqjLmHBNm+yWYIKG+bK2CvPNYTTNN8n4UvY1SrBpJEnLcRRns3U8nM7SVZ4GMaYzOTWtN1n0zamsl42wV0L/wqpz1SePkRZ34jca3V07XRLQSN2wjj8DyvOZUFR0="
-
-before_install:
- - sudo apt-get install -y hscolour
- - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
-
-install:
- - cabal --version
- - travis_retry cabal update
- - cabal sandbox init
- - cabal install alex happy
- - export PATH="$(pwd)/.cabal-sandbox/bin:$PATH"
- - cabal install gtk2hs-buildtools
- - cabal install --only-dependencies --enable-tests -j
-
-script:
- - cabal configure --enable-tests -v2
- - cabal build
- - cabal test
- - cabal check
- - cabal sdist
-# check that the generated source-distribution can be built & installed
- - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ;
-   cd dist/;
-   cabal sandbox init;
-   if [ -f "$SRC_TGZ" ]; then
-      cabal install alex happy;
-      export PATH="$(pwd)/.cabal-sandbox/bin:$PATH";
-      cabal install gtk2hs-buildtools;
-      cabal install "$SRC_TGZ" --enable-tests;
-   else
-      echo "expected '$SRC_TGZ' not found";
-      exit 1;
-   fi;
-   cd ..
- - sed -i -e '/hsfm,/d' hsfm.cabal
- - cabal haddock --executables --internal --hyperlink-source --html-location=https://hackage.haskell.org/package/\$pkg-\$version/docs/
-
-after_script:
-    - ./update-gh-pages.sh
-
-notifications:
-  email:
-    - hasufell@posteo.de
-

HACKING.md

@@ -1 +0,0 @@
-hacking/HACKING.md

HACKING.md

@@ -0,0 +1,29 @@
+HACKING
+=======
+
+Coding style
+------------
+
+- match the sorroundings
+- no overcomplicated pointfree style
+- normal indenting 2 whitespaces
+- just make things pretty and readable
+
+Documentation
+-------------
+
+__Everything__ must be documented. :)
+
+Hacking Guide
+-------------
+
+The main data structure is in [DirTree.hs](src/Data/DirTree.hs), which
+should be seen as a library. This is then mapped into the Gtk+ GUI at
+[Gtk.hs](src/GUI/Gtk.hs) and [Utils.hs](src/GUI/Gtk/Utils.hs).
+
+File operations (like copy, delete etc) are defined at
+[File.hs](src/IO/File.hs).
+
+Note that the main data structures are still a bit in flux. Join
+[the discussion](https://github.com/hasufell/hsfm/issues/12) on how to
+improve them.

README.md

@@ -1,8 +1,7 @@
 HSFM
 ====
 
-[![Join the chat at https://gitter.im/hasufell/hsfm](https://badges.gitter.im/hasufell/hsfm.svg)](https://gitter.im/hasufell/hsfm?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge)
+__NOTE: This project is in a highly experimental state! Don't complain if it deletes your whole home directory. You should use a chroot, docker environment or similar for testing.__
-[![Build Status](https://api.travis-ci.org/hasufell/hsfm.png?branch=master)](https://travis-ci.org/hasufell/hsfm)
 
 A Gtk+:3 filemanager written in Haskell.
 
@@ -13,20 +12,16 @@ Design goals:
 - type safety, runtime safety, strictness
 - simple add-on interface
 
-Screenshots
------------
-
-![hsfm](https://cloud.githubusercontent.com/assets/1241845/20034565/6c3ae80e-a3c2-11e6-882c-9fe0ff202045.png "hsfm-gtk")
 
 Installation
 ------------
 
 ```
-./install.sh
+cabal install
 ```
 
 
 Contributing
 ------------
 
-See [HACKING.md](hacking/HACKING.md).
+See [HACKING.md](HACKING.md).

cabal.project

@@ -1,10 +0,0 @@
-with-compiler: ghc-8.6.5
-
-packages: .
-
-optimization: 2
-
-package *
-    optimization: 2
-
-index-state: 2020-01-24T20:23:40Z

cabal.project.freeze

@@ -1,80 +0,0 @@
-constraints: any.Cabal ==2.4.0.1,
-             any.IfElse ==0.85,
-             any.abstract-deque ==0.3,
-             abstract-deque -usecas,
-             any.alex ==3.2.5,
-             alex +small_base,
-             any.array ==0.5.3.0,
-             any.atomic-primops ==0.8.3,
-             atomic-primops -debug,
-             any.base ==4.12.0.0,
-             any.base-orphans ==0.8.1,
-             any.binary ==0.8.6.0,
-             any.bytestring ==0.10.8.2,
-             any.cairo ==0.13.8.0,
-             cairo +cairo_pdf +cairo_ps +cairo_svg,
-             any.containers ==0.6.0.1,
-             any.deepseq ==1.4.4.0,
-             any.directory ==1.3.3.0,
-             any.exceptions ==0.10.4,
-             exceptions +transformers-0-4,
-             any.filepath ==1.4.2.1,
-             any.ghc-boot-th ==8.6.5,
-             any.ghc-prim ==0.5.3,
-             any.gio ==0.13.8.0,
-             any.glib ==0.13.8.0,
-             glib +closure_signals,
-             any.gtk2hs-buildtools ==0.13.8.0,
-             gtk2hs-buildtools +closuresignals,
-             any.gtk3 ==0.15.4,
-             gtk3 -build-demos +fmode-binary +have-gio,
-             any.happy ==1.19.12,
-             happy +small_base,
-             any.hashable ==1.3.0.0,
-             hashable -examples +integer-gmp +sse2 -sse41,
-             any.hashtables ==1.2.3.4,
-             hashtables -bounds-checking -debug -detailed-profiling -portable -sse42 +unsafe-tricks,
-             any.heaps ==0.3.6.1,
-             any.hinotify-bytestring ==0.3.8.1,
-             any.hpath ==0.11.0,
-             any.hpath-filepath ==0.10.3,
-             any.hpath-io ==0.12.0,
-             any.hsc2hs ==0.68.6,
-             hsc2hs -in-ghc-tree,
-             any.integer-gmp ==1.0.2.0,
-             any.lockfree-queue ==0.2.3.1,
-             any.monad-control ==1.0.2.3,
-             any.monad-loops ==0.4.3,
-             monad-loops +base4,
-             any.mtl ==2.2.2,
-             any.network ==3.1.1.1,
-             any.old-locale ==1.0.0.7,
-             any.pango ==0.13.8.0,
-             pango +new-exception,
-             any.parsec ==3.1.13.0,
-             any.pretty ==1.1.3.6,
-             any.primitive ==0.7.0.0,
-             any.process ==1.6.5.0,
-             any.random ==1.1,
-             any.rts ==1.0,
-             any.safe ==0.3.18,
-             any.safe-exceptions ==0.1.7.0,
-             any.simple-sendfile ==0.2.30,
-             simple-sendfile +allow-bsd,
-             any.stm ==2.5.0.0,
-             any.streamly ==0.7.0,
-             streamly -benchmark -debug -dev -examples -examples-sdl -has-llvm -inspection -no-charts -no-fusion -streamk,
-             any.template-haskell ==2.14.0.0,
-             any.text ==1.2.3.1,
-             any.time ==1.8.0.2,
-             any.transformers ==0.5.6.2,
-             any.transformers-base ==0.4.5.2,
-             transformers-base +orphaninstances,
-             any.transformers-compat ==0.6.5,
-             transformers-compat -five +five-three -four +generic-deriving +mtl -three -two,
-             any.unix ==2.7.2.2,
-             any.unix-bytestring ==0.3.7.3,
-             any.utf8-string ==1.0.1.1,
-             any.vector ==0.12.0.3,
-             vector +boundschecks -internalchecks -unsafechecks -wall,
-             any.word8 ==0.1.3

hacking/HACKING.md

@@ -1,105 +0,0 @@
-# HACKING
-
-Check out the [issue tracker](https://github.com/hasufell/hsfm/issues)
-if you don't know yet what you want to hack on.
-
-## Coding style
-
-- match the sorroundings
-- no overcomplicated pointfree style
-- normal indenting 2 whitespaces
-- just make things pretty and readable
-- you can use the provided [hsimport.hs](hsimport.hs)
-
-## Documentation
-
-__Everything__ must be documented. :)
-Don't assume people know what you mean. Type signatures are not sufficient
-documentation.
-
-## Hacking Overview
-
-Only a GTK GUI is currently implemented, the entry point being
-[HSFM.GUI.Gtk](./../src/HSFM/GUI/Gtk.hs). From there it flows down
-to creating a [MyGUI object](./../src/HSFM/GUI/Gtk/Data.hs#L51) in
-[HSFM.GUI.Gtk.MyGUI](./../src/HSFM/GUI/Gtk/MyGUI.hs), which is sort of
-a global object for the whole window. Inside this object are
-theoretically multiple [MyView objects](./../src/HSFM/GUI/Gtk/Data.hs#L101)
-allowed which represent the actual view on the filesystem and related
-widgets, which are constructed in
-[HSFM.GUI.Gtk.MyView](./../src/HSFM/GUI/Gtk/MyView.hs). Both MyGUI and MyView
-are more or less accessible throughout the whole GTK callstack, expclicitly
-passed as parameters.
-
-For adding new GTK widgets with functionality you mostly have to touch the
-following files:
-* [builder.xml](./../data/Gtk/builder.xml): this defines the main GUI widgets which are static, use the [glade editor](http://glade.gnome.org) to add stuff
-* [HSFM.GUI.Gtk.Data](./../src/HSFM/GUI/Gtk/Data.hs): add the widget to e.g. the MyGUI type so we can access it throughout the GTK call stack
-* [HSFM.GUI.Gtk.MyGUI](./../src/HSFM/GUI/Gtk/MyGUI.hs): add initializers for the GUI buttons to be fetched from the GTK builder.xml file
-* [HSFM.GUI.Gtk.Callbacks](./../src/HSFM/GUI/Gtk/Callbacks.hs): define the callbacks and the actual functionality here
-
-## Concepts
-
-### Path safety
-
-Paths are usually represented in haskell libraries as `type FilePath = String`.
-This is bad, because of a number of reasons:
-* encoding issues, since the low-level representation of filepaths is in fact an array of C chars
-* weak typing... we could pass arbitrary invalid/malicious filepaths or other random strings
-* no information about any property at type level (e.g. is it an absolute path?)
-* no filepath constructors that do sanity checks and proper parsing
-* no guarantee whether the filepath is normalised or not or even valid
-
-Because of that, the solution is:
-* use `ByteString` under the hood
-* wrap it inside `Path t` where `t` can be either `Abs` (for absolute), `Rel` (for relative) or `Fn` (for filename)
-* construct filepaths via smart constructors only that reject certain paths (like `.` or `..`) and normalise the path
-
-This leads to the following benefits:
-* we have guarantees about whether a path is absolute or not, which is important for runtime safety in general, predictable behavior and thread safety
-* we don't mess with the filepath representation we get from low-level posix functions, so encoding issues are pretty much out
-* we can reason about filepaths and rely on them to be valid (don't confuse that with "they exist")
-* filepath functions like `(</>)` are now predictable and safe in contrast to the version from the `filepath` package
-
-The [hpath](https://hackage.haskell.org/package/hpath) library does exactly that for us.
-
-The only problem with this approach is that most libraries are still String
-based. Some provide dedicated `Foo.ByteString` modules though, but it
-might be necessary to fork libraries.
-We also need to keep track of the [Abstract FilePath proposal](https://ghc.haskell.org/trac/ghc/wiki/Proposal/AbstractFilePath).
-
-Almost all paths in HSFM are only allowed to be absolute (`Path Abs`), unless
-they are filenames (`Path Fn`) and processed for GUI purposes. This is as
-already mentioned for the purpose of runtime safety, predictability and
-thread safety.
-
-### File IO safety
-
-This is a pretty difficult problem. One thing to ensure safety on IO level
-is simply the strong haskell type system, since we push everything
-into our `File a` type and can then pattern match easily against the different
-types of files.
-
-The only problem with this approach is that we are examining a file at point
-`a` in time, safe the information and then use that information further down
-the call stack at point `b` in time, when the file information in memory
-could already be out of date. There are two approaches to make this less
-sucky:
-* use the hinotify library on GUI level to refresh the view (and the File representation in memory) whenever the contents of a directory changes
-* when we stuff something into the copy buffer, it is not saved as type `File a`, but as `Path Abs`... when the operation is finalized  then the file at the given path is read and the copy/move/whatnot function carried out immediately
-
-In addition, we don't use the `directory` package, which is dangerous
-and broken. Instead, we use the [HPath.IO](https://hackage.haskell.org/package/hpath/docs/HPath-IO.html).
-
-### Exception handling
-
-Exceptions are good. We don't want to wrap everything in Maybe/Either types
-unless we want to handle failure immediately. Otherwise we need to make
-sure that at least at some point IOExceptions are caught and visualized
-to the user. This is often done via e.g. `withErrorDialog` which catches
-`IOException` and [HPathIOException](https://hackage.haskell.org/package/hpath/docs/HPath-IO-Errors.html#t:HPathIOException).
-
-It's also important to clean up stuff like filedescriptors via
-functions like `bracket` directly in our low-level code in case
-something goes wrong.
-

hacking/hsimport.hs

@@ -1,53 +0,0 @@
-import Data.List
-import qualified Language.Haskell.Exts as HS
-import HsImport
-
-main :: IO ()
-main = hsimport $ defaultConfig { prettyPrint = prettyPrint
-                                , findImportPos = findImportPos }
-   where
-      prettyPrint :: HS.ImportDecl -> String
-      prettyPrint (HS.ImportDecl sloc modname qual _ _ mpkg mas mspec) =
-        "import " ++ (ifStr qual "qualified ") ++
-        (maybe "" (\pkg -> " \"" ++ pkg ++ "\" ") mpkg)  ++
-        getMN modname ++ (maybe "" (\name -> " as " ++ getMN name) $ mas) ++
-        specprint mspec
-
-      specprint :: Maybe (Bool, [HS.ImportSpec]) -> String
-      specprint Nothing = ""
-      specprint (Just (False, xs))
-        = "\n  (\n" ++ printImportSpecs xs ++ "  )"
-      specprint (Just (True, xs))
-        = "\n  hiding (\n" ++ printImportSpecs xs ++ "  )"
-
-      printImportSpecs :: [HS.ImportSpec] -> String
-      printImportSpecs ins
-          = let (x:xs) = sort ins
-            in  "    " ++ printSpec x ++ "\n" ++ go xs
-        where
-          go []       = ""
-          go [x']     = "  , " ++ printSpec x' ++ "\n"
-          go (x':xs') = "  , " ++ printSpec x' ++ "\n" ++ go xs'
-          printSpec :: HS.ImportSpec -> String
-          printSpec = HS.prettyPrint
-    
-
-      findImportPos :: HS.ImportDecl -> [HS.ImportDecl] -> Maybe ImportPos
-      findImportPos _         []             = Nothing
-      findImportPos newImport currentImports = Just findPos
-        where
-          lastPos = After . last $ currentImports
-          findPos = let xs = takeWhile (\x -> (getMN $ HS.importModule x)
-                                              <
-                                              (getMN $ HS.importModule newImport)
-                                       )
-                             . sort
-                             $ currentImports
-                    in if null xs then lastPos else After . last $ xs
-
-      ifStr :: Bool -> String -> String
-      ifStr True str = str
-      ifStr False _  = ""
-
-      getMN :: HS.ModuleName -> String
-      getMN (HS.ModuleName name) = name

hsfm.cabal

@@ -6,102 +6,41 @@ license:             GPL-2
 license-file:        LICENSE
 author:              Julian Ospald
 maintainer:          hasufell@hasufell.de
-copyright:           Copyright: (c) 2016 Julian Ospald
+copyright:           Copyright: (c) 2015 Julian Ospald
 homepage:            https://github.com/hasufell/hsfm
 category:            Desktop
 build-type:          Simple
-cabal-version:       >=1.22
+cabal-version:       >=1.10
 
-data-files:
+data-files:          data/Gtk/builder.xml
-                     LICENSE
-                     data/Gtk/builder.xml
                      data/Gtk/icons/error.png
                      data/Gtk/icons/gtk-directory.png
                      data/Gtk/icons/gtk-file.png
                      data/Gtk/icons/hsfm.png
-                     hsfm.cabal
+                     LICENSE
 
 
 library
-  exposed-modules:
+  exposed-modules:     Data.DirTree
-                       HSFM.FileSystem.FileType
+                       IO.Utils
-                       HSFM.FileSystem.UtilTypes
+                       IO.File
-                       HSFM.History
+                       IO.Error
-                       HSFM.Settings
+                       MyPrelude
-                       HSFM.Utils.IO
-                       HSFM.Utils.MyPrelude
 
-  build-depends:
+  build-depends:       base >= 4.7,
-                       IfElse,
+                       data-default,
-                       base >= 4.8 && < 5,
+                       bifunctors >= 5,
-                       bytestring,
+                       containers,
+                       directory >= 1.1.0.0 && < 1.2.3.0,
                        filepath >= 1.3.0.0,
-                       hinotify-bytestring,
+                       hinotify,
-                       hpath >= 0.11.0 ,
+                       mtl >= 2.2,
-                       hpath-filepath >= 0.10.3,
-                       hpath-io >= 0.12.0,
-                       safe,
-                       stm,
-                       time >= 1.4.2,
-                       unix,
-                       utf8-string
-  hs-source-dirs:      src
-  default-language:    Haskell2010
-  Default-Extensions:  RecordWildCards
-                       PatternSynonyms
-                       FlexibleInstances
-                       ViewPatterns
-  ghc-options:
-    -Wall
-
-executable hsfm-gtk
-  main-is:             HSFM/GUI/Gtk.hs
-  other-modules:
-                       Paths_hsfm
-                       HSFM.FileSystem.FileType
-                       HSFM.FileSystem.UtilTypes
-                       HSFM.GUI.Glib.GlibString
-                       HSFM.GUI.Gtk.Callbacks
-                       HSFM.GUI.Gtk.Callbacks.Utils
-                       HSFM.GUI.Gtk.Data
-                       HSFM.GUI.Gtk.Dialogs
-                       HSFM.GUI.Gtk.Errors
-                       HSFM.GUI.Gtk.Icons
-                       HSFM.GUI.Gtk.MyGUI
-                       HSFM.GUI.Gtk.MyView
-                       HSFM.GUI.Gtk.Plugins
-                       HSFM.GUI.Gtk.Settings
-                       HSFM.GUI.Gtk.Utils
-                       HSFM.History
-                       HSFM.Settings
-                       HSFM.Utils.IO
-                       HSFM.Utils.MyPrelude
-
-  build-depends:
-                       Cabal >= 1.22.0.0,
-                       IfElse,
-                       base >= 4.8 && < 5,
-                       bytestring,
-                       filepath >= 1.3.0.0,
-                       glib >= 0.13,
-                       gtk3 >= 0.14.1,
-                       hinotify-bytestring,
-                       hpath >= 0.11.0 ,
-                       hpath-filepath >= 0.10.3,
-                       hpath-io >= 0.12.0,
-                       hsfm,
-                       monad-loops,
                        old-locale >= 1,
                        process,
                        safe,
-                       simple-sendfile,
                        stm,
                        time >= 1.4.2,
-                       transformers,
+                       unix
-                       unix,
-                       unix-bytestring,
-                       utf8-string,
-                       word8
   hs-source-dirs:      src
   default-language:    Haskell2010
   Default-Extensions:  RecordWildCards
@@ -109,9 +48,45 @@ executable hsfm-gtk
                        FlexibleInstances
                        ViewPatterns
   ghc-options:
-    -Wall
+    -O2
+    -threaded
+    "-with-rtsopts=-N"
 
-source-repository head
+executable hsfm-gtk
-  type:     git
+  main-is:             GUI/Gtk.hs
-  location: https://github.com/hasufell/hsfm
+  other-modules:       GUI.Gtk.Callbacks
+                       GUI.Gtk.Data
+                       GUI.Gtk.Dialogs
+                       GUI.Gtk.Icons
+                       GUI.Gtk.Utils
+                       MyPrelude
 
+  build-depends:       hsfm,
+                       base >= 4.7,
+                       Cabal >= 1.22.0.0,
+                       containers,
+                       data-default,
+                       gtk3 >= 0.14.1,
+                       glib >= 0.13,
+                       bifunctors >= 5,
+                       directory >= 1.1.0.0 && < 1.2.3.0,
+                       filepath >= 1.3.0.0,
+                       hinotify,
+                       mtl >= 2.2,
+                       old-locale >= 1,
+                       process,
+                       safe,
+                       stm,
+                       time >= 1.4.2,
+                       transformers,
+                       unix
+  hs-source-dirs:      src
+  default-language:    Haskell2010
+  Default-Extensions:  RecordWildCards
+                       PatternSynonyms
+                       FlexibleInstances
+                       ViewPatterns
+  ghc-options:
+    -O2
+    -threaded
+    "-with-rtsopts=-N"

install.sh

@@ -1,42 +0,0 @@
-#!/bin/sh
-
-set -eu
-
-SCRIPT_DIR="$(CDPATH="" cd -- "$(dirname -- "$0")" && pwd -P)"
-
-cd "${SCRIPT_DIR}"
-
-# install ghcup
-if ! [ -e "${SCRIPT_DIR}"/.ghcup/bin/ghcup ] ; then
-    mkdir -p "${SCRIPT_DIR}"/.ghcup/bin
-    curl --proto '=https' --tlsv1.2 -sSf https://gitlab.haskell.org/haskell/ghcup/raw/master/ghcup > "${SCRIPT_DIR}"/.ghcup/bin/ghcup
-    chmod +x "${SCRIPT_DIR}"/.ghcup/bin/ghcup
-fi
-
-# set up environment
-export PATH="${SCRIPT_DIR}/.ghcup/bin:$PATH"
-export GHCUP_INSTALL_BASE_PREFIX="${SCRIPT_DIR}"
-
-# get ghc version from cabal.project
-ghc_ver=$(grep with-compiler cabal.project | awk '{print $2}' | sed 's/ghc-//')
-
-# install ghc
-if ! ghcup list -t ghc -c installed -r | grep -q "${ghc_ver}" ; then
-    ghcup install "${ghc_ver}"
-fi
-
-# install cabal-install
-if [ -z "$(ghcup list -t cabal-install -c installed -r)" ] ; then
-    ghcup install-cabal
-fi
-
-[ -e "${SCRIPT_DIR}"/bin ] || mkdir "${SCRIPT_DIR}"/bin
-
-# install binary
-cabal v2-install \
-    --installdir="${SCRIPT_DIR}"/bin \
-    --install-method=copy \
-    --overwrite-policy=always
-
-echo "Binary installed in: ${SCRIPT_DIR}/bin"
-

src/Data/DirTree.hs

@@ -0,0 +1,797 @@
+{--
+HSFM, a filemanager written in Haskell.
+Copyright (C) 2015 Julian Ospald
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+version 2 as published by the Free Software Foundation.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
+--}
+
+{-# OPTIONS_HADDOCK ignore-exports #-}
+
+-- |This module provides data types for representing directories/files
+-- and related operations on it, mostly internal stuff, not actual IO actions.
+--
+-- It doesn't allow to represent the whole filesystem, since that's only
+-- possible through IO laziness, which introduces too much internal state.
+module Data.DirTree where
+
+
+import Control.Applicative
+  (
+    (<*>)
+  , (<$>)
+  , (<|>)
+  , pure
+  )
+import Control.Arrow
+  (
+    first
+  )
+import Control.Exception
+  (
+    handle
+  )
+import Control.Exception.Base
+  (
+    IOException
+  )
+import Control.Monad.State.Lazy
+  (
+
+  )
+import Data.Default
+import Data.List
+  (
+    delete
+  , foldl'
+  , isPrefixOf
+  , sort
+  , sortBy
+  , (\\)
+  )
+import Data.Maybe
+  (
+    fromMaybe
+  )
+import Data.Ord
+  (
+    comparing
+  )
+import Data.Time.Clock.POSIX
+  (
+    POSIXTime
+  , posixSecondsToUTCTime
+  )
+import Data.Traversable
+  (
+    for
+  )
+import Data.Word
+  (
+    Word64
+  )
+import Safe
+  (
+    atDef
+  , initDef
+  )
+import System.FilePath
+  (
+    combine
+  , normalise
+  , equalFilePath
+  , isAbsolute
+  , joinPath
+  , pathSeparator
+  , splitDirectories
+  , takeFileName
+  , (</>)
+  )
+import System.IO
+  (
+    IOMode
+  , Handle
+  , openFile
+  )
+import System.IO.Error
+  (
+    ioeGetErrorType
+  , isDoesNotExistErrorType
+  )
+import System.IO.Unsafe
+  (
+    unsafeInterleaveIO
+  )
+import System.Locale
+  (
+    defaultTimeLocale
+  , rfc822DateFormat
+  )
+import System.Posix.Types
+  (
+    DeviceID
+  , EpochTime
+  , FileID
+  , FileMode
+  , FileOffset
+  , GroupID
+  , LinkCount
+  , UserID
+  )
+
+import qualified Data.Bitraversable as BT
+import qualified Data.Bifunctor     as BF
+import qualified Data.Bifoldable    as BFL
+import qualified Data.Traversable   as T
+import qualified System.Posix.Files as PF
+import qualified System.Posix.Directory as PFD
+
+
+
+
+    ----------------------------
+    --[ BASE TYPES ]--
+    ----------------------------
+
+
+-- |Weak type to distinguish between FilePath and FileName.
+type FileName = String
+
+
+-- |Represents a file. The `anchor` field is the path
+-- to that file without the filename.
+data AnchoredFile a =
+  (:/) { anchor :: FilePath, file :: File a }
+  deriving (Eq, Show)
+
+
+-- |The String in the name field is always a file name, never a full path.
+-- The free type variable is used in the File/Dir constructor and can hold
+-- Handles, Strings representing a file's contents or anything else you can
+-- think of. We catch any IO errors in the Failed constructor. an Exception
+-- can be converted to a String with 'show'.
+data File a =
+    Failed {
+    name :: FileName
+  , err  :: IOException
+  }
+  | Dir {
+    name :: FileName
+  , fvar :: a
+  }
+  | RegFile {
+    name :: FileName
+  , fvar :: a
+  }
+  | SymLink {
+    name  :: FileName
+  , fvar  :: a
+  , sdest :: AnchoredFile a  -- ^ symlink madness,
+                             --   we need to know where it points to
+  }
+  | BlockDev {
+    name :: FileName
+  , fvar :: a
+  }
+  | CharDev {
+    name :: FileName
+  , fvar :: a
+  }
+  | NamedPipe {
+    name :: FileName
+  , fvar :: a
+  }
+  | Socket {
+    name :: FileName
+  , fvar :: a
+  } deriving (Show, Eq)
+
+
+-- |All possible file information we could ever need.
+data FileInfo = FileInfo {
+    deviceID :: DeviceID
+  , fileID :: FileID
+  , fileMode :: FileMode
+  , linkCount :: LinkCount
+  , fileOwner :: UserID
+  , fileGroup :: GroupID
+  , specialDeviceID :: DeviceID
+  , fileSize :: FileOffset
+  , accessTime :: EpochTime
+  , modificationTime :: EpochTime
+  , statusChangeTime :: EpochTime
+  , accessTimeHiRes :: POSIXTime
+  , modificationTimeHiRes :: POSIXTime
+  , statusChangeTimeHiRes :: POSIXTime
+} deriving (Show, Eq, Ord)
+
+
+type UserIO a = FilePath -> IO a
+
+type Builder a = UserIO a -> FilePath -> IO [File a]
+
+
+
+
+    ------------------------------------
+    --[ ViewPatterns/PatternSynonyms ]--
+    ------------------------------------
+
+
+convertViewP :: (File FileInfo -> (Bool, File FileInfo))
+             -> AnchoredFile FileInfo
+             -> (Bool, AnchoredFile FileInfo)
+convertViewP f af@(bp :/ constr) =
+  let (b, file) = f constr
+  in (b, bp :/ file)
+
+
+
+afileLike :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
+afileLike f@(bp :/ constr) = convertViewP fileLike f
+
+fileLike :: File FileInfo -> (Bool, File FileInfo)
+fileLike f@(RegFile {})   = (True, f)
+fileLike f@(BlockDev {})  = (True, f)
+fileLike f@(CharDev {})   = (True, f)
+fileLike f@(NamedPipe {}) = (True, f)
+fileLike f@(Socket {})    = (True, f)
+fileLike f                = (False, f)
+
+
+sadir :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
+sadir f = convertViewP sdir f
+
+sdir :: File FileInfo -> (Bool, File FileInfo)
+sdir f@(SymLink { sdest = (_ :/ s@(SymLink {}) )})
+  -- we have to follow a chain of symlinks here, but
+  -- return only the very first level
+  = case (sdir s) of
+      (True, _) -> (True, f)
+      _         -> (False, f)
+sdir f@(SymLink { sdest = (_ :/ Dir {} )})
+  = (True, f)
+sdir f@(Dir {}) = (True, f)
+sdir f          = (False, f)
+
+
+safileLike :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
+safileLike f = convertViewP sfileLike f
+
+sfileLike :: File FileInfo -> (Bool, File FileInfo)
+sfileLike f@(RegFile {})   = (True, f)
+sfileLike f@(BlockDev {})  = (True, f)
+sfileLike f@(CharDev {})   = (True, f)
+sfileLike f@(NamedPipe {}) = (True, f)
+sfileLike f@(Socket {})    = (True, f)
+sfileLike f                = fileLikeSym f
+
+
+afileLikeSym :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
+afileLikeSym f = convertViewP fileLikeSym f
+
+fileLikeSym :: File FileInfo -> (Bool, File FileInfo)
+fileLikeSym f@(SymLink { sdest = (_ :/ s@(SymLink {}) )})
+  = case (fileLikeSym s) of
+      (True, _) -> (True, f)
+      _         -> (False, f)
+fileLikeSym f@(SymLink { sdest = (_ :/ RegFile {} )}) = (True, f)
+fileLikeSym f@(SymLink { sdest = (_ :/ BlockDev {} )}) = (True, f)
+fileLikeSym f@(SymLink { sdest = (_ :/ CharDev {} )}) = (True, f)
+fileLikeSym f@(SymLink { sdest = (_ :/ NamedPipe {} )}) = (True, f)
+fileLikeSym f@(SymLink { sdest = (_ :/ Socket {} )}) = (True, f)
+fileLikeSym f = (False, f)
+
+
+adirSym :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
+adirSym f = convertViewP dirSym f
+
+dirSym :: File FileInfo -> (Bool, File FileInfo)
+dirSym f@(SymLink { sdest = (_ :/ s@(SymLink {}) )})
+  = case (dirSym s) of
+      (True, _) -> (True, f)
+      _         -> (False, f)
+dirSym f@(SymLink { sdest = (_ :/ Dir {} )}) = (True, f)
+dirSym f = (False, f)
+
+
+invalidFileName :: FileName -> (Bool, FileName)
+invalidFileName ""   = (True, "")
+invalidFileName "."  = (True, ".")
+invalidFileName ".." = (True, "..")
+invalidFileName fn   = (elem pathSeparator fn, fn)
+
+
+abrokenSymlink :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
+abrokenSymlink f = convertViewP brokenSymlink f
+
+brokenSymlink :: File FileInfo -> (Bool, File FileInfo)
+brokenSymlink f = (isBrokenSymlink f, f)
+
+
+-- |Matches on invalid filesnames, such as ".", ".." and anything
+-- that contains a path separator.
+pattern InvFN   <- (invalidFileName -> (True,_))
+-- |Opposite of `InvFN`.
+pattern ValFN f <- (invalidFileName -> (False, f))
+
+
+-- |Matches on directories or symlinks pointing to directories.
+-- If the symlink is pointing to a symlink pointing to a directory, then
+-- it will return True, but also return the first element in the symlink-
+-- chain, not the last.
+pattern ADirOrSym f <- (sadir -> (True, f))
+pattern DirOrSym  f <- (sdir  -> (True, f))
+
+-- |Matches on symlinks pointing to directories only.
+pattern ADirSym  f <- (adirSym -> (True, f))
+pattern DirSym   f <- (dirSym  -> (True, f))
+
+-- |Matches on any non-directory kind of files or symlinks pointing to
+-- such.
+-- If the symlink is pointing to a symlink pointing to such a file, then
+-- it will return True, but also return the first element in the symlink-
+-- chain, not the last.
+pattern AFileLikeOrSym f <- (safileLike -> (True, f))
+pattern FileLikeOrSym  f <- (sfileLike  -> (True, f))
+
+-- |Matches on any non-directory kind of files, excluding symlinks.
+pattern AFileLike f <- (afileLike -> (True, f))
+pattern FileLike  f <- (fileLike  -> (True, f))
+
+-- |Matches on symlinks pointing to file-like files only.
+pattern AFileLikeSym f <- (afileLikeSym -> (True, f))
+pattern FileLikeSym  f <- (fileLikeSym  -> (True, f))
+
+-- |Matches on broken symbolic links.
+pattern ABrokenSymlink f <- (abrokenSymlink -> (True, f))
+pattern BrokenSymlink  f <- (brokenSymlink  -> (True, f))
+
+
+
+    -----------------
+    --[ INSTANCES ]--
+    -----------------
+
+
+-- | First compare constructors: Failed < Dir < File...
+-- Then compare `name`...
+-- Then compare free variable parameter of `File` constructors
+instance Ord (File FileInfo) where
+    compare (RegFile n a) (RegFile n' a') =
+        case compare n n' of
+             EQ -> compare a a'
+             el -> el
+    compare (Dir n b) (Dir n' b') =
+        case compare n n' of
+             EQ -> compare b b'
+             el -> el
+     -- after comparing above we can hand off to shape ord function:
+    compare d d' = comparingConstr d d'
+
+
+-- |First compare anchor, then compare File.
+instance Ord (AnchoredFile FileInfo) where
+  compare (bp1 :/ a) (bp2 :/ b) =
+    case compare bp1 bp2 of
+      EQ -> compare a b
+      el -> el
+
+
+
+
+
+    ----------------------------
+    --[ HIGH LEVEL FUNCTIONS ]--
+    ----------------------------
+
+
+-- |Read a file into an `AnchoredFile`, filling the free variables via
+-- the given function.
+readFileWith :: (FilePath -> IO a)
+             -> FilePath
+             -> IO (AnchoredFile a)
+readFileWith ff p = do
+  let fn = topDir p
+      bd = baseDir p
+  handleDT' bd fn $ do
+    fs  <- PF.getSymbolicLinkStatus p
+    fv  <- ff p
+    file <- constructFile fs fv bd fn
+    return (bd :/ file)
+  where
+    constructFile fs fv bd' n
+      | PF.isSymbolicLink    fs = do
+          -- symlink madness, we need to make sure we save the correct
+          -- AnchoredFile
+          let fp = bd' </> n
+          resolvedSyml <- handleDT' bd' n $ do
+            sfp <- (\x -> if isAbsolute x then x else bd' </> x)
+                     <$> PF.readSymbolicLink fp
+            _ <- PF.getFileStatus sfp -- important to break infinite symbolic
+                                      -- link cycle
+            readFileWith ff sfp
+          return $ SymLink n fv resolvedSyml
+      | PF.isDirectory       fs = return $ Dir       n fv
+      | PF.isRegularFile     fs = return $ RegFile   n fv
+      | PF.isBlockDevice     fs = return $ BlockDev  n fv
+      | PF.isCharacterDevice fs = return $ CharDev   n fv
+      | PF.isNamedPipe       fs = return $ NamedPipe n fv
+      | PF.isSocket          fs = return $ Socket    n fv
+      | otherwise               = return $ Failed    n (userError
+                                                        "Unknown filetype!")
+
+
+readFile :: FilePath -> IO (AnchoredFile FileInfo)
+readFile fp = readFileWith getFileInfo $ normalize fp
+
+
+-- |Build a list of AnchoredFile, given the path to a directory, filling
+-- the free variables via `getFileInfo`. This includes the "." and ".."
+-- directories.
+readDirectory :: FilePath -> IO [AnchoredFile FileInfo]
+readDirectory fp = readDirectoryWith getAllDirsFiles getFileInfo
+                     $ normalize fp
+
+
+-- |Build a list of AnchoredFile, given the path to a directory, filling
+-- the free variables via `getFileInfo`. This excludes the "." and ".."
+-- directories.
+readDirectory' :: FilePath -> IO [AnchoredFile FileInfo]
+readDirectory' fp = readDirectoryWith getDirsFiles getFileInfo
+                      $ normalize fp
+
+
+-- | same as readDirectory but allows us to, for example, use
+-- ByteString.readFile to return a tree of ByteStrings.
+readDirectoryWith :: (FilePath -> IO [FilePath])
+                  -> (FilePath -> IO a)
+                  -> FilePath
+                  -> IO [AnchoredFile a]
+readDirectoryWith getfiles ff p = do
+  contents <- getfiles $ normalize p
+  cs <- mapM (\x -> readFileWith ff $ p </> x) contents
+  return $ removeNonexistent cs
+
+
+
+
+
+    -----------------
+    --[ UTILITIES ]--
+    -----------------
+
+
+
+---- HANDLING FAILURES ----
+
+
+-- | True if any Failed constructors in the tree
+anyFailed :: [File a] -> Bool
+anyFailed = not . successful
+
+-- | True if there are no Failed constructors in the tree
+successful :: [File a] -> Bool
+successful = null . failures
+
+
+-- | returns true if argument is a `Failed` constructor:
+failed :: File a -> Bool
+failed (Failed _ _) = True
+failed _            = False
+
+
+-- | returns a list of 'Failed' constructors only:
+failures :: [File a] -> [File a]
+failures = filter failed
+
+
+
+---- ORDERING AND EQUALITY ----
+
+
+ -- HELPER: a non-recursive comparison
+comparingConstr :: File FileInfo -> File FileInfo -> Ordering
+comparingConstr (Failed _ _)      (DirOrSym _)      = LT
+comparingConstr (Failed _ _)      (FileLikeOrSym _) = LT
+comparingConstr (FileLikeOrSym _) (Failed _ _)      = GT
+comparingConstr (FileLikeOrSym _) (DirOrSym _)      = GT
+comparingConstr (DirOrSym _)      (Failed _ _)      = GT
+comparingConstr (DirOrSym _)      (FileLikeOrSym _) = LT
+ -- else compare on the names of constructors that are the same, without
+ -- looking at the contents of Dir constructors:
+comparingConstr t t'  = compare (name t) (name t')
+
+
+
+
+---- OTHER ----
+
+
+
+    ---------------
+    --[ HELPERS ]--
+    ---------------
+
+
+---- CONSTRUCTOR IDENTIFIERS ----
+
+isFileC :: File a -> Bool
+isFileC (RegFile _ _) = True
+isFileC _             = False
+
+
+isDirC :: File a -> Bool
+isDirC (Dir _ _) = True
+isDirC _         = False
+
+
+isSymC :: File a -> Bool
+isSymC (SymLink _ _ _) = True
+isSymC _               = False
+
+
+isBlockC :: File a -> Bool
+isBlockC (BlockDev _ _) = True
+isBlockC _              = False
+
+
+isCharC :: File a -> Bool
+isCharC (CharDev _ _) = True
+isCharC _             = False
+
+
+
+isNamedC :: File a -> Bool
+isNamedC (NamedPipe _ _) = True
+isNamedC _               = False
+
+
+isSocketC :: File a -> Bool
+isSocketC (Socket _ _) = True
+isSocketC _            = False
+
+
+
+---- PATH CONVERSIONS ----
+
+
+
+-- extracting pathnames and base names:
+topDir, baseDir :: FilePath -> FilePath
+topDir = last . splitDirectories
+baseDir = joinPath . init . splitDirectories
+
+
+-- |Check whether the given file is a hidden file.
+hiddenFile :: FilePath -> Bool
+hiddenFile "."  = False
+hiddenFile ".." = False
+hiddenFile str
+  | "." `isPrefixOf` str = True
+  | otherwise            = False
+
+
+-- |Like `normalise` from System.FilePath but removes occurences of '..'.
+-- Note that this sort of misbehaves if the path contains symlink
+-- components.
+normalize :: FilePath -> FilePath
+normalize fp =
+  joinPath $ foldl' ff [] (splitDirectories . normalise $ fp)
+  where
+    ff ["/"] ".." = ["/"]
+    ff x ".."     = initDef [] x
+    ff x y        = x ++ [y]
+
+
+
+---- IO HELPERS: ----
+
+
+-- |Go up one directory in the filesystem hierarchy.
+goUp :: AnchoredFile FileInfo -> IO (AnchoredFile FileInfo)
+goUp af@("" :/ _) = return af
+goUp    (bp :/ _) = Data.DirTree.readFile bp
+
+
+-- |Go up one directory in the filesystem hierarchy.
+goUp' :: FilePath -> IO (AnchoredFile FileInfo)
+goUp' fp = do
+  let cfp = normalize fp
+  Data.DirTree.readFile $ baseDir cfp
+
+
+-- |Get the contents of a directory.
+getContents :: AnchoredFile FileInfo
+            -> IO [AnchoredFile FileInfo]
+getContents (ADirOrSym af) = readDirectory (fullPath af)
+getContents _              = return []
+
+
+-- |Get all files of a given directory and return them as a List.
+-- This includes "." and "..".
+getAllDirsFiles :: FilePath -> IO [FilePath]
+getAllDirsFiles fp = do
+  dirstream <- PFD.openDirStream fp
+  let mdirs :: [FilePath] -> IO [FilePath]
+      mdirs dirs = do
+        dir <- PFD.readDirStream dirstream
+        if dir == ""
+          then return dirs
+          else mdirs (dir : dirs)
+  dirs <- mdirs []
+  PFD.closeDirStream dirstream
+  return dirs
+
+
+-- |Get all files of a given directory and return them as a List.
+-- This excludes "." and "..".
+getDirsFiles :: FilePath -> IO [FilePath]
+getDirsFiles fp = do
+  dirstream <- PFD.openDirStream fp
+  let mdirs :: [FilePath] -> IO [FilePath]
+      mdirs dirs = do
+        dir <- PFD.readDirStream dirstream
+        if dir == ""
+          then return dirs
+          else mdirs (insert dir dirs)
+  dirs <- mdirs []
+  PFD.closeDirStream dirstream
+  return dirs
+  where
+    insert dir dirs = case dir of
+      "."  -> dirs
+      ".." -> dirs
+      _    -> dir : dirs
+
+
+-- |Gets all file information.
+getFileInfo :: FilePath -> IO FileInfo
+getFileInfo fp = do
+  fs <- PF.getSymbolicLinkStatus fp
+  return $ FileInfo
+    (PF.deviceID fs)
+    (PF.fileID fs)
+    (PF.fileMode fs)
+    (PF.linkCount fs)
+    (PF.fileOwner fs)
+    (PF.fileGroup fs)
+    (PF.specialDeviceID fs)
+    (PF.fileSize fs)
+    (PF.accessTime fs)
+    (PF.modificationTime fs)
+    (PF.statusChangeTime fs)
+    (PF.accessTimeHiRes fs)
+    (PF.modificationTimeHiRes fs)
+    (PF.statusChangeTimeHiRes fs)
+
+
+-- |Gets the free variable. Returns Nothing if the constructor is of `Failed`.
+getFreeVar :: File a -> Maybe a
+getFreeVar (Dir _  d)       = Just d
+getFreeVar (RegFile _  d)   = Just d
+getFreeVar (SymLink _  d _) = Just d
+getFreeVar (BlockDev _  d)  = Just d
+getFreeVar (CharDev _  d)   = Just d
+getFreeVar (NamedPipe _  d) = Just d
+getFreeVar (Socket _  d)    = Just d
+getFreeVar _                = Nothing
+
+
+---- FAILURE HELPERS: ----
+
+
+-- handles an IO exception by returning a Failed constructor filled with that
+-- exception:
+handleDT :: FileName -> IO (File a) -> IO (File a)
+handleDT n = handle (return . Failed n)
+
+
+-- handles an IO exception by returning a Failed constructor filled with that
+-- exception:
+handleDT' :: FilePath -> FileName -> IO (AnchoredFile a) -> IO (AnchoredFile a)
+handleDT' bp n = handle (\e -> return $ bp :/ Failed n e)
+
+
+-- DoesNotExist errors not present at the topmost level could happen if a
+-- named file or directory is deleted after being listed by
+-- getDirectoryContents but before we can get it into memory.
+--    So we filter those errors out because the user should not see errors
+-- raised by the internal implementation of this module:
+--     This leaves the error if it exists in the top (user-supplied) level:
+removeNonexistent :: [AnchoredFile a] -> [AnchoredFile a]
+removeNonexistent = filter isOkConstructor
+  where
+    isOkConstructor (_ :/ c) = not (failed c) || isOkError c
+    isOkError = not . isDoesNotExistErrorType . ioeGetErrorType . err
+
+
+---- SYMLINK HELPERS: ----
+
+
+-- |Follows a chain of symlinks until it finds a non-symlink. Note that
+-- this can be caught in an infinite loop if the symlinks haven't been
+-- constructed properly. This module however ensures that this cannot
+-- happen.
+followSymlink :: File FileInfo -> File FileInfo
+followSymlink (SymLink _ _ (_ :/ b@(SymLink {}))) = followSymlink b
+followSymlink af                                  = af
+
+
+-- |Checks if a symlink is broken by examining the constructor of the
+-- symlink destination. This also follows the symlink chain.
+--
+-- When called on a non-symlink, returns False.
+isBrokenSymlink :: File FileInfo -> Bool
+isBrokenSymlink af@(SymLink _ _ (_ :/ Failed {})) = True
+isBrokenSymlink af@(SymLink {})
+  = case followSymlink af of
+      (Failed {}) -> True
+      _           -> False
+isBrokenSymlink _ = False
+
+
+---- OTHER: ----
+
+
+
+fullPath :: AnchoredFile a -> FilePath
+fullPath (bp :/ f) = bp </> name f
+
+
+-- |Apply a function on the free variable. If there is no free variable
+-- for the given constructor the value from the `Default` class is used.
+fromFreeVar :: (Default d) => (a -> d) -> File a -> d
+fromFreeVar f df = maybeD f $ getFreeVar df
+
+
+-- |A `maybe` flavor using the `Default` class.
+maybeD :: (Default b) => (a -> b) -> Maybe a -> b
+maybeD = maybe def
+
+
+-- |Pack the modification time into a string.
+packModTime :: File FileInfo
+            -> String
+packModTime = fromFreeVar
+                $ show . posixSecondsToUTCTime . realToFrac . modificationTime
+
+
+-- |Pack the permissions into a string, similar to what "ls -l" does.
+packPermissions :: File FileInfo
+                -> String
+packPermissions dt = fromFreeVar (pStr . fileMode) dt
+  where
+    pStr ffm = typeModeStr ++ ownerModeStr ++ groupModeStr ++ otherModeStr
+      where
+        typeModeStr
+          | hasFM PF.regularFileMode      = "-"
+          | hasFM PF.directoryMode        = "d"
+          | hasFM PF.symbolicLinkMode     = "l"
+          | hasFM PF.socketMode           = "s"
+          | hasFM PF.blockSpecialMode     = "b"
+          | hasFM PF.characterSpecialMode = "c"
+          | hasFM PF.namedPipeMode        = "p"
+        ownerModeStr =    hasFmStr PF.ownerReadMode    "r"
+                       ++ hasFmStr PF.ownerWriteMode   "w"
+                       ++ hasFmStr PF.ownerExecuteMode "x"
+        groupModeStr =    hasFmStr PF.groupReadMode    "r"
+                       ++ hasFmStr PF.groupWriteMode   "w"
+                       ++ hasFmStr PF.groupExecuteMode "x"
+        otherModeStr =    hasFmStr PF.otherReadMode    "r"
+                       ++ hasFmStr PF.otherWriteMode   "w"
+                       ++ hasFmStr PF.otherExecuteMode "x"
+        hasFmStr fm str
+          | hasFM fm  = str
+          | otherwise = "-"
+        hasFM fm = ffm `PF.intersectFileModes` fm == fm

src/GUI/Gtk.hs

@@ -0,0 +1,293 @@
+{--
+HSFM, a filemanager written in Haskell.
+Copyright (C) 2015 Julian Ospald
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+version 2 as published by the Free Software Foundation.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
+--}
+
+{-# OPTIONS_HADDOCK ignore-exports #-}
+
+module Main where
+
+import Control.Applicative
+  (
+    (<$>)
+  , (<*>)
+  )
+import Control.Concurrent
+  (
+    forkIO
+  )
+import Control.Concurrent.MVar
+  (
+    newEmptyMVar
+  )
+import Control.Concurrent.STM
+  (
+    TVar
+  , newTVarIO
+  , readTVarIO
+  )
+import Control.Exception
+  (
+    try
+  , Exception
+  , SomeException
+  )
+import Control.Monad
+  (
+    when
+  , void
+  )
+import Control.Monad.IO.Class
+  (
+    liftIO
+  )
+import Data.DirTree
+import Data.Foldable
+  (
+    for_
+  )
+import Data.List
+  (
+    sort
+  , isPrefixOf
+  )
+import Data.Maybe
+  (
+    fromJust
+  , catMaybes
+  , fromMaybe
+  )
+import Data.Traversable
+  (
+    forM
+  )
+import Graphics.UI.Gtk
+import GUI.Gtk.Callbacks
+import GUI.Gtk.Data
+import GUI.Gtk.Dialogs
+import GUI.Gtk.Icons
+import GUI.Gtk.Utils
+import IO.Error
+import IO.File
+import IO.Utils
+import MyPrelude
+import Safe
+  (
+    headDef
+  )
+import System.Directory
+  (
+    doesFileExist
+  , doesDirectoryExist
+  )
+import System.Environment
+  (
+    getArgs
+  )
+import System.FilePath
+  (
+    isAbsolute
+  , (</>)
+  )
+import System.Glib.UTFString
+  (
+    glibToString
+  )
+import System.IO.Unsafe
+  (
+    unsafePerformIO
+  )
+import System.Process
+  (
+    spawnProcess
+  )
+
+
+-- TODO: simplify where we modify the TVars
+-- TODO: double check garbage collection/gtk ref counting
+-- TODO: file watching, when and what to reread
+
+
+main :: IO ()
+main = do
+  _ <- initGUI
+
+  args <- getArgs
+
+  startMainWindow (headDef "/" args)
+
+  _ <- mainGUI
+  return ()
+
+
+    -------------------------
+    --[ Main Window Setup ]--
+    -------------------------
+
+
+-- |Set up the GUI.
+--
+-- Interaction with mutable references:
+--
+-- * 'settings' creates
+-- * 'operationBuffer' creates
+-- * 'rawModel' creates
+-- * 'filteredModel' creates
+-- * 'sortedModel' creates
+startMainWindow :: FilePath -> IO ()
+startMainWindow startdir = do
+
+  settings <- newTVarIO (MkFMSettings False True)
+
+  inotify  <- newEmptyMVar
+
+  -- get the icons
+  iT           <- iconThemeGetDefault
+  folderPix    <- getIcon IFolder iT 24
+  folderSymPix <- getSymlinkIcon IFolder iT 24
+  filePix      <- getIcon IFile iT 24
+  fileSymPix   <- getSymlinkIcon IFile iT 24
+  errorPix     <- getIcon IError iT 24
+
+  operationBuffer <- newTVarIO None
+
+  builder <- builderNew
+  builderAddFromFile builder "data/Gtk/builder.xml"
+
+  -- get the pre-defined gui widgets
+  rootWin           <- builderGetObject builder castToWindow
+                       "rootWin"
+  scroll            <- builderGetObject builder castToScrolledWindow
+                       "mainScroll"
+  menubarFileQuit   <- builderGetObject builder castToImageMenuItem
+                       "menubarFileQuit"
+  menubarFileOpen   <- builderGetObject builder castToImageMenuItem
+                       "menubarFileOpen"
+  menubarFileExecute <- builderGetObject builder castToImageMenuItem
+                        "menubarFileExecute"
+  menubarFileNew    <- builderGetObject builder castToImageMenuItem
+                       "menubarFileNew"
+  menubarEditCut    <- builderGetObject builder castToImageMenuItem
+                       "menubarEditCut"
+  menubarEditCopy   <- builderGetObject builder castToImageMenuItem
+                       "menubarEditCopy"
+  menubarEditRename <- builderGetObject builder castToImageMenuItem
+                       "menubarEditRename"
+  menubarEditPaste  <- builderGetObject builder castToImageMenuItem
+                       "menubarEditPaste"
+  menubarEditDelete <- builderGetObject builder castToImageMenuItem
+                      "menubarEditDelete"
+  menubarHelpAbout  <- builderGetObject builder castToImageMenuItem
+                      "menubarHelpAbout"
+  urlBar            <- builderGetObject builder castToEntry
+                       "urlBar"
+  statusBar         <- builderGetObject builder castToStatusbar
+                       "statusBar"
+  rcMenu            <- builderGetObject builder castToMenu
+                       "rcMenu"
+  rcFileOpen        <- builderGetObject builder castToImageMenuItem
+                       "rcFileOpen"
+  rcFileExecute     <- builderGetObject builder castToImageMenuItem
+                       "rcFileExecute"
+  rcFileNew         <- builderGetObject builder castToImageMenuItem
+                       "rcFileNew"
+  rcFileCut         <- builderGetObject builder castToImageMenuItem
+                       "rcFileCut"
+  rcFileCopy        <- builderGetObject builder castToImageMenuItem
+                       "rcFileCopy"
+  rcFileRename      <- builderGetObject builder castToImageMenuItem
+                       "rcFileRename"
+  rcFilePaste       <- builderGetObject builder castToImageMenuItem
+                       "rcFilePaste"
+  rcFileDelete      <- builderGetObject builder castToImageMenuItem
+                       "rcFileDelete"
+  refreshView       <- builderGetObject builder castToButton
+                       "refreshView"
+
+  -- create initial list store model with unsorted data
+  -- we check that the startdir passed by the user is valid
+  -- TODO: maybe move this to a separate function
+  sd <- (\x -> if (failed . file $ x) || (not . isAbsolute . anchor $ x)
+                 then Data.DirTree.readFile "/"
+                 else return x) =<< Data.DirTree.readFile startdir
+  rawModel <- newTVarIO =<< listStoreNew
+                        =<< Data.DirTree.getContents sd
+
+  filteredModel <- newTVarIO =<< (\x -> treeModelFilterNew x [])
+                           =<< readTVarIO rawModel
+
+  -- create an initial sorting proxy model
+  sortedModel <- newTVarIO =<< treeModelSortNewWithModel
+                           =<< readTVarIO filteredModel
+
+  -- create the final view
+  treeView <- treeViewNew
+
+  -- create final tree model columns
+  renderTxt <- cellRendererTextNew
+  renderPix <- cellRendererPixbufNew
+  let ct = cellText   :: (CellRendererTextClass cr) => Attr cr String
+      cp = cellPixbuf :: (CellRendererPixbufClass self) => Attr self Pixbuf
+
+  -- filename column
+  cF <- treeViewColumnNew
+  treeViewColumnSetTitle        cF "Filename"
+  treeViewColumnSetResizable    cF True
+  treeViewColumnSetClickable    cF True
+  treeViewColumnSetSortColumnId cF 1
+  cellLayoutPackStart cF renderPix False
+  cellLayoutPackStart cF renderTxt True
+  _ <- treeViewAppendColumn treeView cF
+  cellLayoutAddColumnAttribute cF renderPix cp $ makeColumnIdPixbuf 0
+  cellLayoutAddColumnAttribute cF renderTxt ct $ makeColumnIdString 1
+
+  -- date column
+  cMD <- treeViewColumnNew
+  treeViewColumnSetTitle        cMD "Date"
+  treeViewColumnSetResizable    cMD True
+  treeViewColumnSetClickable    cMD True
+  treeViewColumnSetSortColumnId cMD 2
+  cellLayoutPackStart cMD renderTxt True
+  _ <- treeViewAppendColumn treeView cMD
+  cellLayoutAddColumnAttribute cMD renderTxt ct $ makeColumnIdString 2
+
+  -- permissions column
+  cP <- treeViewColumnNew
+  treeViewColumnSetTitle        cP "Permission"
+  treeViewColumnSetResizable    cP True
+  treeViewColumnSetClickable    cP True
+  treeViewColumnSetSortColumnId cP 3
+  cellLayoutPackStart cP renderTxt True
+  _ <- treeViewAppendColumn treeView cP
+  cellLayoutAddColumnAttribute cP renderTxt ct $ makeColumnIdString 3
+
+  -- construct the gui object
+  let mygui  = MkMyGUI {..}
+  let myview = MkMyView {..}
+
+  -- create the tree model with its contents
+  constructTreeView mygui myview
+
+  -- set the bindings
+  setCallbacks mygui myview
+
+  -- add the treeview to the scroll container
+  containerAdd scroll treeView
+
+  -- sets the default icon
+  windowSetDefaultIconFromFile "data/Gtk/icons/hsfm.png"
+
+  widgetShowAll rootWin

src/GUI/Gtk/Callbacks.hs

@@ -0,0 +1,288 @@
+{--
+HSFM, a filemanager written in Haskell.
+Copyright (C) 2015 Julian Ospald
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+version 2 as published by the Free Software Foundation.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
+--}
+
+{-# OPTIONS_HADDOCK ignore-exports #-}
+
+module GUI.Gtk.Callbacks where
+
+
+import Control.Applicative
+  (
+    (<$>)
+  , (<*>)
+  )
+import Control.Concurrent.STM
+  (
+    TVar
+  , newTVarIO
+  , readTVarIO
+  )
+import Control.Monad
+  (
+    void
+  )
+import Control.Monad.IO.Class
+  (
+    liftIO
+  )
+import Data.DirTree
+import Data.Foldable
+  (
+    for_
+  )
+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
+  )
+
+
+
+
+
+    -----------------
+    --[ Callbacks ]--
+    -----------------
+
+
+-- |Set callbacks, on hotkeys, events and stuff.
+--
+-- Interaction with mutable references:
+--
+-- * 'settings mygui' modifies
+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
+    cdir <- liftIO $ getCurrentDir myview
+    liftIO $ modifyTVarIO (settings mygui)
+                          (\x -> x { showHidden = not . showHidden $ x})
+             >> refreshTreeView' mygui myview cdir
+  _ <- 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)
+  _ <- 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
+    "x"       <- fmap glibToString eventKeyName
+    liftIO $ withRow mygui myview moveInit
+  _ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
+    [Control] <- eventModifier
+    "v"       <- fmap glibToString eventKeyName
+    liftIO $ operationFinal mygui myview
+
+  _ <- refreshView mygui `on` buttonActivated $ do
+       cdir <- liftIO $ getCurrentDir myview
+       refreshTreeView' mygui myview cdir
+
+  -- menubar-file
+  _ <- menubarFileQuit mygui `on` menuItemActivated $ mainQuit
+  _ <- menubarFileOpen mygui `on` menuItemActivated $
+    liftIO $ withRow mygui myview open
+  _ <- menubarFileExecute mygui `on` menuItemActivated $
+    liftIO $ withRow mygui myview execute
+  _ <- menubarFileNew mygui `on` menuItemActivated $
+    liftIO $ newFile mygui myview
+
+  -- menubar-edit
+  _ <- menubarEditCut mygui `on` menuItemActivated $
+    liftIO $ withRow mygui myview moveInit
+  _ <- menubarEditCopy mygui `on` menuItemActivated $
+    liftIO $ withRow mygui myview copyInit
+  _ <- menubarEditRename mygui `on` menuItemActivated $
+    liftIO $ withRow mygui myview renameF
+  _ <- menubarEditPaste mygui `on` menuItemActivated $
+    liftIO $ operationFinal mygui myview
+  _ <- menubarEditDelete mygui `on` menuItemActivated $
+    liftIO $ withRow mygui myview del
+
+  -- menubar-help
+  _ <- menubarHelpAbout mygui `on` menuItemActivated $
+    liftIO showAboutDialog
+
+  -- righ-click
+  _ <- treeView mygui `on` buttonPressEvent $ do
+    eb <- eventButton
+    t  <- eventTime
+    case eb of
+      RightButton -> liftIO $ menuPopup (rcMenu mygui) $ Just (RightButton, t)
+      _           -> return ()
+    return False
+  _ <- rcFileOpen mygui `on` menuItemActivated $
+    liftIO $ withRow mygui myview open
+  _ <- rcFileExecute mygui `on` menuItemActivated $
+    liftIO $ withRow mygui myview execute
+  _ <- rcFileNew mygui `on` menuItemActivated $
+    liftIO $ newFile mygui myview
+  _ <- rcFileCopy mygui `on` menuItemActivated $
+    liftIO $ withRow mygui myview copyInit
+  _ <- rcFileRename mygui `on` menuItemActivated $
+    liftIO $ withRow mygui myview renameF
+  _ <- rcFilePaste mygui `on` menuItemActivated $
+    liftIO $ operationFinal mygui myview
+  _ <- rcFileDelete mygui `on` menuItemActivated $
+    liftIO $ withRow mygui myview del
+  _ <- rcFileCut mygui `on` menuItemActivated $
+    liftIO $ withRow mygui myview moveInit
+
+
+  return ()
+
+
+-- |Go to the url given at the 'urlBar' and visualize it in the given
+-- treeView.
+urlGoTo :: MyGUI -> MyView -> IO ()
+urlGoTo mygui myview = withErrorDialog $ 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.
+open :: Row -> MyGUI -> MyView -> IO ()
+open row mygui myview = withErrorDialog $
+  case row of
+    ADirOrSym r -> do
+      nv <- Data.DirTree.readFile $ fullPath r
+      refreshTreeView' mygui myview nv
+    r ->
+      void $ openFile r
+
+
+-- |Execute a given file.
+execute :: Row -> MyGUI -> MyView -> IO ()
+execute row mygui myview = withErrorDialog $
+  void $ executeFile row []
+
+
+-- |Supposed to be used with 'withRow'. Deletes a file or directory.
+del :: Row -> MyGUI -> MyView -> IO ()
+del row mygui myview = withErrorDialog $ do
+  let cmsg  = "Really delete \"" ++ fullPath row ++ "\"?"
+  withConfirmationDialog cmsg
+    $ easyDelete row
+
+
+-- |Initializes a file move operation.
+--
+-- Interaction with mutable references:
+--
+-- * 'operationBuffer' writes
+moveInit :: Row -> MyGUI -> MyView -> IO ()
+moveInit row mygui myview =
+  writeTVarIO (operationBuffer myview) (FMove . MP1 $ row)
+
+
+-- |Supposed to be used with 'withRow'. Initializes a file copy operation.
+--
+-- Interaction with mutable references:
+--
+-- * 'operationBuffer' writes
+copyInit :: Row -> MyGUI -> MyView -> IO ()
+copyInit row mygui myview =
+  writeTVarIO (operationBuffer myview) (FCopy . CP1 $ row)
+
+
+-- |Finalizes a file operation, such as copy or move.
+--
+-- Interaction with mutable references:
+--
+-- * 'operationBuffer' reads
+operationFinal :: MyGUI -> MyView -> IO ()
+operationFinal mygui myview = withErrorDialog $ do
+  op <- readTVarIO (operationBuffer myview)
+  cdir <- getCurrentDir myview
+  case op of
+    FMove (MP1 s) -> do
+      let cmsg = "Really move \"" ++ fullPath s
+                  ++ "\"" ++ " to \"" ++ fullPath cdir ++ "\"?"
+      withConfirmationDialog cmsg
+        $ void $ runFileOp (FMove . MC s $ cdir)
+      return ()
+    FCopy (CP1 s) -> do
+      let cmsg = "Really copy \"" ++ fullPath s
+                 ++ "\"" ++ " to \"" ++ fullPath cdir ++ "\"?"
+      cm <- showCopyModeChooserDialog
+      withConfirmationDialog cmsg
+        $ void $ runFileOp (FCopy . CC s cdir $ cm)
+      return ()
+    _ -> return ()
+
+
+-- |Go up one directory and visualize it in the treeView.
+--
+-- Interaction with mutable references:
+--
+-- * 'rawModel' reads
+-- * 'sortedModel' reads
+upDir :: MyGUI -> MyView -> IO ()
+upDir mygui myview = withErrorDialog $ do
+  cdir <- getCurrentDir myview
+  rawModel'    <- readTVarIO $ rawModel myview
+  sortedModel' <- readTVarIO $ sortedModel myview
+  nv <- goUp cdir
+  refreshTreeView' mygui myview nv
+
+
+-- |Go up one directory and visualize it in the treeView.
+newFile :: MyGUI -> MyView -> IO ()
+newFile mygui myview = withErrorDialog $ do
+  mfn   <- textInputDialog "Enter file name"
+  for_ mfn $ \fn -> do
+    cdir  <- getCurrentDir myview
+    createFile cdir fn
+
+
+renameF :: Row -> MyGUI -> MyView -> IO ()
+renameF row mygui myview = withErrorDialog $ do
+  mfn   <- textInputDialog "Enter new file name"
+  for_ mfn $ \fn -> do
+    let cmsg = "Really rename \"" ++ fullPath row
+               ++ "\"" ++ " to \"" ++ anchor row </> fn ++ "\"?"
+    withConfirmationDialog cmsg $ IO.File.renameFile row fn

src/GUI/Gtk/Data.hs

@@ -0,0 +1,111 @@
+{--
+HSFM, a filemanager written in Haskell.
+Copyright (C) 2015 Julian Ospald
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+version 2 as published by the Free Software Foundation.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
+--}
+
+{-# OPTIONS_HADDOCK ignore-exports #-}
+
+module GUI.Gtk.Data where
+
+
+import Control.Concurrent.MVar
+  (
+    MVar
+  )
+import Control.Concurrent.STM
+  (
+    TVar
+  )
+import Data.DirTree
+import Graphics.UI.Gtk
+import IO.File
+import System.INotify
+  (
+    INotify
+  )
+
+
+
+    ------------------
+    --[ Base Types ]--
+    ------------------
+
+
+-- |Monolithic object passed to various GUI functions in order
+-- to keep the API stable and not alter the parameters too much.
+-- This only holds GUI widgets that are needed to be read during
+-- runtime.
+data MyGUI = MkMyGUI {
+  -- |main Window
+    rootWin  :: Window
+  , menubarFileQuit :: ImageMenuItem
+  , menubarFileOpen :: ImageMenuItem
+  , menubarFileExecute :: ImageMenuItem
+  , menubarFileNew :: ImageMenuItem
+  , menubarEditCut :: ImageMenuItem
+  , menubarEditCopy :: ImageMenuItem
+  , menubarEditRename :: ImageMenuItem
+  , menubarEditPaste :: ImageMenuItem
+  , menubarEditDelete :: ImageMenuItem
+  , menubarHelpAbout :: ImageMenuItem
+  , rcMenu :: Menu
+  , rcFileOpen :: ImageMenuItem
+  , rcFileExecute :: ImageMenuItem
+  , rcFileNew :: ImageMenuItem
+  , rcFileCut :: ImageMenuItem
+  , rcFileCopy :: ImageMenuItem
+  , rcFileRename :: ImageMenuItem
+  , rcFilePaste :: ImageMenuItem
+  , rcFileDelete :: ImageMenuItem
+  , refreshView :: Button
+  , urlBar :: Entry
+  , statusBar :: Statusbar
+  , treeView :: TreeView
+  -- |first column
+  , cF :: TreeViewColumn
+  -- |second column
+  , cMD :: TreeViewColumn
+  , renderTxt :: CellRendererText
+  , renderPix :: CellRendererPixbuf
+  , settings :: TVar FMSettings
+  , folderPix :: Pixbuf
+  , folderSymPix :: Pixbuf
+  , filePix :: Pixbuf
+  , fileSymPix :: Pixbuf
+  , errorPix :: Pixbuf
+}
+
+
+-- |FM-wide settings.
+data FMSettings = MkFMSettings {
+    showHidden :: Bool
+  , isLazy :: Bool
+}
+
+
+type Row = AnchoredFile FileInfo
+
+
+-- |This describes the contents of the treeView and is separated from MyGUI,
+-- because we might want to have multiple views.
+data MyView = MkMyView {
+    rawModel :: TVar (ListStore Row)
+  , sortedModel :: TVar (TypedTreeModelSort Row)
+  , filteredModel :: TVar (TypedTreeModelFilter Row)
+  , operationBuffer :: TVar FileOperation
+  , inotify :: MVar INotify
+}
+

src/GUI/Gtk/Dialogs.hs

@@ -0,0 +1,183 @@
+{--
+HSFM, a filemanager written in Haskell.
+Copyright (C) 2015 Julian Ospald
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+version 2 as published by the Free Software Foundation.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
+--}
+
+{-# OPTIONS_HADDOCK ignore-exports #-}
+
+module GUI.Gtk.Dialogs where
+
+
+import Control.Applicative
+  (
+    (<$>)
+  )
+import Control.Exception
+  (
+    try
+  , SomeException
+  )
+import Control.Monad
+  (
+    when
+  , void
+  )
+import Data.Version
+  (
+    showVersion
+  )
+import Distribution.Package
+  (
+    PackageIdentifier(..)
+  , PackageName(..)
+  )
+import Distribution.PackageDescription
+  (
+    GenericPackageDescription(..)
+  , PackageDescription(..)
+  )
+import Distribution.PackageDescription.Parse
+  (
+    readPackageDescription
+  )
+import Distribution.Verbosity
+  (
+    silent
+  )
+import Graphics.UI.Gtk
+import GUI.Gtk.Data
+import IO.File
+
+
+
+
+
+    ---------------------
+    --[ Dialog popups ]--
+    ---------------------
+
+
+-- |Pops up an error Dialog with the given String.
+showErrorDialog :: String -> IO ()
+showErrorDialog str = do
+  errorDialog <- messageDialogNew Nothing
+                                  [DialogDestroyWithParent]
+                                  MessageError
+                                  ButtonsClose
+                                  str
+  _ <- dialogRun errorDialog
+  widgetDestroy errorDialog
+
+
+-- |Asks the user for confirmation and returns True/False.
+showConfirmationDialog :: String -> IO Bool
+showConfirmationDialog str = do
+  confirmDialog <- messageDialogNew Nothing
+                                    [DialogDestroyWithParent]
+                                    MessageQuestion
+                                    ButtonsYesNo
+                                    str
+  rID <- dialogRun confirmDialog
+  widgetDestroy confirmDialog
+  case rID of
+    ResponseYes -> return True
+    ResponseNo  -> return False
+    _           -> return False
+
+
+-- |Asks the user which directory copy mode he wants via dialog popup
+-- and returns 'DirCopyMode'.
+showCopyModeChooserDialog :: IO DirCopyMode
+showCopyModeChooserDialog = do
+  chooserDialog <- messageDialogNew Nothing
+                                    [DialogDestroyWithParent]
+                                    MessageQuestion
+                                    ButtonsNone
+                                    "Choose the copy mode"
+  dialogAddButton chooserDialog "Strict"  (ResponseUser 0)
+  dialogAddButton chooserDialog "Merge"   (ResponseUser 1)
+  dialogAddButton chooserDialog "Replace" (ResponseUser 2)
+  rID <- dialogRun chooserDialog
+  widgetDestroy chooserDialog
+  case rID of
+    ResponseUser 0 -> return Strict
+    ResponseUser 1 -> return Merge
+    ResponseUser 2 -> return Replace
+
+
+-- |Shows the about dialog from the help menu.
+showAboutDialog :: IO ()
+showAboutDialog = do
+  ad       <- aboutDialogNew
+  lstr     <- readFile "LICENSE"
+  hsfmicon <- pixbufNewFromFile "data/Gtk/icons/hsfm.png"
+  pdesc    <- packageDescription <$> readPackageDescription silent "hsfm.cabal"
+  set ad
+    [ aboutDialogProgramName  := (unPackageName . pkgName . package) pdesc
+    , aboutDialogName         := (unPackageName . pkgName . package) pdesc
+    , aboutDialogVersion      := (showVersion . pkgVersion . package) pdesc
+    , aboutDialogCopyright    := copyright pdesc
+    , aboutDialogComments     := description pdesc
+    , aboutDialogLicense      := Just lstr
+    , aboutDialogWebsite      := homepage pdesc
+    , aboutDialogAuthors      := [author pdesc]
+    , aboutDialogLogo         := Just hsfmicon
+    , aboutDialogWrapLicense  := True
+    ]
+  _ <- dialogRun ad
+  widgetDestroy ad
+
+
+-- |Carry out an IO action with a confirmation dialog.
+-- If the user presses "No", then do nothing.
+withConfirmationDialog :: String -> IO () -> IO ()
+withConfirmationDialog str io = do
+  run <- showConfirmationDialog str
+  when run io
+
+
+-- |Execute the given IO action. If the action throws exceptions,
+-- visualize them via 'showErrorDialog'.
+withErrorDialog :: IO a -> IO ()
+withErrorDialog io = do
+  r <- try io
+  either (\e -> showErrorDialog $ show (e :: SomeException))
+         (\_ -> return ())
+         r
+
+
+-- |Asks the user which directory copy mode he wants via dialog popup
+-- and returns 'DirCopyMode'.
+textInputDialog :: String -> IO (Maybe String)
+textInputDialog title = do
+  chooserDialog <- messageDialogNew Nothing
+                                    [DialogDestroyWithParent]
+                                    MessageQuestion
+                                    ButtonsNone
+                                    title
+  entry <- entryNew
+  cbox <- dialogGetActionArea chooserDialog
+  dialogAddButton chooserDialog "Ok"     (ResponseUser 0)
+  dialogAddButton chooserDialog "Cancel" (ResponseUser 1)
+  boxPackStart (castToBox cbox) entry PackNatural 5
+  widgetShowAll chooserDialog
+  rID <- dialogRun chooserDialog
+  ret <- case rID of
+           -- TODO: make this more safe
+           ResponseUser 0 -> Just <$> entryGetText entry
+           ResponseUser 1 -> return Nothing
+  widgetDestroy chooserDialog
+  return ret

src/GUI/Gtk/Icons.hs

@@ -1,6 +1,6 @@
 {--
 HSFM, a filemanager written in Haskell.
-Copyright (C) 2016 Julian Ospald
+Copyright (C) 2015 Julian Ospald
 
 This program is free software; you can redistribute it and/or
 modify it under the terms of the GNU General Public License
@@ -19,18 +19,11 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
 {-# OPTIONS_HADDOCK ignore-exports #-}
 
 -- |Module for Gtk icon handling.
-module HSFM.GUI.Gtk.Icons where
+module GUI.Gtk.Icons where
 
 
-import Data.Maybe
-  (
-    fromJust
-  )
 import Graphics.UI.Gtk
-import Paths_hsfm
+import Graphics.UI.Gtk.Gdk.Pixbuf
-  (
-    getDataFileName
-  )
 
 
 -- |Icon type we use in our GUI.
@@ -48,12 +41,10 @@ getIcon :: GtkIcon    -- ^ icon we want
         -> IO Pixbuf
 getIcon icon itheme isize = do
   let iname = iconToStr icon
-  hasicon <- iconThemeHasIcon itheme iname
+  mpix <- iconThemeLoadIcon itheme iname isize IconLookupUseBuiltin
-  case hasicon of
+  case mpix of
-    True -> fromJust <$> iconThemeLoadIcon itheme iname isize
+    Just pix -> return pix
-                                           IconLookupUseBuiltin
+    Nothing  -> pixbufNewFromFile ("data/Gtk/icons/" ++ iname)
-    False -> pixbufNewFromFile =<< getDataFileName
-                                    ("data/Gtk/icons/" ++ iname ++ ".png")
   where
     iconToStr IFolder = "gtk-directory"
     iconToStr IFile   = "gtk-file"

src/GUI/Gtk/Utils.hs

@@ -0,0 +1,294 @@
+{--
+HSFM, a filemanager written in Haskell.
+Copyright (C) 2015 Julian Ospald
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+version 2 as published by the Free Software Foundation.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
+--}
+
+{-# OPTIONS_HADDOCK ignore-exports #-}
+
+module GUI.Gtk.Utils where
+
+
+import Control.Applicative
+  (
+    (<$>)
+  )
+import Control.Concurrent.MVar
+  (
+    putMVar
+  , tryTakeMVar
+  )
+import Control.Concurrent.STM
+  (
+    TVar
+  , newTVarIO
+  , readTVarIO
+  )
+import Data.DirTree
+import Data.Foldable
+  (
+    for_
+  )
+import Data.List
+  (
+    isPrefixOf
+  )
+import Data.Maybe
+  (
+    fromMaybe
+  , fromJust
+  )
+import Data.Traversable
+  (
+    forM
+  )
+import Graphics.UI.Gtk
+import GUI.Gtk.Data
+import IO.Error
+import IO.Utils
+import MyPrelude
+import System.INotify
+  (
+    addWatch
+  , initINotify
+  , killINotify
+  , EventVariety(..)
+  , Event(..)
+  )
+
+
+
+
+    -----------------
+    --[ Utilities ]--
+    -----------------
+
+
+-- |Gets the currently selected row of the treeView, if any.
+--
+-- Interaction with mutable references:
+--
+-- * 'rawModel' reads
+-- * 'sortedModel' reads
+-- * 'filteredModel' reads
+getSelectedRow :: MyGUI
+               -> MyView
+               -> IO (Maybe Row)
+getSelectedRow mygui myview = do
+  (tp, _)        <- treeViewGetCursor $ treeView mygui
+  rawModel'      <- readTVarIO $ rawModel myview
+  sortedModel'   <- readTVarIO $ sortedModel myview
+  filteredModel' <- readTVarIO $ filteredModel myview
+  miter          <- treeModelGetIter sortedModel' tp
+  forM miter $ \iter -> do
+    cIter' <- treeModelSortConvertIterToChildIter sortedModel' iter
+    cIter  <- treeModelFilterConvertIterToChildIter filteredModel' cIter'
+    treeModelGetRow rawModel' cIter
+
+
+-- |Carry out an action on the currently selected row.
+--
+-- If there is no row selected, does nothing.
+withRow :: MyGUI
+        -> MyView
+        -> (   Row
+            -> MyGUI
+            -> MyView
+            -> IO ()) -- ^ action to carry out
+        -> IO ()
+withRow mygui myview io = do
+  mrow <- getSelectedRow mygui myview
+  for_ mrow $ \row -> io row mygui myview
+
+
+-- |Create the 'ListStore' of files/directories from the current directory.
+-- This is the function which maps the Data.DirTree data structures
+-- into the GTK+ data structures.
+fileListStore :: AnchoredFile FileInfo  -- ^ current dir
+              -> MyView
+              -> IO (ListStore Row)
+fileListStore dt myview = do
+  cs <- Data.DirTree.getContents dt
+  listStoreNew cs
+
+
+-- |Currently unsafe. This is used to obtain any row (possibly the '.' row)
+-- and extract the "current working directory" from it.
+--
+-- Interaction with mutable references:
+--
+-- * 'rawModel' reads
+getFirstRow :: MyView
+            -> IO (AnchoredFile FileInfo)
+getFirstRow myview = do
+  rawModel' <- readTVarIO $ rawModel myview
+  iter      <- fromJust <$> treeModelGetIterFirst rawModel'
+  treeModelGetRow rawModel' iter
+
+
+-- |Currently unsafe. Gets the current directory via `getFirstRow` and `goUp`.
+getCurrentDir :: MyView
+              -> IO (AnchoredFile FileInfo)
+getCurrentDir myview = getFirstRow myview >>= goUp
+
+
+-- |Re-reads the current directory or the given one and updates the TreeView.
+--
+-- The operation may fail with:
+--
+-- * 'DirDoesNotExist' if the target directory does not exist
+-- * 'PathNotAbsolute' if the target directory is not absolute
+--
+-- Interaction with mutable references:
+--
+-- * 'rawModel' writes
+refreshTreeView :: MyGUI
+                -> MyView
+                -> Maybe FilePath
+                -> IO ()
+refreshTreeView mygui myview mfp = do
+  mcdir <- getFirstRow myview
+  let fp  = fromMaybe (anchor mcdir) mfp
+
+  -- get selected rows
+  tvs   <- treeViewGetSelection (treeView mygui)
+  srows <- treeSelectionGetSelectedRows tvs
+
+  -- TODO catch exceptions
+  dirSanityThrow fp
+
+  newFsState  <- Data.DirTree.readFile fp
+  newRawModel <- fileListStore newFsState myview
+  writeTVarIO (rawModel myview) newRawModel
+
+  constructTreeView mygui myview
+
+  -- reselect selected rows
+  mapM_ (treeSelectionSelectPath tvs) srows
+
+
+-- |Refreshes the TreeView based on the given directory.
+--
+-- Interaction with mutable references:
+--
+-- * 'rawModel' writes
+refreshTreeView' :: MyGUI
+                 -> MyView
+                 -> AnchoredFile FileInfo
+                 -> IO ()
+refreshTreeView' mygui myview dt = do
+  newRawModel  <- fileListStore dt myview
+  writeTVarIO (rawModel myview) newRawModel
+
+  -- get selected rows
+  tvs   <- treeViewGetSelection (treeView mygui)
+  srows <- treeSelectionGetSelectedRows tvs
+
+  constructTreeView mygui myview
+
+  -- reselect selected rows
+  mapM_ (treeSelectionSelectPath tvs) srows
+
+
+-- TODO: make this function more slim so only the most necessary parts are
+-- called
+-- |Constructs the visible TreeView with the current underlying mutable models,
+-- which are retrieved from 'MyGUI'.
+--
+-- Interaction with mutable references:
+--
+-- * 'rawModel' reads
+-- * 'filteredModel' writes
+-- * 'sortedModel' writes
+-- * 'settings' reads
+constructTreeView :: MyGUI
+                  -> MyView
+                  -> IO ()
+constructTreeView mygui myview = do
+  let treeView' = treeView mygui
+      cF'       = cF mygui
+      cMD'      = cMD mygui
+      render'   = renderTxt mygui
+
+  cdirp <- anchor <$> getFirstRow myview
+
+  -- update urlBar
+  entrySetText (urlBar mygui) cdirp
+
+  rawModel' <- readTVarIO $ rawModel myview
+
+  -- filtering
+  filteredModel' <- treeModelFilterNew rawModel' []
+  writeTVarIO (filteredModel myview) filteredModel'
+  treeModelFilterSetVisibleFunc filteredModel' $ \iter -> do
+     hidden <- showHidden <$> readTVarIO (settings mygui)
+     row    <- (name . file) <$> treeModelGetRow rawModel' iter
+     if hidden
+       then return True
+       else return $ not . hiddenFile $ row
+
+  -- sorting
+  sortedModel' <- treeModelSortNewWithModel filteredModel'
+  writeTVarIO (sortedModel myview) sortedModel'
+  treeSortableSetSortFunc sortedModel' 1 $ \iter1 iter2 -> do
+      cIter1 <- treeModelFilterConvertIterToChildIter filteredModel' iter1
+      cIter2 <- treeModelFilterConvertIterToChildIter filteredModel' iter2
+      row1   <- treeModelGetRow rawModel' cIter1
+      row2   <- treeModelGetRow rawModel' cIter2
+      return $ compare row1 row2
+  treeSortableSetSortColumnId sortedModel' 1 SortAscending
+
+  -- set values
+  treeModelSetColumn rawModel' (makeColumnIdPixbuf 0)
+                     (dirtreePix . file)
+  treeModelSetColumn rawModel' (makeColumnIdString 1)
+                     (name . file)
+  treeModelSetColumn rawModel' (makeColumnIdString 2)
+                     (packModTime . file)
+  treeModelSetColumn rawModel' (makeColumnIdString 3)
+                     (packPermissions . file)
+
+  -- update treeview model
+  treeViewSetModel treeView' sortedModel'
+
+  -- add watcher
+  mi <- tryTakeMVar (inotify myview)
+  for_ mi $ \i -> killINotify i
+  newi <- initINotify
+  w <- addWatch
+         newi
+         [Move, MoveIn, MoveOut, MoveSelf, Create, Delete, DeleteSelf]
+         cdirp
+         (\_ -> postGUIAsync $ refreshTreeView mygui myview (Just cdirp))
+  putMVar (inotify myview) newi
+
+  return ()
+  where
+    dirtreePix (Dir {})          = folderPix mygui
+    dirtreePix (FileLike {})     = filePix mygui
+    dirtreePix (DirSym _)        = folderSymPix mygui
+    dirtreePix (FileLikeSym {})  = fileSymPix mygui
+    dirtreePix (Failed {})       = errorPix mygui
+    dirtreePix (BrokenSymlink _) = errorPix mygui
+    dirtreePix _                 = errorPix mygui
+
+
+-- |Push a message to the status bar.
+pushStatusBar :: MyGUI -> String -> IO (ContextId, MessageId)
+pushStatusBar mygui str = do
+  let sb = statusBar mygui
+  cid <- statusbarGetContextId sb "FM Status"
+  mid <- statusbarPush sb cid str
+  return (cid, mid)

src/HSFM/FileSystem/FileType.hs

@@ -1,550 +0,0 @@
-{--
-HSFM, a filemanager written in Haskell.
-Copyright (C) 2016 Julian Ospald
-
-This program is free software; you can redistribute it and/or
-modify it under the terms of the GNU General Public License
-version 2 as published by the Free Software Foundation.
-
-This program is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with this program; if not, write to the Free Software
-Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
---}
-
-{-# OPTIONS_HADDOCK ignore-exports #-}
-
-
--- |This module provides a data type for representing directories/files
--- in a well-typed and convenient way. This is useful to gather and
--- save information about a file, so the information can be easily
--- processed in e.g. a GUI.
---
--- However, it's not meant to be used to interact with low-level
--- functions that copy files etc, since there's no guarantee that
--- the in-memory representation of the type still matches what is
--- happening on filesystem level.
---
--- If you interact with low-level libraries, you must not pattern
--- match on the `File a` type. Instead, you should only use the saved
--- `path` and make no assumptions about the file the path might or
--- might not point to.
-module HSFM.FileSystem.FileType where
-
-
-
-import Data.ByteString(ByteString)
-import Data.ByteString.UTF8
-  (
-    toString
-  )
-import Data.Time.Clock.POSIX
-  (
-    POSIXTime
-  , posixSecondsToUTCTime
-  )
-import Data.Time()
-import HPath
-  (
-    Abs
-  , Path
-  )
-import qualified HPath as P
-import HPath.IO hiding (FileType(..))
-import HPath.IO.Errors
-import Prelude hiding(readFile)
-import System.Posix.FilePath
-  (
-    (</>)
-  )
-import System.Posix.Directory.Traversals
-  (
-    realpath
-  )
-import qualified System.Posix.Files.ByteString as PF
-import System.Posix.Types
-  (
-    DeviceID
-  , EpochTime
-  , FileID
-  , FileMode
-  , FileOffset
-  , GroupID
-  , LinkCount
-  , UserID
-  )
-
-
-
-
-
-
-    ----------------------------
-    --[ BASE TYPES ]--
-    ----------------------------
-
-
--- |The String in the path field is always a full path.
--- The free type variable is used in the File/Dir constructor and can hold
--- Handles, Strings representing a file's contents or anything else you can
--- think of.
-data File a =
-  Dir {
-    path :: !(Path Abs)
-  , fvar :: a
-  }
-  | RegFile {
-    path :: !(Path Abs)
-  , fvar :: a
-  }
-  | SymLink {
-    path    :: !(Path Abs)
-  , fvar    :: a
-  , sdest   :: Maybe (File a)  -- ^ symlink madness,
-                               --   we need to know where it points to
-  , rawdest :: !ByteString
-  }
-  | BlockDev {
-    path :: !(Path Abs)
-  , fvar :: a
-  }
-  | CharDev {
-    path :: !(Path Abs)
-  , fvar :: a
-  }
-  | NamedPipe {
-    path :: !(Path Abs)
-  , fvar :: a
-  }
-  | Socket {
-    path :: !(Path Abs)
-  , fvar :: a
-  } deriving (Show, Eq)
-
-
--- |Low-level file information.
-data FileInfo = FileInfo {
-    deviceID              :: !DeviceID
-  , fileID                :: !FileID
-  , fileMode              :: !FileMode
-  , linkCount             :: !LinkCount
-  , fileOwner             :: !UserID
-  , fileGroup             :: !GroupID
-  , specialDeviceID       :: !DeviceID
-  , fileSize              :: !FileOffset
-  , accessTime            :: !EpochTime
-  , modificationTime      :: !EpochTime
-  , statusChangeTime      :: !EpochTime
-  , accessTimeHiRes       :: !POSIXTime
-  , modificationTimeHiRes :: !POSIXTime
-  , statusChangeTimeHiRes :: !POSIXTime
-} deriving (Show, Eq, Ord)
-
-
-
-
-    ------------------------------------
-    --[ ViewPatterns/PatternSynonyms ]--
-    ------------------------------------
-
-
-
-
----- Filetypes ----
-
-
-sfileLike :: File FileInfo -> (Bool, File FileInfo)
-sfileLike f@RegFile{}   = (True, f)
-sfileLike f@BlockDev{}  = (True, f)
-sfileLike f@CharDev{}   = (True, f)
-sfileLike f@NamedPipe{} = (True, f)
-sfileLike f@Socket{}    = (True, f)
-sfileLike f             = fileLikeSym f
-
-
-fileLike :: File FileInfo -> (Bool, File FileInfo)
-fileLike f@RegFile {}  = (True, f)
-fileLike f@BlockDev{}  = (True, f)
-fileLike f@CharDev{}   = (True, f)
-fileLike f@NamedPipe{} = (True, f)
-fileLike f@Socket{}    = (True, f)
-fileLike f             = (False, f)
-
-
-sdir :: File FileInfo -> (Bool, File FileInfo)
-sdir f@SymLink{ sdest = (Just s@SymLink{} )}
-  -- we have to follow a chain of symlinks here, but
-  -- return only the very first level
-  -- TODO: this is probably obsolete now
-  = case sdir s of
-      (True, _) -> (True, f)
-      _         -> (False, f)
-sdir f@SymLink{ sdest = Just Dir{} }
-  = (True, f)
-sdir f@Dir{} = (True, f)
-sdir f       = (False, f)
-
-
--- |Matches on any non-directory kind of files, excluding symlinks.
-pattern FileLike :: File FileInfo -> File FileInfo
-pattern FileLike  f <- (fileLike  -> (True, f))
-
--- |Matches a list of directories or symlinks pointing to directories.
-pattern DirList :: [File FileInfo] -> [File FileInfo]
-pattern DirList fs <- (\fs -> (and . fmap (fst . sdir) $ fs, fs)
-                                -> (True, fs))
-
--- |Matches a list of any non-directory kind of files or symlinks
--- pointing to such.
-pattern FileLikeList :: [File FileInfo] -> [File FileInfo]
-pattern FileLikeList fs <- (\fs -> (and
-                                     . fmap (fst . sfileLike)
-                                     $ fs, fs) -> (True, fs))
-
-
-
----- Symlinks ----
-
-
-brokenSymlink :: File FileInfo -> (Bool, File FileInfo)
-brokenSymlink f = (isBrokenSymlink f, f)
-
-
-fileLikeSym :: File FileInfo -> (Bool, File FileInfo)
-fileLikeSym f@SymLink{ sdest = Just s@SymLink{} }
-  = case fileLikeSym s of
-      (True, _) -> (True, f)
-      _         -> (False, f)
-fileLikeSym f@SymLink{ sdest = Just RegFile{} }   = (True, f)
-fileLikeSym f@SymLink{ sdest = Just BlockDev{} }  = (True, f)
-fileLikeSym f@SymLink{ sdest = Just CharDev{} }   = (True, f)
-fileLikeSym f@SymLink{ sdest = Just NamedPipe{} } = (True, f)
-fileLikeSym f@SymLink{ sdest = Just Socket{} }    = (True, f)
-fileLikeSym f                                = (False, f)
-
-
-dirSym :: File FileInfo -> (Bool, File FileInfo)
-dirSym f@SymLink{ sdest = Just s@SymLink{} }
-  = case dirSym s of
-      (True, _) -> (True, f)
-      _         -> (False, f)
-dirSym f@SymLink{ sdest = Just Dir{} } = (True, f)
-dirSym f = (False, f)
-
-
--- |Matches on symlinks pointing to file-like files only.
-pattern FileLikeSym :: File FileInfo -> File FileInfo
-pattern FileLikeSym  f <- (fileLikeSym  -> (True, f))
-
--- |Matches on broken symbolic links.
-pattern BrokenSymlink :: File FileInfo -> File FileInfo
-pattern BrokenSymlink  f <- (brokenSymlink  -> (True, f))
-
-
--- |Matches on directories or symlinks pointing to directories.
--- If the symlink is pointing to a symlink pointing to a directory, then
--- it will return True, but also return the first element in the symlink-
--- chain, not the last.
-pattern DirOrSym :: File FileInfo -> File FileInfo
-pattern DirOrSym  f <- (sdir  -> (True, f))
-
--- |Matches on symlinks pointing to directories only.
-pattern DirSym :: File FileInfo -> File FileInfo
-pattern DirSym   f <- (dirSym  -> (True, f))
-
--- |Matches on any non-directory kind of files or symlinks pointing to
--- such.
--- If the symlink is pointing to a symlink pointing to such a file, then
--- it will return True, but also return the first element in the symlink-
--- chain, not the last.
-pattern FileLikeOrSym :: File FileInfo -> File FileInfo
-pattern FileLikeOrSym  f <- (sfileLike  -> (True, f))
-
-
-
-
-
-    -----------------
-    --[ INSTANCES ]--
-    -----------------
-
-
--- | First compare constructors: Failed < Dir < File...
--- Then compare `name`...
--- Then compare free variable parameter of `File` constructors
-instance Ord (File FileInfo) where
-    compare (RegFile n a) (RegFile n' a') =
-        case compare n n' of
-             EQ -> compare a a'
-             el -> el
-    compare (Dir n b) (Dir n' b') =
-        case compare n n' of
-             EQ -> compare b b'
-             el -> el
-     -- after comparing above we can hand off to shape ord function:
-    compare d d' = comparingConstr d d'
-
-
-
-
-
-    ----------------------------
-    --[ HIGH LEVEL FUNCTIONS ]--
-    ----------------------------
-
-
-
--- |Reads a file or directory Path into an `AnchoredFile`, filling the free
--- variables via the given function.
-pathToFile :: (Path Abs -> IO a)
-           -> Path Abs
-           -> IO (File a)
-pathToFile ff p = do
-    fs   <- PF.getSymbolicLinkStatus (P.toFilePath p)
-    fv   <- ff p
-    constructFile fs fv p
-  where
-    constructFile fs fv p'
-      | PF.isSymbolicLink    fs = do
-          -- symlink madness, we need to make sure we save the correct
-          -- File
-          x <- PF.readSymbolicLink (P.fromAbs p')
-          resolvedSyml <- handleIOError (\_ -> return Nothing) $ do
-            -- watch out, we call </> from 'filepath' here, but it is safe
-            let sfp = (P.fromAbs . P.dirname $ p') </> x
-            rsfp <- realpath sfp
-            f <- pathToFile ff =<< P.parseAbs rsfp
-            return $ Just f
-          return $ SymLink p' fv resolvedSyml x
-      | PF.isDirectory       fs = return $ Dir       p' fv
-      | PF.isRegularFile     fs = return $ RegFile   p' fv
-      | PF.isBlockDevice     fs = return $ BlockDev  p' fv
-      | PF.isCharacterDevice fs = return $ CharDev   p' fv
-      | PF.isNamedPipe       fs = return $ NamedPipe p' fv
-      | PF.isSocket          fs = return $ Socket    p' fv
-      | otherwise               = ioError $ userError "Unknown filetype!"
-
-
--- |Get the contents of a given directory and return them as a list
--- of `AnchoredFile`.
-readDirectoryContents :: (Path Abs -> IO a)  -- ^ fills free a variable
-                      -> Path Abs            -- ^ path to read
-                      -> IO [File a]
-readDirectoryContents ff p = do
-  files <- getDirsFiles p
-  mapM (pathToFile ff) files
-
-
--- |A variant of `readDirectoryContents` where the second argument
--- is a `File`. If a non-directory is passed returns an empty list.
-getContents :: (Path Abs -> IO a)
-            -> File FileInfo
-            -> IO [File a]
-getContents ff (DirOrSym af)
-  = readDirectoryContents ff (path af)
-getContents _ _ = return []
-
-
-
--- |Go up one directory in the filesystem hierarchy.
-goUp :: File FileInfo -> IO (File FileInfo)
-goUp file = pathToFile getFileInfo (P.dirname . path $ file)
-
-
--- |Go up one directory in the filesystem hierarchy.
-goUp' :: Path Abs -> IO (File FileInfo)
-goUp' fp = pathToFile getFileInfo $ P.dirname fp
-
-
-
-
-    -----------------
-    --[ UTILITIES ]--
-    -----------------
-
-
-
-
-
----- ORDERING AND EQUALITY ----
-
-
- -- HELPER: a non-recursive comparison
-comparingConstr :: File FileInfo -> File FileInfo -> Ordering
-comparingConstr (FileLikeOrSym _) (DirOrSym _)      = GT
-comparingConstr (DirOrSym _)      (FileLikeOrSym _) = LT
- -- else compare on the names of constructors that are the same, without
- -- looking at the contents of Dir constructors:
-comparingConstr t t'  = compare (path t) (path t')
-
-
-
-
-
-
-
-    ---------------
-    --[ HELPERS ]--
-    ---------------
-
-
----- CONSTRUCTOR IDENTIFIERS ----
-
-isFileC :: File a -> Bool
-isFileC RegFile{} = True
-isFileC _         = False
-
-
-isDirC :: File a -> Bool
-isDirC Dir{} = True
-isDirC _     = False
-
-
-isSymC :: File a -> Bool
-isSymC SymLink{} = True
-isSymC _         = False
-
-
-isBlockC :: File a -> Bool
-isBlockC BlockDev{} = True
-isBlockC _          = False
-
-
-isCharC :: File a -> Bool
-isCharC CharDev{} = True
-isCharC _         = False
-
-
-isNamedC :: File a -> Bool
-isNamedC NamedPipe{} = True
-isNamedC _           = False
-
-
-isSocketC :: File a -> Bool
-isSocketC Socket{} = True
-isSocketC _        = False
-
-
-
-
----- IO HELPERS: ----
-
-
-
--- |Gets all file information.
-getFileInfo :: Path Abs -> IO FileInfo
-getFileInfo fp = do
-  fs <- PF.getSymbolicLinkStatus (P.fromAbs fp)
-  return $ FileInfo
-    (PF.deviceID fs)
-    (PF.fileID fs)
-    (PF.fileMode fs)
-    (PF.linkCount fs)
-    (PF.fileOwner fs)
-    (PF.fileGroup fs)
-    (PF.specialDeviceID fs)
-    (PF.fileSize fs)
-    (PF.accessTime fs)
-    (PF.modificationTime fs)
-    (PF.statusChangeTime fs)
-    (PF.accessTimeHiRes fs)
-    (PF.modificationTimeHiRes fs)
-    (PF.statusChangeTimeHiRes fs)
-
-
-
-
-
----- SYMLINK HELPERS: ----
-
-
--- |Checks if a symlink is broken by examining the constructor of the
--- symlink destination.
---
--- When called on a non-symlink, returns False.
-isBrokenSymlink :: File FileInfo -> Bool
-isBrokenSymlink (SymLink _ _ Nothing _) = True
-isBrokenSymlink _ = False
-
-
-
-
----- PACKERS: ----
-
-
--- |Pack the modification time into a string.
-packModTime :: File FileInfo
-            -> String
-packModTime = epochToString . modificationTime . fvar
-
-
--- |Pack the modification time into a string.
-packAccessTime :: File FileInfo
-               -> String
-packAccessTime = epochToString . accessTime . fvar
-
-
-epochToString :: EpochTime -> String
-epochToString =  show . posixSecondsToUTCTime . realToFrac
-
-
--- |Pack the permissions into a string, similar to what "ls -l" does.
-packPermissions :: File FileInfo
-                -> String
-packPermissions file = (pStr . fileMode) . fvar $ file
-  where
-    pStr :: FileMode -> String
-    pStr ffm = typeModeStr ++ ownerModeStr ++ groupModeStr ++ otherModeStr
-      where
-        typeModeStr = case file of
-          Dir {}       -> "d"
-          RegFile {}   -> "-"
-          SymLink {}   -> "l"
-          BlockDev {}  -> "b"
-          CharDev {}   -> "c"
-          NamedPipe {} -> "p"
-          Socket {}    -> "s"
-        ownerModeStr =    hasFmStr PF.ownerReadMode    "r"
-                       ++ hasFmStr PF.ownerWriteMode   "w"
-                       ++ hasFmStr PF.ownerExecuteMode "x"
-        groupModeStr =    hasFmStr PF.groupReadMode    "r"
-                       ++ hasFmStr PF.groupWriteMode   "w"
-                       ++ hasFmStr PF.groupExecuteMode "x"
-        otherModeStr =    hasFmStr PF.otherReadMode    "r"
-                       ++ hasFmStr PF.otherWriteMode   "w"
-                       ++ hasFmStr PF.otherExecuteMode "x"
-        hasFmStr fm str
-          | hasFM fm  = str
-          | otherwise = "-"
-        hasFM fm = ffm `PF.intersectFileModes` fm == fm
-
-
-packFileType :: File a -> String
-packFileType file = case file of
-  Dir {}       -> "Directory"
-  RegFile {}   -> "Regular File"
-  SymLink {}   -> "Symbolic Link"
-  BlockDev {}  -> "Block Device"
-  CharDev {}   -> "Char Device"
-  NamedPipe {} -> "Named Pipe"
-  Socket {}    -> "Socket"
-
-
-packLinkDestination :: File a -> Maybe ByteString
-packLinkDestination file = case file of
-  SymLink { rawdest = dest } -> Just dest
-  _                          -> Nothing
-
-
-
-
----- OTHER: ----
-
-
-getFPasStr :: File a -> String
-getFPasStr = toString . P.fromAbs . path
-

src/HSFM/FileSystem/UtilTypes.hs

@@ -1,83 +0,0 @@
-{--
-HSFM, a filemanager written in Haskell.
-Copyright (C) 2016 Julian Ospald
-
-This program is free software; you can redistribute it and/or
-modify it under the terms of the GNU General Public License
-version 2 as published by the Free Software Foundation.
-
-This program is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with this program; if not, write to the Free Software
-Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
---}
-
-{-# OPTIONS_HADDOCK ignore-exports #-}
-
-
--- |This module provides high-level IO related file operations like
--- copy, delete, move and so on. It only operates on `Path Abs` which
--- guarantees us well-typed paths which are absolute.
---
--- Some functions are just path-safe wrappers around
--- unix functions, others have stricter exception handling
--- and some implement functionality that doesn't have a unix
--- counterpart (like `copyDirRecursive`).
---
--- Some of these operations are due to their nature not _atomic_, which
--- means they may do multiple syscalls which form one context. Some
--- of them also have to examine the filetypes explicitly before the
--- syscalls, so a reasonable decision can be made. That means
--- the result is undefined if another process changes that context
--- while the non-atomic operation is still happening. However, where
--- possible, as few syscalls as possible are used and the underlying
--- exception handling is kept.
-module HSFM.FileSystem.UtilTypes where
-
-
-import Data.ByteString
-  (
-    ByteString
-  )
-import HPath
-  (
-    Path
-  , Abs
-  , Rel
-  )
-
-
--- |Data type describing file operations.
--- Useful to build up a list of operations or delay operations.
-data FileOperation = FCopy    Copy
-                   | FMove    Move
-                   | FDelete  [Path Abs]
-                   | FOpen    (Path Abs)
-                   | FExecute (Path Abs) [ByteString]
-                   | None
-
-
--- |Data type describing partial or complete file copy operation.
-data Copy = PartialCopy [Path Abs] -- source files
-          | Copy        [Path Abs] -- source files
-                        (Path Abs) -- base destination directory
-
-
--- |Data type describing partial or complete file move operation.
-data Move = PartialMove [Path Abs] -- source files
-          | Move        [Path Abs] -- source files
-                        (Path Abs) -- base destination directory
-
-
--- |Collision modes that describe the behavior in case a file collision
--- happens.
-data FCollisonMode = Strict  -- ^ fail if the target already exists
-                   | Overwrite
-                   | OverwriteAll
-                   | Skip
-                   | Rename (Path Rel)
-

src/HSFM/GUI/Glib/GlibString.hs

@@ -1,79 +0,0 @@
-{--
-HSFM, a filemanager written in Haskell.
-Copyright (C) 2016 Julian Ospald
-
-This program is free software; you can redistribute it and/or
-modify it under the terms of the GNU General Public License
-version 2 as published by the Free Software Foundation.
-
-This program is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with this program; if not, write to the Free Software
-Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
---}
-
-{-# OPTIONS_HADDOCK ignore-exports #-}
-
-
-module HSFM.GUI.Glib.GlibString where
-
-
-import qualified Data.ByteString as BS
-import Data.ByteString.UTF8
-  (
-    toString
-  )
-import Data.Word8
-  (
-    _percent
-  )
-import Foreign.C.String
-  (
-    CStringLen
-  , CString
-  )
-import Foreign.C.Types
-  (
-    CSize(..)
-  )
-import Foreign.Marshal.Utils
-  (
-    maybePeek
-  )
-import Foreign.Ptr
-  (
-    nullPtr
-  , plusPtr
-  )
-import System.Glib.UTFString
-
-
-
--- TODO: move this to its own module
-instance GlibString BS.ByteString where
-    withUTFString = BS.useAsCString
-    withUTFStringLen s f = BS.useAsCStringLen  s (f . noNullPtrs)
-    peekUTFString s = do
-        len <- c_strlen s
-        BS.packCStringLen (s, fromIntegral len)
-    maybePeekUTFString = maybePeek peekUTFString
-    peekUTFStringLen = BS.packCStringLen
-    newUTFString = newUTFString . toString
-    newUTFStringLen = newUTFStringLen . toString
-    genUTFOfs = genUTFOfs . toString
-    stringLength = BS.length
-    unPrintf s = BS.intercalate (BS.pack [_percent, _percent]) (BS.split _percent s)
-
-
-foreign import ccall unsafe "string.h strlen" c_strlen
-    :: CString -> IO CSize
-
-
-noNullPtrs :: CStringLen -> CStringLen
-noNullPtrs (p, 0) | p == nullPtr = (plusPtr p 1, 0)
-noNullPtrs s = s
-

src/HSFM/GUI/Gtk.hs

@@ -1,72 +0,0 @@
-{--
-HSFM, a filemanager written in Haskell.
-Copyright (C) 2015 Julian Ospald
-
-This program is free software; you can redistribute it and/or
-modify it under the terms of the GNU General Public License
-version 2 as published by the Free Software Foundation.
-
-This program is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with this program; if not, write to the Free Software
-Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
---}
-
-{-# OPTIONS_HADDOCK ignore-exports #-}
-
-module Main where
-
-
-import qualified Data.ByteString as BS
-import Data.Maybe
-  (
-    fromJust
-  , fromMaybe
-  )
-import Data.Word8
-import Graphics.UI.Gtk
-import qualified HPath as P
-import HSFM.FileSystem.FileType
-import HSFM.GUI.Gtk.Callbacks
-import HSFM.GUI.Gtk.Data
-import HSFM.GUI.Gtk.MyGUI
-import HSFM.GUI.Gtk.MyView
-import Prelude hiding(readFile)
-import Safe
-  (
-    headDef
-  )
-import System.IO.Error
-  (
-    catchIOError
-  )
-import qualified System.Posix.Env.ByteString as SPE
-
-slash :: BS.ByteString
-slash = BS.singleton _slash
-
-main :: IO ()
-main = do
-  args <- SPE.getArgs
-  let mdir = fromMaybe (fromJust $ P.parseAbs slash)
-                       (P.parseAbs . headDef slash $ args)
-
-  file <- catchIOError (pathToFile getFileInfo mdir) $
-    \_ -> pathToFile getFileInfo  . fromJust $ P.parseAbs slash
-
-  _ <- initGUI
-  mygui <- createMyGUI
-  _ <- newTab mygui (notebook1 mygui) createTreeView file (-1)
-  _ <- newTab mygui (notebook2 mygui) createTreeView file (-1)
-
-  setGUICallbacks mygui
-
-  widgetShowAll (rootWin mygui)
-
-  _ <- mainGUI
-  return ()
-

src/HSFM/GUI/Gtk/Callbacks.hs

@@ -1,728 +0,0 @@
-{--
-HSFM, a filemanager written in Haskell.
-Copyright (C) 2016 Julian Ospald
-
-This program is free software; you can redistribute it and/or
-modify it under the terms of the GNU General Public License
-version 2 as published by the Free Software Foundation.
-
-This program is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with this program; if not, write to the Free Software
-Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
---}
-
-{-# LANGUAGE TupleSections #-}
-{-# OPTIONS_HADDOCK ignore-exports #-}
-
-module HSFM.GUI.Gtk.Callbacks where
-
-
-import Control.Concurrent.STM
-  (
-    readTVarIO
-  )
-import Control.Exception
-  (
-    throwIO
-  )
-import Control.Monad
-  (
-    forM
-  , forM_
-  , join
-  , void
-  , when
-  )
-import Control.Monad.IfElse
-import Control.Monad.IO.Class
-  (
-    liftIO
-  )
-import Control.Monad.Loops
-  (
-    iterateUntil
-  )
-import Data.ByteString
-  (
-    ByteString
-  )
-import Data.ByteString.UTF8
-  (
-    fromString
-  , toString
-  )
-import Data.Foldable
-  (
-    for_
-  )
-import Graphics.UI.Gtk
-import qualified HPath as P
-import HPath
-  (
-    fromAbs
-  , Abs
-  , Path
-  )
-import HPath.IO
-import HPath.IO.Errors
-import HSFM.FileSystem.FileType
-import HSFM.FileSystem.UtilTypes
-import HSFM.GUI.Gtk.Callbacks.Utils
-import HSFM.GUI.Gtk.Data
-import HSFM.GUI.Gtk.Dialogs
-import HSFM.GUI.Gtk.MyView
-import HSFM.GUI.Gtk.Plugins
-import HSFM.GUI.Gtk.Settings
-import HSFM.GUI.Gtk.Utils
-import HSFM.History
-import HSFM.Settings
-import HSFM.Utils.IO
-import Prelude hiding(readFile)
-import System.Glib.UTFString
-  (
-    glibToString
-  )
-import qualified System.Posix.Process.ByteString as SPP
-import System.Posix.Types
-  (
-    ProcessID
-  )
-import Control.Concurrent.MVar
-  (
-    putMVar
-  , readMVar
-  , takeMVar
-  )
-import Paths_hsfm
-  (
-    getDataFileName
-  )
-
-
-
-
-    -----------------
-    --[ Callbacks ]--
-    -----------------
-
-
-
-
----- MAIN CALLBACK ENTRYPOINT ----
-
-
--- |Set callbacks for the whole gui, on hotkeys, events and stuff.
-setGUICallbacks :: MyGUI -> IO ()
-setGUICallbacks mygui = do
-
-  -- notebook toggle buttons
-  _ <- leftNbBtn mygui `on` toggled $ do
-    isPressed <- toggleButtonGetActive $ leftNbBtn mygui
-    if isPressed then widgetShow $ notebook1 mygui
-                 else widgetHide $ notebook1 mygui
-
-  _ <- rightNbBtn mygui `on` toggled $ do
-    isPressed <- toggleButtonGetActive $ rightNbBtn mygui
-    if isPressed then widgetShow $ notebook2 mygui
-                 else widgetHide $ notebook2 mygui
-
-  -- statusbar
-  _ <- clearStatusBar mygui `on` buttonActivated $ do
-       popStatusbar mygui
-       writeTVarIO (operationBuffer mygui) None
-
-  -- menubar-file
-  _ <- (menubarFileQuit . menubar) mygui `on` menuItemActivated $
-    mainQuit
-
-  -- menubar-help
-  _ <- (menubarHelpAbout . menubar) mygui `on` menuItemActivated $
-    liftIO showAboutDialog
-  return ()
-
-  -- key events
-  _ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
-    QuitModifier <- eventModifier
-    QuitKey      <- fmap glibToString eventKeyName
-    liftIO mainQuit
-
-  return ()
-
-
--- |Set callbacks specific to a given view, on hotkeys, events and stuff.
-setViewCallbacks :: MyGUI -> MyView -> IO ()
-setViewCallbacks mygui myview = do
-  view' <- readTVarIO $ view myview
-  case view' of
-    fmv@(FMTreeView treeView) -> do
-      _ <- treeView `on` rowActivated
-             $ (\_ _ -> withItems mygui myview open)
-
-      -- drag events
-      _ <- treeView `on` dragBegin $
-        \_ -> withItems mygui myview moveInit
-      _ <- treeView `on` dragDrop $
-         \dc p ts -> do
-           p'    <- treeViewConvertWidgetToTreeCoords treeView p
-           mpath <- treeViewGetPathAtPos treeView p'
-           case mpath of
-             Nothing -> do
-               dragFinish dc False False ts
-               return False
-             Just _  -> do
-               atom  <- atomNew ("HSFM" :: String)
-               dragGetData treeView dc atom ts
-               return True
-      _ <- treeView `on` dragDataReceived $
-        \dc p _ ts ->
-          liftIO $ do
-            signalStopEmission treeView "drag_data_received"
-            p'    <- treeViewConvertWidgetToTreeCoords treeView p
-            mpath <- treeViewGetPathAtPos treeView p'
-            case mpath of
-              Nothing         -> dragFinish dc False False ts
-              Just (tp, _, _) -> do
-                mitem <- rawPathToItem myview tp
-                forM_ mitem $ \item ->
-                  operationFinal mygui myview (Just item)
-                dragFinish dc True False ts
-
-      commonGuiEvents fmv
-      return ()
-    fmv@(FMIconView iconView) -> do
-      _ <- iconView `on` itemActivated
-             $ (\_ -> withItems mygui myview open)
-      commonGuiEvents fmv
-      return ()
-  where
-    commonGuiEvents fmv = do
-      let view = fmViewToContainer fmv
-
-      -- focus events
-      _ <- notebook1 mygui `on` setFocusChild $ \w ->
-        case w of
-             Nothing -> widgetSetSensitive (leftNbIcon mygui) False
-             _       -> widgetSetSensitive (leftNbIcon mygui) True
-      _ <- notebook2 mygui `on` setFocusChild $ \w ->
-        case w of
-             Nothing -> widgetSetSensitive (rightNbIcon mygui) False
-             _       -> widgetSetSensitive (rightNbIcon mygui) True
-
-      -- GUI events
-      _ <- backViewB myview `on` buttonPressEvent $ do
-        eb <- eventButton
-        t  <- eventTime
-        case eb of
-          LeftButton  -> do
-            liftIO $ void $ goHistoryBack mygui myview
-            return True
-          RightButton -> do
-            his <- liftIO $ readMVar (history myview)
-            menu <- liftIO $ mkHistoryMenuB mygui myview
-                               (backwardsHistory his)
-            _ <- liftIO $ menuPopup menu $ Just (RightButton, t)
-            return True
-          _           -> return False
-      _ <- forwardViewB myview `on` buttonPressEvent $ do
-        eb <- eventButton
-        t  <- eventTime
-        case eb of
-          LeftButton  -> do
-            liftIO $ void $ goHistoryForward mygui myview
-            return True
-          RightButton -> do
-            his <- liftIO $ readMVar (history myview)
-            menu <- liftIO $ mkHistoryMenuF mygui myview
-                               (forwardHistory his)
-            _ <- liftIO $ menuPopup menu $ Just (RightButton, t)
-            return True
-          _           -> return False
-      _ <- urlBar myview `on` entryActivated $ urlGoTo mygui myview
-      _ <- upViewB myview `on` buttonActivated $
-           upDir mygui myview
-      _ <- homeViewB myview `on` buttonActivated $
-           goHome mygui myview
-      _ <- refreshViewB myview `on` buttonActivated $ do
-           cdir <- liftIO $ getCurrentDir myview
-           refreshView mygui myview cdir
-
-      -- key events
-      _ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
-        ShowHiddenModifier <- eventModifier
-        ShowHiddenKey      <- fmap glibToString eventKeyName
-        cdir <- liftIO $ getCurrentDir myview
-        liftIO $ modifyTVarIO (settings mygui)
-                              (\x -> x { showHidden = not . showHidden $ x})
-                 >> refreshView mygui myview cdir
-      _ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
-        UpDirModifier <- eventModifier
-        UpDirKey      <- fmap glibToString eventKeyName
-        liftIO $ upDir mygui myview
-      _ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
-        HistoryBackModifier <- eventModifier
-        HistoryBackKey      <- fmap glibToString eventKeyName
-        liftIO $ void $ goHistoryBack mygui myview
-      _ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
-        HistoryForwardModifier <- eventModifier
-        HistoryForwardKey      <- fmap glibToString eventKeyName
-        liftIO $ void $ goHistoryForward mygui myview
-      _ <- view `on` keyPressEvent $ tryEvent $ do
-        DeleteModifier <- eventModifier
-        DeleteKey      <- fmap glibToString eventKeyName
-        liftIO $ withItems mygui myview del
-      _ <- view `on` keyPressEvent $ tryEvent $ do
-        OpenModifier <- eventModifier
-        OpenKey      <- fmap glibToString eventKeyName
-        liftIO $ withItems mygui myview open
-      _ <- view `on` keyPressEvent $ tryEvent $ do
-        CopyModifier <- eventModifier
-        CopyKey      <- fmap glibToString eventKeyName
-        liftIO $ withItems mygui myview copyInit
-      _ <- view `on` keyPressEvent $ tryEvent $ do
-        MoveModifier <- eventModifier
-        MoveKey      <- fmap glibToString eventKeyName
-        liftIO $ withItems mygui myview moveInit
-      _ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
-        PasteModifier <- eventModifier
-        PasteKey      <- fmap glibToString eventKeyName
-        liftIO $ operationFinal mygui myview Nothing
-      _ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
-        NewTabModifier <- eventModifier
-        NewTabKey      <- fmap glibToString eventKeyName
-        liftIO $ void $ newTab' mygui myview
-      _ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
-        CloseTabModifier <- eventModifier
-        CloseTabKey      <- fmap glibToString eventKeyName
-        liftIO $ void $ closeTab mygui myview
-      _ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
-        OpenTerminalModifier <- eventModifier
-        OpenTerminalKey      <- fmap glibToString eventKeyName
-        liftIO $ void $ openTerminalHere myview
-
-      -- mouse button click
-      _ <- view `on` buttonPressEvent $ do
-        eb <- eventButton
-        t  <- eventTime
-        case eb of
-          RightButton -> do
-              _ <- liftIO $ showPopup mygui myview t
-              -- this is just to not screw with current selection
-              -- on right-click
-              -- TODO: this misbehaves under IconView
-              (x, y) <- eventCoordinates
-              mpath  <- liftIO $ getPathAtPos fmv (x, y)
-              case mpath of
-                -- item under the cursor, only pass on the signal
-                -- if the item under the cursor is not within the current
-                -- selection
-                (Just tp) -> do
-                  selectedTps <- liftIO $ getSelectedTreePaths mygui myview
-                  return $ elem tp selectedTps
-                -- no item under the cursor, pass on the signal
-                Nothing -> return False
-          MiddleButton -> do
-            (x, y) <- eventCoordinates
-            mitem  <- liftIO $ (getPathAtPos fmv (x, y))
-                               >>= \mpos -> fmap join
-                                 $ forM mpos (rawPathToItem myview)
-
-            case mitem of
-              -- item under the cursor, only pass on the signal
-              -- if the item under the cursor is not within the current
-              -- selection
-              (Just item) -> do
-                liftIO $ opeInNewTab mygui myview item
-                return True
-              -- no item under the cursor, pass on the signal
-              Nothing -> return False
-
-          OtherButton 8 -> do
-            liftIO $ void $ goHistoryBack mygui myview
-            return False
-          OtherButton 9 -> do
-            liftIO $ void $ goHistoryForward mygui myview
-            return False
-          -- not right-click, so pass on the signal
-          _ -> return False
-
-      return ()
-    getPathAtPos fmv (x, y) =
-      case fmv of
-        FMTreeView treeView -> do
-          mp <- treeViewGetPathAtPos treeView (round x, round y)
-          return $ fmap (\(p, _, _) -> p) mp
-        FMIconView iconView ->
-           fmap (\tp -> if null tp then Nothing else Just tp)
-                  $ iconViewGetPathAtPos iconView (round x) (round y)
-
-
-
-
----- OTHER ----
-
-
-openTerminalHere :: MyView -> IO ProcessID
-openTerminalHere myview = do
-  cwd <- (P.fromAbs . path) <$> getCurrentDir myview
-  SPP.forkProcess $ terminalCommand cwd
-
-
-
-
----- TAB OPERATIONS ----
-
-
--- |Closes the current tab, but only if there is more than one tab.
-closeTab :: MyGUI -> MyView -> IO ()
-closeTab _ myview = do
-  n <- notebookGetNPages (notebook myview)
-  when (n > 1) $ void $ destroyView myview
-
-
-newTab' :: MyGUI -> MyView -> IO ()
-newTab' mygui myview = do
-  cwd <- getCurrentDir myview
-  void $ withErrorDialog
-       $ newTab mygui (notebook myview) createTreeView cwd (-1)
-
-
-opeInNewTab :: MyGUI -> MyView -> Item -> IO ()
-opeInNewTab mygui myview item@(DirOrSym _) =
-  void $ withErrorDialog
-       $ newTab mygui (notebook myview) createTreeView item (-1)
-opeInNewTab _ _ _ = return ()
-
-
-
----- FILE OPERATION CALLBACKS (COPY, MOVE, ...) ----
-
-
--- |Supposed to be used with 'withRows'. Deletes a file or directory.
-del :: [Item] -> MyGUI -> MyView -> IO ()
-del [item] _ _ = withErrorDialog $ do
-  let cmsg  = "Really delete \"" ++ getFPasStr item ++ "\"?"
-  withConfirmationDialog cmsg
-    $ easyDelete . path $ item
--- this throws on the first error that occurs
-del items@(_:_) _ _ = withErrorDialog $ do
-  let cmsg  = "Really delete " ++ show (length items) ++ " files?"
-  withConfirmationDialog cmsg
-    $ forM_ items $ \item -> easyDelete . path $ item
-del _ _ _ = withErrorDialog
-              . ioError $ userError
-                          "Operation not supported on multiple files"
-
-
--- |Initializes a file move operation.
-moveInit :: [Item] -> MyGUI -> MyView -> IO ()
-moveInit items@(_:_) mygui _ = do
-  writeTVarIO (operationBuffer mygui) (FMove . PartialMove . map path $ items)
-  let sbmsg = case items of
-              (item:[]) -> "Move buffer: " ++ getFPasStr item
-              _         -> "Move buffer: " ++ (show . length $ items)
-                                           ++ " items"
-  popStatusbar mygui
-  void $ pushStatusBar mygui sbmsg
-moveInit _ _ _ = withErrorDialog
-                   . ioError $ userError
-                               "No file selected!"
-
--- |Supposed to be used with 'withRows'. Initializes a file copy operation.
-copyInit :: [Item] -> MyGUI -> MyView -> IO ()
-copyInit items@(_:_) mygui _ = do
-  writeTVarIO (operationBuffer mygui) (FCopy . PartialCopy . map path $ items)
-  let sbmsg = case items of
-              (item:[]) -> "Copy buffer: " ++ getFPasStr item
-              _         -> "Copy buffer: " ++ (show . length $ items)
-                                           ++ " items"
-  popStatusbar mygui
-  void $ pushStatusBar mygui sbmsg
-copyInit _ _ _ = withErrorDialog
-                   . ioError $ userError
-                               "No file selected!"
-
-
--- |Finalizes a file operation, such as copy or move.
-operationFinal :: MyGUI -> MyView -> Maybe Item -> IO ()
-operationFinal mygui myview mitem = withErrorDialog $ do
-  op <- readTVarIO (operationBuffer mygui)
-  cdir <- case mitem of
-            Nothing -> path <$> getCurrentDir myview
-            Just x  -> return $ path x
-  case op of
-    FMove (PartialMove s) -> do
-      let cmsg = "Really move " ++ imsg s
-                  ++ " to \"" ++ toString (P.fromAbs cdir)
-                  ++ "\"?"
-      withConfirmationDialog cmsg $ doFileOperation (FMove $ Move s cdir)
-      popStatusbar mygui
-      writeTVarIO (operationBuffer mygui) None
-    FCopy (PartialCopy s) -> do
-      let cmsg = "Really copy " ++ imsg s
-                 ++ " to \"" ++ toString (P.fromAbs cdir)
-                 ++ "\"?"
-      withConfirmationDialog cmsg $ doFileOperation (FCopy $ Copy s cdir)
-    _ -> return ()
-  where
-    imsg s = case s of
-               (item:[]) -> "\"" ++ toString (P.fromAbs item) ++ "\""
-               items     -> (show . length $ items) ++ " items"
-
-
--- |Create a new file.
-newFile :: MyGUI -> MyView -> IO ()
-newFile _ myview = withErrorDialog $ do
-  mfn   <- textInputDialog "Enter file name" ("" :: String)
-  let pmfn = P.parseRel =<< fromString <$> mfn
-  for_ pmfn $ \fn -> do
-    cdir  <- getCurrentDir myview
-    createRegularFile newFilePerms (path cdir P.</> fn)
-
-
--- |Create a new directory.
-newDir :: MyGUI -> MyView -> IO ()
-newDir _ myview = withErrorDialog $ do
-  mfn   <- textInputDialog "Enter directory name" ("" :: String)
-  let pmfn = P.parseRel =<< fromString <$> mfn
-  for_ pmfn $ \fn -> do
-    cdir  <- getCurrentDir myview
-    createDir newDirPerms (path cdir P.</> fn)
-
-
-renameF :: [Item] -> MyGUI -> MyView -> IO ()
-renameF [item] _ _ = withErrorDialog $ do
-  iname <- P.fromRel <$> (P.basename $ path item)
-  mfn  <- textInputDialog "Enter new file name" (iname :: ByteString)
-  let pmfn = P.parseRel =<< fromString <$> mfn
-  for_ pmfn $ \fn -> do
-    let cmsg = "Really rename \"" ++ getFPasStr item
-               ++ "\"" ++ " to \""
-               ++ toString (P.fromAbs $ (P.dirname . path $ item)
-                                             P.</> fn) ++ "\"?"
-    withConfirmationDialog cmsg $
-      HPath.IO.renameFile (path item)
-                          ((P.dirname $ path item) P.</> fn)
-renameF _ _ _ = withErrorDialog
-                  . ioError $ userError
-                              "Operation not supported on multiple files"
-
-
-
-
----- DIRECTORY TRAVERSAL AND FILE OPENING CALLBACKS ----
-
-
--- |Go to the url given at the 'urlBar' and visualize it in the given
--- treeView.
---
--- If the url is invalid, does nothing.
-urlGoTo :: MyGUI -> MyView -> IO ()
-urlGoTo mygui myview = withErrorDialog $ do
-  fp <- entryGetText (urlBar myview)
-  forM_ (P.parseAbs fp :: Maybe (Path Abs)) $ \fp' ->
-      whenM (canOpenDirectory fp')
-            (goDir True mygui myview =<< (pathToFile getFileInfo $ fp'))
-
-
-goHome :: MyGUI -> MyView -> IO ()
-goHome mygui myview =  withErrorDialog $ do
-  homedir <- home
-  forM_ (P.parseAbs homedir :: Maybe (Path Abs)) $ \fp' ->
-      whenM (canOpenDirectory fp')
-            (goDir True mygui myview =<< (pathToFile getFileInfo $ fp'))
-
-
--- |Execute a given file.
-execute :: [Item] -> MyGUI -> MyView -> IO ()
-execute [item] _ _ = withErrorDialog $
-  void $ executeFile (path item) []
-execute _ _ _ = withErrorDialog
-                  . ioError $ userError
-                              "Operation not supported on multiple files"
-
-
--- |Supposed to be used with 'withRows'. Opens a file or directory.
-open :: [Item] -> MyGUI -> MyView -> IO ()
-open [item] mygui myview = withErrorDialog $
-  case item of
-    DirOrSym r -> do
-      nv <- pathToFile getFileInfo $ path r
-      goDir True mygui myview nv
-    r ->
-      void $ openFile . path $ r
-open items mygui myview = do
-  let dirs  = filter (fst . sdir) items
-      files = filter (fst . sfileLike) items
-  forM_ dirs (withErrorDialog . opeInNewTab mygui myview)
-  forM_ files (withErrorDialog . openFile . path)
-
-
--- |Go up one directory and visualize it in the treeView.
-upDir :: MyGUI -> MyView -> IO ()
-upDir mygui myview = withErrorDialog $ do
-  cdir <- getCurrentDir myview
-  nv <- goUp cdir
-  goDir True mygui myview nv
-
-
-
-
----- HISTORY CALLBACKS ----
-
-
--- |Go "back" in the history.
-goHistoryBack :: MyGUI -> MyView -> IO (Path Abs)
-goHistoryBack mygui myview = do
-  hs <- takeMVar (history myview)
-  let nhs = historyBack hs
-  putMVar (history myview) nhs
-  nv <- pathToFile getFileInfo $ currentDir nhs
-  goDir False mygui myview nv
-  return $ currentDir nhs
-
-
--- |Go "forward" in the history.
-goHistoryForward :: MyGUI -> MyView -> IO (Path Abs)
-goHistoryForward mygui myview = do
-  hs <- takeMVar (history myview)
-  let nhs = historyForward hs
-  putMVar (history myview) nhs
-  nv <- pathToFile getFileInfo $ currentDir nhs
-  goDir False mygui myview nv
-  return $ currentDir nhs
-
-
--- |Show backwards history in a drop-down menu, depending on the input.
-mkHistoryMenuB :: MyGUI -> MyView -> [Path Abs] -> IO Menu
-mkHistoryMenuB mygui myview hs = do
-  menu <- menuNew
-  menuitems <- forM hs $ \p -> do
-    item <- menuItemNewWithLabel (fromAbs p)
-    _ <- item `on` menuItemActivated $
-      void $ iterateUntil (== p) (goHistoryBack mygui myview)
-    return item
-  forM_ menuitems $ \item -> menuShellAppend menu item
-  widgetShowAll menu
-  return menu
-
-
--- |Show forward history in a drop-down menu, depending on the input.
-mkHistoryMenuF :: MyGUI -> MyView -> [Path Abs] -> IO Menu
-mkHistoryMenuF mygui myview hs = do
-  menu <- menuNew
-  menuitems <- forM hs $ \p -> do
-    item <- menuItemNewWithLabel (fromAbs p)
-    _ <- item `on` menuItemActivated $
-      void $ iterateUntil (== p) (goHistoryForward mygui myview)
-    return item
-  forM_ menuitems $ \item -> menuShellAppend menu item
-  widgetShowAll menu
-  return menu
-
-
-
-
----- RIGHTCLICK CALLBACKS ----
-
-
--- |TODO: hopefully this does not leak
-showPopup :: MyGUI -> MyView -> TimeStamp -> IO ()
-showPopup mygui myview t
-  | null myplugins = return ()
-  | otherwise = do
-
-    rcmenu <- doRcMenu
-
-    -- add common callbacks
-    _ <- (\_ -> rcFileOpen rcmenu) myview `on` menuItemActivated $
-      liftIO $ withItems mygui myview open
-    _ <- (rcFileExecute rcmenu) `on` menuItemActivated $
-      liftIO $ withItems mygui myview execute
-    _ <- (rcFileNewRegFile rcmenu) `on` menuItemActivated $
-      liftIO $ newFile mygui myview
-    _ <- (rcFileNewDir rcmenu) `on` menuItemActivated $
-      liftIO $ newDir mygui myview
-    _ <- (rcFileNewTab rcmenu) `on` menuItemActivated $
-      liftIO $ newTab' mygui myview
-    _ <- (rcFileNewTerm rcmenu) `on` menuItemActivated $
-      liftIO $ void $ openTerminalHere myview
-    _ <- (rcFileCopy rcmenu) `on` menuItemActivated $
-      liftIO $ withItems mygui myview copyInit
-    _ <- (rcFileRename rcmenu) `on` menuItemActivated $
-      liftIO $ withItems mygui myview renameF
-    _ <- (rcFilePaste rcmenu) `on` menuItemActivated $
-      liftIO $ operationFinal mygui myview Nothing
-    _ <- (rcFileDelete rcmenu) `on` menuItemActivated $
-      liftIO $ withItems mygui myview del
-    _ <- (rcFileProperty rcmenu) `on` menuItemActivated $
-      liftIO $ withItems mygui myview showFilePropertyDialog
-    _ <- (rcFileCut rcmenu) `on` menuItemActivated $
-      liftIO $ withItems mygui myview moveInit
-    _ <- (rcFileIconView rcmenu) `on` menuItemActivated $
-      liftIO $ switchView mygui myview createIconView
-    _ <- (rcFileTreeView rcmenu) `on` menuItemActivated $
-      liftIO $ switchView mygui myview createTreeView
-
-
-    -- add another plugin separator after the existing one
-    -- where we want to place our plugins
-    sep2 <- separatorMenuItemNew
-    widgetShow sep2
-
-    menuShellInsert (rcMenu rcmenu) sep2 insertPos
-
-    plugins <- forM myplugins $ \(ma, mb, mc) -> fmap (, mb, mc) ma
-    -- need to reverse plugins list so the order is right
-    forM_ (reverse plugins) $ \(plugin, filter', cb) -> do
-      showItem <- withItems mygui myview filter'
-
-      menuShellInsert (rcMenu rcmenu) plugin insertPos
-      when showItem $ widgetShow plugin
-      -- init callback
-      plugin `on` menuItemActivated $ withItems mygui myview cb
-
-    menuPopup (rcMenu rcmenu) $ Just (RightButton, t)
-  where
-    doRcMenu = do
-      builder <- builderNew
-      builderAddFromFile builder =<< getDataFileName "data/Gtk/builder.xml"
-
-      -- create static right-click menu
-      rcMenu            <- builderGetObject builder castToMenu
-                           (fromString "rcMenu")
-      rcFileOpen        <- builderGetObject builder castToImageMenuItem
-                           (fromString "rcFileOpen")
-      rcFileExecute     <- builderGetObject builder castToImageMenuItem
-                           (fromString "rcFileExecute")
-      rcFileNewRegFile  <- builderGetObject builder castToImageMenuItem
-                           (fromString "rcFileNewRegFile")
-      rcFileNewDir      <- builderGetObject builder castToImageMenuItem
-                           (fromString "rcFileNewDir")
-      rcFileNewTab      <- builderGetObject builder castToImageMenuItem
-                           (fromString "rcFileNewTab")
-      rcFileNewTerm     <- builderGetObject builder castToImageMenuItem
-                           (fromString "rcFileNewTerm")
-      rcFileCut         <- builderGetObject builder castToImageMenuItem
-                           (fromString "rcFileCut")
-      rcFileCopy        <- builderGetObject builder castToImageMenuItem
-                           (fromString "rcFileCopy")
-      rcFileRename      <- builderGetObject builder castToImageMenuItem
-                           (fromString "rcFileRename")
-      rcFilePaste       <- builderGetObject builder castToImageMenuItem
-                           (fromString "rcFilePaste")
-      rcFileDelete      <- builderGetObject builder castToImageMenuItem
-                           (fromString "rcFileDelete")
-      rcFileProperty    <- builderGetObject builder castToImageMenuItem
-                           (fromString "rcFileProperty")
-      rcFileIconView    <- builderGetObject builder castToImageMenuItem
-                           (fromString "rcFileIconView")
-      rcFileTreeView    <- builderGetObject builder castToImageMenuItem
-                           (fromString "rcFileTreeView")
-
-      return $ MkRightClickMenu {..}
-

src/HSFM/GUI/Gtk/Callbacks.hs-boot

@@ -1,25 +0,0 @@
-{--
-HSFM, a filemanager written in Haskell.
-Copyright (C) 2016 Julian Ospald
-
-This program is free software; you can redistribute it and/or
-modify it under the terms of the GNU General Public License
-version 2 as published by the Free Software Foundation.
-
-This program is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with this program; if not, write to the Free Software
-Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
---}
-
-
-module HSFM.GUI.Gtk.Callbacks where
-
-import HSFM.GUI.Gtk.Data
-
-
-setViewCallbacks :: MyGUI -> MyView -> IO ()

src/HSFM/GUI/Gtk/Callbacks/Utils.hs

@@ -1,128 +0,0 @@
-{--
-HSFM, a filemanager written in Haskell.
-Copyright (C) 2016 Julian Ospald
-
-This program is free software; you can redistribute it and/or
-modify it under the terms of the GNU General Public License
-version 2 as published by the Free Software Foundation.
-
-This program is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with this program; if not, write to the Free Software
-Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
---}
-
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# OPTIONS_HADDOCK ignore-exports #-}
-
-module HSFM.GUI.Gtk.Callbacks.Utils where
-
-
-
-import Control.Monad
-  (
-    forM_
-  , when
-  )
-import Data.Foldable
-  (
-    for_
-  )
-import Data.Maybe
-  (
-    fromJust
-  )
-import GHC.IO.Exception
-  (
-    IOErrorType(..)
-  )
-import Graphics.UI.Gtk
-import qualified HPath as P
-import HPath.IO
-import HPath.IO.Errors
-import HSFM.FileSystem.FileType
-import qualified HSFM.FileSystem.UtilTypes as UT
-import HSFM.GUI.Gtk.Data
-import HSFM.GUI.Gtk.Dialogs
-import HSFM.GUI.Gtk.MyView
-import HSFM.History
-import Prelude hiding(readFile)
-import Control.Concurrent.MVar
-  (
-    putMVar
-  , tryTakeMVar
-  )
-
-
-
-
--- |Carries out a file operation with the appropriate error handling
--- allowing the user to react to various exceptions with further input.
-doFileOperation :: UT.FileOperation -> IO ()
-doFileOperation (UT.FCopy (UT.Copy (f':fs') to)) =
-  _doFileOperation (f':fs') to (\p1 p2 cm -> easyCopy p1 p2 cm FailEarly)
-    $ doFileOperation (UT.FCopy $ UT.Copy fs' to)
-doFileOperation (UT.FMove (UT.Move (f':fs') to)) =
-  _doFileOperation (f':fs') to moveFile
-    $ doFileOperation (UT.FMove $ UT.Move fs' to)
-doFileOperation _ = return ()
-
-
-_doFileOperation :: [P.Path b1]
-                 -> P.Path P.Abs
-                 -> (P.Path b1 -> P.Path P.Abs -> CopyMode -> IO b)
-                 -> IO ()
-                 -> IO ()
-_doFileOperation [] _ _ _ = return ()
-_doFileOperation (f:fs) to mc rest = do
-  toname <- P.basename f
-  let topath = to P.</> toname
-  reactOnError (mc f topath Strict >> rest)
-    -- TODO: how safe is 'AlreadyExists' here?
-    [(AlreadyExists  , collisionAction fileCollisionDialog topath)]
-    [(SameFile{}     , collisionAction renameDialog topath)]
-  where
-    collisionAction diag topath = do
-      mcm <- diag . P.fromAbs $ topath
-      forM_ mcm $ \cm -> case cm of
-        UT.Overwrite -> mc f topath Overwrite >> rest
-        UT.OverwriteAll -> forM_ (f:fs) $ \x -> do
-                          toname' <- P.basename x
-                          mc x (to P.</> toname') Overwrite
-        UT.Skip         -> rest
-        UT.Rename newn  -> mc f (to P.</> newn) Strict >> rest
-        _            -> return ()
-
-
--- |Helper that is invoked for any directory change operations.
-goDir :: Bool    -- ^ whether to update the history
-      -> MyGUI
-      -> MyView
-      -> Item
-      -> IO ()
-goDir bhis mygui myview item = do
-  when bhis $ do
-    mhs <- tryTakeMVar (history myview)
-    for_ mhs $ \hs -> do
-      let nhs = historyNewPath (path item) hs
-      putMVar (history myview) nhs
-  refreshView mygui myview item
-
-  -- set notebook tab label
-  page <- notebookGetCurrentPage (notebook myview)
-  child <- fromJust <$> notebookGetNthPage (notebook myview) page
-
-  -- get the label
-  ebox <- (castToEventBox . fromJust)
-    <$> notebookGetTabLabel (notebook myview) child
-  label <- (castToLabel . head) <$> containerGetChildren ebox
-
-  -- set the label
-  labelSetText label
-    (maybe (P.fromAbs $ path item)
-           P.fromRel $ P.basename . path $ item)
-

src/HSFM/GUI/Gtk/Data.hs

@@ -1,157 +0,0 @@
-{--
-HSFM, a filemanager written in Haskell.
-Copyright (C) 2016 Julian Ospald
-
-This program is free software; you can redistribute it and/or
-modify it under the terms of the GNU General Public License
-version 2 as published by the Free Software Foundation.
-
-This program is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with this program; if not, write to the Free Software
-Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
---}
-
-{-# OPTIONS_HADDOCK ignore-exports #-}
-
-module HSFM.GUI.Gtk.Data where
-
-
-import Control.Concurrent.MVar
-  (
-    MVar
-  )
-import Control.Concurrent.STM
-  (
-    TVar
-  )
-import Graphics.UI.Gtk hiding (MenuBar)
-import HSFM.FileSystem.FileType
-import HSFM.FileSystem.UtilTypes
-import HSFM.History
-import System.INotify
-  (
-    INotify
-  )
-
-
-
-    ------------------
-    --[ Base Types ]--
-    ------------------
-
-
--- |Monolithic object passed to various GUI functions in order
--- to keep the API stable and not alter the parameters too much.
--- This only holds GUI widgets that are needed to be read during
--- runtime.
-data MyGUI = MkMyGUI {
-  -- |main Window
-    rootWin :: !Window
-
-  -- widgets on the main window
-  , menubar        :: !MenuBar
-  , statusBar      :: !Statusbar
-  , clearStatusBar :: !Button
-
-  , notebook1      :: !Notebook
-  , leftNbBtn      :: !ToggleButton
-  , leftNbIcon     :: !Image
-
-  , notebook2      :: !Notebook
-  , rightNbBtn     :: !ToggleButton
-  , rightNbIcon    :: !Image
-
-  -- other
-  , fprop    :: !FilePropertyGrid
-  , settings :: !(TVar FMSettings)
-
-  , operationBuffer :: !(TVar FileOperation)
-}
-
-
--- |This describes the contents of the current view and is separated from MyGUI,
--- because we might want to have multiple views.
-data MyView = MkMyView {
-    view            :: !(TVar FMView)
-  , cwd             :: !(MVar Item)
-  , rawModel        :: !(TVar (ListStore Item))
-  , sortedModel     :: !(TVar (TypedTreeModelSort Item))
-  , filteredModel   :: !(TVar (TypedTreeModelFilter Item))
-  , inotify         :: !(MVar INotify)
-  , notebook        :: !Notebook -- current notebook
-
-  -- the first part of the tuple represents the "go back"
-  -- the second part the "go forth" in the history
-  , history         :: !(MVar BrowsingHistory)
-
-  -- sub-widgets
-  , scroll       :: !ScrolledWindow
-  , viewBox      :: !Box
-  , backViewB    :: !Button
-  , upViewB      :: !Button
-  , forwardViewB :: !Button
-  , homeViewB    :: !Button
-  , refreshViewB :: !Button
-  , urlBar       :: !Entry
-}
-
-
-data MenuBar = MkMenuBar {
-    menubarFileQuit  :: !ImageMenuItem
-  , menubarHelpAbout :: !ImageMenuItem
-}
-
-data RightClickMenu = MkRightClickMenu {
-    rcMenu           :: !Menu
-  , rcFileOpen       :: !ImageMenuItem
-  , rcFileExecute    :: !ImageMenuItem
-  , rcFileNewRegFile :: !ImageMenuItem
-  , rcFileNewDir     :: !ImageMenuItem
-  , rcFileNewTab     :: !ImageMenuItem
-  , rcFileNewTerm    :: !ImageMenuItem
-  , rcFileCut        :: !ImageMenuItem
-  , rcFileCopy       :: !ImageMenuItem
-  , rcFileRename     :: !ImageMenuItem
-  , rcFilePaste      :: !ImageMenuItem
-  , rcFileDelete     :: !ImageMenuItem
-  , rcFileProperty   :: !ImageMenuItem
-  , rcFileIconView   :: !ImageMenuItem
-  , rcFileTreeView   :: !ImageMenuItem
-}
-
-data FilePropertyGrid = MkFilePropertyGrid {
-    fpropGrid      :: !Grid
-  , fpropFnEntry   :: !Entry
-  , fpropLocEntry  :: !Entry
-  , fpropTsEntry   :: !Entry
-  , fpropModEntry  :: !Entry
-  , fpropAcEntry   :: !Entry
-  , fpropFTEntry   :: !Entry
-  , fpropPermEntry :: !Entry
-  , fpropLDEntry   :: !Entry
-}
-
-
--- |FM-wide settings.
-data FMSettings = MkFMSettings {
-    showHidden :: !Bool
-  , isLazy     :: !Bool
-  , iconSize   :: !Int
-}
-
-data FMView = FMTreeView !TreeView
-            | FMIconView !IconView
-
-type Item = File FileInfo
-
-
-
-fmViewToContainer :: FMView -> Container
-fmViewToContainer (FMTreeView x) =  castToContainer . toGObject $ x
-fmViewToContainer (FMIconView x) =  castToContainer . toGObject $ x
-

src/HSFM/GUI/Gtk/Dialogs.hs

@@ -1,328 +0,0 @@
-{--
-HSFM, a filemanager written in Haskell.
-Copyright (C) 2016 Julian Ospald
-
-This program is free software; you can redistribute it and/or
-modify it under the terms of the GNU General Public License
-version 2 as published by the Free Software Foundation.
-
-This program is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with this program; if not, write to the Free Software
-Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
---}
-
-{-# LANGUAGE CPP #-}
-{-# OPTIONS_HADDOCK ignore-exports #-}
-
-module HSFM.GUI.Gtk.Dialogs where
-
-
-import Codec.Binary.UTF8.String
-  (
-    decodeString
-  )
-import Control.Exception
-  (
-    catches
-  , displayException
-  , throwIO
-  , IOException
-  , Handler(..)
-  )
-import Control.Monad
-  (
-    forM
-  , when
-  , void
-  )
-import Data.ByteString
-  (
-    ByteString
-  )
-import qualified Data.ByteString as BS
-import Data.ByteString.UTF8
-  (
-    fromString
-  )
-import Distribution.Package
-  (
-    PackageIdentifier(..)
-  , packageVersion
-  , unPackageName
-  )
-#if MIN_VERSION_Cabal(2,0,0)
-import Distribution.Version
-  (
-    showVersion
-  )
-#else
-import Data.Version
-  (
-    showVersion
-  )
-#endif
-import Distribution.PackageDescription
-  (
-    GenericPackageDescription(..)
-  , PackageDescription(..)
-  )
-#if MIN_VERSION_Cabal(2,2,0)
-import Distribution.PackageDescription.Parsec
-#else
-import Distribution.PackageDescription.Parse
-#endif
-  (
-#if MIN_VERSION_Cabal(2,0,0)
-    readGenericPackageDescription,
-#else
-    readPackageDescription,
-#endif
-  )
-import Distribution.Verbosity
-  (
-    silent
-  )
-import Graphics.UI.Gtk
-import qualified HPath as P
-import HPath.IO.Errors
-import HSFM.FileSystem.FileType
-import HSFM.FileSystem.UtilTypes
-import HSFM.GUI.Glib.GlibString()
-import HSFM.GUI.Gtk.Data
-import HSFM.GUI.Gtk.Errors
-import Paths_hsfm
-  (
-    getDataFileName
-  )
-import System.Glib.UTFString
-  (
-    GlibString
-  )
-import System.Posix.FilePath
-  (
-    takeFileName
-  )
-
-
-
-
-
-
-
-    ---------------------
-    --[ Dialog popups ]--
-    ---------------------
-
-
--- |Pops up an error Dialog with the given String.
-showErrorDialog :: String -> IO ()
-showErrorDialog str = do
-  errorDialog <- messageDialogNew Nothing
-                                  [DialogDestroyWithParent]
-                                  MessageError
-                                  ButtonsClose
-                                  str
-  _ <- dialogRun errorDialog
-  widgetDestroy errorDialog
-
-
--- |Asks the user for confirmation and returns True/False.
-showConfirmationDialog :: String -> IO Bool
-showConfirmationDialog str = do
-  confirmDialog <- messageDialogNew Nothing
-                                    [DialogDestroyWithParent]
-                                    MessageQuestion
-                                    ButtonsYesNo
-                                    str
-  rID <- dialogRun confirmDialog
-  widgetDestroy confirmDialog
-  case rID of
-    ResponseYes -> return True
-    ResponseNo  -> return False
-    _           -> return False
-
-
-fileCollisionDialog :: ByteString -> IO (Maybe FCollisonMode)
-fileCollisionDialog t = do
-  chooserDialog <- messageDialogNew Nothing
-                                    [DialogDestroyWithParent]
-                                    MessageQuestion
-                                    ButtonsNone
-                                    (fromString "Target \"" `BS.append`
-                                     t `BS.append`
-                                     fromString "\" exists, how to proceed?")
-  _ <- dialogAddButton chooserDialog "Cancel"        (ResponseUser 0)
-  _ <- dialogAddButton chooserDialog "Overwrite"     (ResponseUser 1)
-  _ <- dialogAddButton chooserDialog "Overwrite all" (ResponseUser 2)
-  _ <- dialogAddButton chooserDialog "Skip"          (ResponseUser 3)
-  _ <- dialogAddButton chooserDialog "Rename"        (ResponseUser 4)
-  rID <- dialogRun chooserDialog
-  widgetDestroy chooserDialog
-  case rID of
-    ResponseUser 0 -> return Nothing
-    ResponseUser 1 -> return (Just Overwrite)
-    ResponseUser 2 -> return (Just OverwriteAll)
-    ResponseUser 3 -> return (Just Skip)
-    ResponseUser 4 -> do
-      mfn   <- textInputDialog (fromString "Enter new name") (takeFileName t)
-      forM mfn $ \fn -> do
-        pfn <- P.parseRel (fromString fn)
-        return $ Rename pfn
-    _              -> throwIO UnknownDialogButton
-
-
-renameDialog :: ByteString -> IO (Maybe FCollisonMode)
-renameDialog t = do
-  chooserDialog <- messageDialogNew Nothing
-                                    [DialogDestroyWithParent]
-                                    MessageQuestion
-                                    ButtonsNone
-                                    (fromString "Target \"" `BS.append`
-                                     t `BS.append`
-                                     fromString "\" exists, how to proceed?")
-  _ <- dialogAddButton chooserDialog "Cancel"        (ResponseUser 0)
-  _ <- dialogAddButton chooserDialog "Skip"          (ResponseUser 1)
-  _ <- dialogAddButton chooserDialog "Rename"        (ResponseUser 2)
-  rID <- dialogRun chooserDialog
-  widgetDestroy chooserDialog
-  case rID of
-    ResponseUser 0 -> return Nothing
-    ResponseUser 1 -> return (Just Skip)
-    ResponseUser 2 -> do
-      mfn   <- textInputDialog (fromString "Enter new name") (takeFileName t)
-      forM mfn $ \fn -> do
-        pfn <- P.parseRel (fromString fn)
-        return $ Rename pfn
-    _              -> throwIO UnknownDialogButton
-
-
--- |Shows the about dialog from the help menu.
-showAboutDialog :: IO ()
-showAboutDialog = do
-  ad       <- aboutDialogNew
-  lstr     <- Prelude.readFile =<< getDataFileName "LICENSE"
-  hsfmicon <- pixbufNewFromFile =<< getDataFileName "data/Gtk/icons/hsfm.png"
-  pdesc    <- fmap packageDescription
-#if MIN_VERSION_Cabal(2,0,0)
-                   (readGenericPackageDescription silent
-#else
-                   (readPackageDescription silent
-#endif
-                     =<< getDataFileName "hsfm.cabal")
-  set ad
-    [ aboutDialogProgramName  := (unPackageName . pkgName . package) pdesc
-    , aboutDialogName         := (unPackageName . pkgName . package) pdesc
-    , aboutDialogVersion      := (showVersion . packageVersion . package) pdesc
-    , aboutDialogCopyright    := copyright pdesc
-    , aboutDialogComments     := description pdesc
-    , aboutDialogLicense      := Just lstr
-    , aboutDialogWebsite      := homepage pdesc
-    , aboutDialogAuthors      := [author pdesc]
-    , aboutDialogLogo         := Just hsfmicon
-    , aboutDialogWrapLicense  := True
-    ]
-  _ <- dialogRun ad
-  widgetDestroy ad
-
-
--- |Carry out an IO action with a confirmation dialog.
--- If the user presses "No", then do nothing.
-withConfirmationDialog :: String -> IO () -> IO ()
-withConfirmationDialog str io = do
-  run <- showConfirmationDialog str
-  when run io
-
-
--- |Execute the given IO action. If the action throws exceptions,
--- visualize them via 'showErrorDialog'.
-withErrorDialog :: IO a -> IO ()
-withErrorDialog io =
-  catches (void io)
-    [ Handler (\e -> showErrorDialog
-                       . decodeString
-                       . displayException
-                       $ (e :: IOException))
-    , Handler (\e -> showErrorDialog
-                       $ displayException (e :: HPathIOException))
-    ]
-
-
--- |Asks the user which directory copy mode he wants via dialog popup
--- and returns 'DirCopyMode'.
-textInputDialog :: (GlibString s1, GlibString s2)
-                => s1   -- ^ window title
-                -> s2   -- ^ initial text in input widget
-                -> IO (Maybe String)
-textInputDialog title inittext = do
-  chooserDialog <- messageDialogNew Nothing
-                                    [DialogDestroyWithParent]
-                                    MessageQuestion
-                                    ButtonsNone
-                                    title
-  entry <- entryNew
-  entrySetText entry inittext
-  cbox <- dialogGetActionArea chooserDialog
-  _ <- dialogAddButton chooserDialog "Ok"     (ResponseUser 0)
-  _ <- dialogAddButton chooserDialog "Cancel" (ResponseUser 1)
-  boxPackStart (castToBox cbox) entry PackNatural 5
-  widgetShowAll chooserDialog
-  rID <- dialogRun chooserDialog
-  ret <- case rID of
-           -- TODO: make this more safe
-           ResponseUser 0 -> Just <$> entryGetText entry
-           ResponseUser 1 -> return Nothing
-           _              -> throwIO UnknownDialogButton
-  widgetDestroy chooserDialog
-  return ret
-
-
-showFilePropertyDialog :: [Item] -> MyGUI -> MyView -> IO ()
-showFilePropertyDialog [item] mygui _ = do
-  dialog <- messageDialogNew Nothing
-                             [DialogDestroyWithParent]
-                             MessageInfo
-                             ButtonsNone
-                             "File Properties"
-
-  let fprop' = fprop mygui
-      grid   = fpropGrid fprop'
-
-  entrySetText (fpropFnEntry fprop')  (maybe BS.empty P.fromRel
-                                        $ P.basename . path $ item)
-  entrySetText (fpropLocEntry fprop') (P.fromAbs . P.dirname . path $ item)
-  entrySetText (fpropTsEntry fprop')  (show . fileSize $ fvar item)
-  entrySetText (fpropModEntry fprop') (packModTime item)
-  entrySetText (fpropAcEntry fprop')  (packAccessTime item)
-  entrySetText (fpropFTEntry fprop')  (packFileType item)
-  entrySetText (fpropPermEntry fprop')
-               (tail $ packPermissions item) -- throw away the filetype part
-  case packLinkDestination item of
-    (Just dest) -> do
-      widgetSetSensitive (fpropLDEntry fprop') True
-      entrySetText (fpropLDEntry fprop') dest
-    Nothing     -> do
-      widgetSetSensitive (fpropLDEntry fprop') False
-      entrySetText (fpropLDEntry fprop') "( Not a symlink )"
-
-
-  cbox <- dialogGetActionArea dialog
-  _ <- dialogAddButton dialog "Ok"     (ResponseUser 0)
-  _ <- dialogAddButton dialog "Cancel" (ResponseUser 1)
-  boxPackStart (castToBox cbox) grid PackNatural 5
-
-  widgetShowAll dialog
-  _ <- dialogRun dialog
-
-  -- make sure our grid does not get destroyed
-  containerRemove (castToBox cbox) grid
-
-  widgetDestroy dialog
-
-  return ()
-showFilePropertyDialog _ _ _ = return ()
-

src/HSFM/GUI/Gtk/Errors.hs

@@ -1,34 +0,0 @@
-{--
-HSFM, a filemanager written in Haskell.
-Copyright (C) 2016 Julian Ospald
-
-This program is free software; you can redistribute it and/or
-modify it under the terms of the GNU General Public License
-version 2 as published by the Free Software Foundation.
-
-This program is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with this program; if not, write to the Free Software
-Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
---}
-
-{-# OPTIONS_HADDOCK ignore-exports #-}
-
--- |Provides error handling for Gtk.
-module HSFM.GUI.Gtk.Errors where
-
-
-import Control.Exception
-import Data.Typeable
-
-
-
-data GtkException = UnknownDialogButton
-  deriving (Show, Typeable)
-
-instance Exception GtkException
-

src/HSFM/GUI/Gtk/MyGUI.hs

@@ -1,120 +0,0 @@
-{--
-HSFM, a filemanager written in Haskell.
-Copyright (C) 2016 Julian Ospald
-
-This program is free software; you can redistribute it and/or
-modify it under the terms of the GNU General Public License
-version 2 as published by the Free Software Foundation.
-
-This program is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with this program; if not, write to the Free Software
-Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
---}
-
-{-# LANGUAGE RecordWildCards #-}
-{-# OPTIONS_HADDOCK ignore-exports #-}
-
-module HSFM.GUI.Gtk.MyGUI where
-
-
-import Control.Concurrent.STM
-  (
-    newTVarIO
-  )
-import Graphics.UI.Gtk
-import HSFM.FileSystem.UtilTypes
-import HSFM.GUI.Gtk.Data
-import Paths_hsfm
-  (
-    getDataFileName
-  )
-
-
-
-
-    -------------------------
-    --[ Main Window Setup ]--
-    -------------------------
-
-
--- |Set up the GUI. This only creates the permanent widgets.
-createMyGUI :: IO MyGUI
-createMyGUI = do
-  let settings' = MkFMSettings False True 24
-  settings <- newTVarIO settings'
-  operationBuffer <- newTVarIO None
-
-  builder <- builderNew
-  builderAddFromFile builder =<< getDataFileName "data/Gtk/builder.xml"
-
-  -- get the pre-defined gui widgets
-  rootWin           <- builderGetObject builder castToWindow
-                       "rootWin"
-  menubarFileQuit   <- builderGetObject builder castToImageMenuItem
-                       "menubarFileQuit"
-  menubarHelpAbout  <- builderGetObject builder castToImageMenuItem
-                      "menubarHelpAbout"
-  statusBar         <- builderGetObject builder castToStatusbar
-                       "statusBar"
-  clearStatusBar    <- builderGetObject builder castToButton
-                       "clearStatusBar"
-  fpropGrid         <- builderGetObject builder castToGrid
-                       "fpropGrid"
-  fpropFnEntry      <- builderGetObject builder castToEntry
-                       "fpropFnEntry"
-  fpropLocEntry     <- builderGetObject builder castToEntry
-                       "fpropLocEntry"
-  fpropTsEntry      <- builderGetObject builder castToEntry
-                       "fpropTsEntry"
-  fpropModEntry     <- builderGetObject builder castToEntry
-                       "fpropModEntry"
-  fpropAcEntry      <- builderGetObject builder castToEntry
-                       "fpropAcEntry"
-  fpropFTEntry      <- builderGetObject builder castToEntry
-                       "fpropFTEntry"
-  fpropPermEntry    <- builderGetObject builder castToEntry
-                       "fpropPermEntry"
-  fpropLDEntry      <- builderGetObject builder castToEntry
-                       "fpropLDEntry"
-  notebook1         <- builderGetObject builder castToNotebook
-                       "notebook1"
-  notebook2         <- builderGetObject builder castToNotebook
-                       "notebook2"
-  leftNbIcon        <- builderGetObject builder castToImage
-                       "leftNbIcon"
-  rightNbIcon       <- builderGetObject builder castToImage
-                       "rightNbIcon"
-  leftNbBtn         <- builderGetObject builder castToToggleButton
-                       "leftNbBtn"
-  rightNbBtn        <- builderGetObject builder castToToggleButton
-                       "rightNbBtn"
-
-
-  -- this is required so that hotkeys work as expected, because
-  -- we then can connect to signals from `viewBox` more reliably
-  widgetSetCanFocus notebook1 False
-  widgetSetCanFocus notebook2 False
-
-  -- notebook toggle buttons
-  buttonSetImage leftNbBtn leftNbIcon
-  buttonSetImage rightNbBtn rightNbIcon
-  widgetSetSensitive leftNbIcon False
-  widgetSetSensitive rightNbIcon False
-  toggleButtonSetActive leftNbBtn True
-  toggleButtonSetActive rightNbBtn True
-
-  -- construct the gui object
-  let menubar = MkMenuBar {..}
-  let fprop = MkFilePropertyGrid {..}
-  let mygui  = MkMyGUI {..}
-
-  -- sets the default icon
-  _ <- windowSetDefaultIconFromFile
-         =<< getDataFileName "data/Gtk/icons/hsfm.png"
-
-  return mygui

src/HSFM/GUI/Gtk/MyView.hs

@@ -1,434 +0,0 @@
-{--
-HSFM, a filemanager written in Haskell.
-Copyright (C) 2016 Julian Ospald
-
-This program is free software; you can redistribute it and/or
-modify it under the terms of the GNU General Public License
-version 2 as published by the Free Software Foundation.
-
-This program is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with this program; if not, write to the Free Software
-Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
---}
-
-{-# LANGUAGE RecordWildCards #-}
-
-
-module HSFM.GUI.Gtk.MyView where
-
-
-import Control.Concurrent.MVar
-  (
-    newEmptyMVar
-  , putMVar
-  , tryTakeMVar
-  )
-import Control.Concurrent.STM
-  (
-    newTVarIO
-  , readTVarIO
-  )
-import Control.Monad
-  (
-    unless
-  , void
-  , when
-  )
-import Control.Monad.IO.Class
-  (
-    liftIO
-  )
-import Data.Foldable
-  (
-    for_
-  )
-import Data.Maybe
-  (
-    catMaybes
-  , fromJust
-  )
-import Data.String
-  (
-    fromString
-  )
-import Graphics.UI.Gtk
-import {-# SOURCE #-} HSFM.GUI.Gtk.Callbacks (setViewCallbacks)
-import qualified HPath as P
-import HSFM.FileSystem.FileType
-import HSFM.GUI.Glib.GlibString()
-import HSFM.GUI.Gtk.Data
-import HSFM.GUI.Gtk.Icons
-import HSFM.GUI.Gtk.Utils
-import HSFM.History
-import HSFM.Utils.IO
-import Paths_hsfm
-  (
-    getDataFileName
-  )
-import Prelude hiding(readFile)
-import System.INotify
-  (
-    addWatch
-  , initINotify
-  , killINotify
-  , EventVariety(..)
-  )
-import System.IO.Error
-  (
-    catchIOError
-  , ioError
-  , isUserError
-  )
-import System.Posix.FilePath
-  (
-    hiddenFile
-  )
-
-
-
--- |Creates a new tab with its own view and refreshes the view.
-newTab :: MyGUI -> Notebook -> IO FMView -> Item -> Int -> IO MyView
-newTab mygui nb iofmv item pos = do
-
-
-  -- create eventbox with label
-  label <- labelNewWithMnemonic
-    (maybe (P.fromAbs $ path item) P.fromRel $ P.basename $ path item)
-  ebox <- eventBoxNew
-  eventBoxSetVisibleWindow ebox False
-  containerAdd ebox label
-  widgetShowAll label
-
-  myview <- createMyView mygui nb iofmv
-  _ <- notebookInsertPageMenu (notebook myview) (viewBox myview)
-    ebox ebox pos
-
-  -- set initial history
-  let historySize = 5
-  putMVar (history myview)
-          (BrowsingHistory [] (path item) [] historySize)
-
-  notebookSetTabReorderable (notebook myview) (viewBox myview) True
-
-  catchIOError (refreshView mygui myview item) $ \e -> do
-    file <- pathToFile getFileInfo . fromJust . P.parseAbs . fromString
-      $ "/"
-    refreshView mygui myview file
-    labelSetText label (fromString "/" :: String)
-    unless (isUserError e) (ioError e)
-
-  -- close callback
-  _ <- ebox `on` buttonPressEvent $ do
-    eb <- eventButton
-    case eb of
-      MiddleButton -> liftIO $ do
-        n <- notebookGetNPages (notebook myview)
-        when (n > 1) $ void $ destroyView myview
-        return True
-      _ -> return False
-
-  return myview
-
-
--- |Constructs the initial MyView object with a few dummy models.
--- It also initializes the callbacks.
-createMyView :: MyGUI
-             -> Notebook
-             -> IO FMView
-             -> IO MyView
-createMyView mygui nb iofmv = do
-  inotify <- newEmptyMVar
-  history <- newEmptyMVar
-
-  builder <- builderNew
-  builderAddFromFile builder =<< getDataFileName "data/Gtk/builder.xml"
-
-  -- create dummy models, so we don't have to use MVar
-  rawModel <- newTVarIO =<< listStoreNew []
-  filteredModel <- newTVarIO =<< (\x -> treeModelFilterNew x [])
-                             =<< readTVarIO rawModel
-  sortedModel <- newTVarIO =<< treeModelSortNewWithModel
-                           =<< readTVarIO filteredModel
-  cwd <- newEmptyMVar
-  view' <- iofmv
-  view  <- newTVarIO view'
-
-  urlBar            <- builderGetObject builder castToEntry
-                       "urlBar"
-
-  backViewB         <- builderGetObject builder castToButton
-                       "backViewB"
-  upViewB           <- builderGetObject builder castToButton
-                       "upViewB"
-  forwardViewB      <- builderGetObject builder castToButton
-                       "forwardViewB"
-  homeViewB         <- builderGetObject builder castToButton
-                       "homeViewB"
-  refreshViewB      <- builderGetObject builder castToButton
-                       "refreshViewB"
-  scroll            <- builderGetObject builder castToScrolledWindow
-                       "mainScroll"
-  viewBox           <- builderGetObject builder castToBox
-                         "viewBox"
-
-  let notebook = nb
-  let myview = MkMyView {..}
-
-  -- set the bindings
-  setViewCallbacks mygui myview
-
-  -- add the treeview to the scroll container
-  let oview = fmViewToContainer view'
-  containerAdd scroll oview
-
-  widgetShowAll viewBox
-
-  return myview
-
-
--- |Switch the existing view in `MyView` with the one that the
--- io action returns.
-switchView :: MyGUI -> MyView -> IO FMView -> IO ()
-switchView mygui myview iofmv = do
-  cwd <- getCurrentDir myview
-
-  let nb = notebook myview
-
-  oldpage <- destroyView myview
-
-  -- create new view and tab page where the previous one was
-  nview <- newTab mygui nb iofmv cwd oldpage
-
-  page <- fromJust <$> notebookPageNum nb (viewBox nview)
-  notebookSetCurrentPage nb page
-
-  refreshView mygui nview cwd
-
-
--- |Destroys the given view by disconnecting the watcher
--- and destroying the active FMView container.
---
--- Everything that needs to be done in order to forget about a
--- view needs to be done here.
---
--- Returns the page in the tab list this view corresponds to.
-destroyView :: MyView -> IO Int
-destroyView myview = do
-  -- disconnect watcher
-  mi <- tryTakeMVar (inotify myview)
-  for_ mi $ \i -> killINotify i
-
-  page <- fromJust <$> notebookPageNum (notebook myview) (viewBox myview)
-
-  -- destroy old view and tab page
-  view' <- readTVarIO $ view myview
-  widgetDestroy (fmViewToContainer view')
-  notebookRemovePage (notebook myview) page
-
-  return page
-
-
--- |Createss an IconView.
-createIconView :: IO FMView
-createIconView = do
-  iconv <- iconViewNew
-  iconViewSetSelectionMode iconv SelectionMultiple
-  iconViewSetColumns iconv (-1)
-  iconViewSetSpacing iconv 2
-  iconViewSetMargin iconv 0
-  {- set iconv [ iconViewItemOrientation := OrientationHorizontal ] -}
-  {- set iconv [ iconViewOrientation := OrientationHorizontal ] -}
-
-  return $ FMIconView iconv
-
-
--- |Creates a TreeView.
-createTreeView :: IO FMView
-createTreeView = do
-  -- create the final view
-  treeView <- treeViewNew
-  -- set selection mode
-  tvs <- treeViewGetSelection treeView
-  treeSelectionSetMode tvs SelectionMultiple
-
-  -- set drag and drop
-  tl <- targetListNew
-  atom <- atomNew ("HSFM" :: String)
-  targetListAdd tl atom [TargetSameApp] 0
-  treeViewEnableModelDragDest treeView tl [ActionCopy]
-  treeViewEnableModelDragSource treeView [Button1] tl [ActionCopy]
-
-  -- create final tree model columns
-  renderTxt <- cellRendererTextNew
-  renderPix <- cellRendererPixbufNew
-  let ct = cellText   :: (CellRendererTextClass cr) => Attr cr String
-      cp = cellPixbuf :: (CellRendererPixbufClass self) => Attr self Pixbuf
-
-  -- filename column
-  cF <- treeViewColumnNew
-  treeViewColumnSetTitle        cF ("Filename" :: String)
-  treeViewColumnSetResizable    cF True
-  treeViewColumnSetClickable    cF True
-  treeViewColumnSetSortColumnId cF 1
-  cellLayoutPackStart cF renderPix False
-  cellLayoutPackStart cF renderTxt True
-  _ <- treeViewAppendColumn treeView cF
-  cellLayoutAddColumnAttribute cF renderPix cp $ makeColumnIdPixbuf 0
-  cellLayoutAddColumnAttribute cF renderTxt ct $ makeColumnIdString 1
-
-  -- date column
-  cMD <- treeViewColumnNew
-  treeViewColumnSetTitle        cMD ("Date" :: String)
-  treeViewColumnSetResizable    cMD True
-  treeViewColumnSetClickable    cMD True
-  treeViewColumnSetSortColumnId cMD 2
-  cellLayoutPackStart cMD renderTxt True
-  _ <- treeViewAppendColumn treeView cMD
-  cellLayoutAddColumnAttribute cMD renderTxt ct $ makeColumnIdString 2
-
-  -- permissions column
-  cP <- treeViewColumnNew
-  treeViewColumnSetTitle        cP ("Permission" :: String)
-  treeViewColumnSetResizable    cP True
-  treeViewColumnSetClickable    cP True
-  treeViewColumnSetSortColumnId cP 3
-  cellLayoutPackStart cP renderTxt True
-  _ <- treeViewAppendColumn treeView cP
-  cellLayoutAddColumnAttribute cP renderTxt ct $ makeColumnIdString 3
-
-  return $ FMTreeView treeView
-
-
--- |Refreshes the View based on the given directory.
---
--- Throws:
---
---   - `userError` on inappropriate type
-refreshView :: MyGUI
-             -> MyView
-             -> Item
-             -> IO ()
-refreshView mygui myview SymLink { sdest = Just d@Dir{} } =
-  refreshView mygui myview d
-refreshView mygui myview item@Dir{} = do
-  newRawModel  <- fileListStore item myview
-  writeTVarIO (rawModel myview) newRawModel
-
-  view' <- readTVarIO $ view myview
-
-  _ <- tryTakeMVar (cwd myview)
-  putMVar (cwd myview) item
-
-  -- get selected items
-  tps <- getSelectedTreePaths mygui myview
-  trs <- catMaybes <$> mapM (treeRowReferenceNew newRawModel) tps
-
-  constructView mygui myview
-
-  -- reselect selected items
-  -- TODO: not implemented for icon view yet
-  case view' of
-    FMTreeView treeView -> do
-      tvs <- treeViewGetSelection treeView
-      ntps <- mapM treeRowReferenceGetPath trs
-      mapM_ (treeSelectionSelectPath tvs) ntps
-    _ -> return ()
-refreshView _ _ _ = ioError $ userError "Inappropriate type!"
-
-
--- |Constructs the visible View with the current underlying mutable models,
--- which are retrieved from 'MyGUI'.
---
--- This sort of merges the components mygui and myview and fires up
--- the actual models.
-constructView :: MyGUI
-              -> MyView
-              -> IO ()
-constructView mygui myview = do
-  settings' <- readTVarIO $ settings mygui
-
-  -- pix stuff
-  iT           <- iconThemeGetDefault
-  folderPix    <- getIcon IFolder iT (iconSize settings')
-  folderSymPix <- getSymlinkIcon IFolder iT (iconSize settings')
-  filePix      <- getIcon IFile iT (iconSize settings')
-  fileSymPix   <- getSymlinkIcon IFile iT (iconSize settings')
-  errorPix     <- getIcon IError iT (iconSize settings')
-  let dirtreePix Dir{}           = folderPix
-      dirtreePix FileLike{}      = filePix
-      dirtreePix DirSym{}        = folderSymPix
-      dirtreePix FileLikeSym{}   = fileSymPix
-      dirtreePix BrokenSymlink{} = errorPix
-      dirtreePix _               = errorPix
-
-
-  view' <- readTVarIO $ view myview
-
-  cdir <- getCurrentDir myview
-  let cdirp = path cdir
-
-  -- update urlBar
-  entrySetText (urlBar myview) (P.fromAbs cdirp)
-
-  rawModel' <- readTVarIO $ rawModel myview
-
-  -- filtering
-  filteredModel' <- treeModelFilterNew rawModel' []
-  writeTVarIO (filteredModel myview) filteredModel'
-  treeModelFilterSetVisibleFunc filteredModel' $ \iter -> do
-     hidden <- showHidden <$> readTVarIO (settings mygui)
-     item   <- treeModelGetRow rawModel' iter >>= (P.basename . path)
-     if hidden
-       then return True
-       else return . not . hiddenFile . P.fromRel $ item
-
-  -- sorting
-  sortedModel' <- treeModelSortNewWithModel filteredModel'
-  writeTVarIO (sortedModel myview) sortedModel'
-  treeSortableSetSortFunc sortedModel' 1 $ \iter1 iter2 -> do
-      cIter1 <- treeModelFilterConvertIterToChildIter filteredModel' iter1
-      cIter2 <- treeModelFilterConvertIterToChildIter filteredModel' iter2
-      item1  <- treeModelGetRow rawModel' cIter1
-      item2  <- treeModelGetRow rawModel' cIter2
-      return $ compare item1 item2
-  treeSortableSetSortColumnId sortedModel' 1 SortAscending
-
-  -- set values
-  treeModelSetColumn rawModel' (makeColumnIdPixbuf 0)
-                     dirtreePix
-  treeModelSetColumn rawModel' (makeColumnIdString 1)
-                     (P.toFilePath . fromJust . P.basename . path)
-  treeModelSetColumn rawModel' (makeColumnIdString 2)
-                     packModTime
-  treeModelSetColumn rawModel' (makeColumnIdString 3)
-                     packPermissions
-
-  -- update model of view
-  case view' of
-    FMTreeView treeView -> do
-      treeViewSetModel treeView (Just sortedModel')
-      treeViewSetRubberBanding treeView True
-    FMIconView iconView -> do
-      iconViewSetModel iconView (Just sortedModel')
-      iconViewSetPixbufColumn iconView
-                              (makeColumnIdPixbuf 0 :: ColumnId item Pixbuf)
-      iconViewSetTextColumn iconView
-                            (makeColumnIdString 1 :: ColumnId item String)
-
-  -- add watcher
-  mi <- tryTakeMVar (inotify myview)
-  for_ mi $ \i -> killINotify i
-  newi <- initINotify
-  _ <- addWatch
-         newi
-         [Move, MoveIn, MoveOut, MoveSelf, Create, Delete, DeleteSelf]
-         (P.fromAbs cdirp)
-         (\_ -> postGUIAsync $ refreshView mygui myview cdir)
-  putMVar (inotify myview) newi
-
-  return ()

src/HSFM/GUI/Gtk/Plugins.hs

@@ -1,112 +0,0 @@
-{--
-HSFM, a filemanager written in Haskell.
-Copyright (C) 2016 Julian Ospald
-
-This program is free software; you can redistribute it and/or
-modify it under the terms of the GNU General Public License
-version 2 as published by the Free Software Foundation.
-
-This program is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with this program; if not, write to the Free Software
-Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
---}
-
-
-{-# OPTIONS_HADDOCK ignore-exports #-}
-{-# OPTIONS_GHC -Wno-unused-imports #-}
-
-
-module HSFM.GUI.Gtk.Plugins where
-
-
-import Graphics.UI.Gtk
-import HPath
-import HSFM.FileSystem.FileType
-import HSFM.GUI.Gtk.Data
-import HSFM.GUI.Gtk.Settings
-import HSFM.GUI.Gtk.Utils
-import HSFM.Settings
-import Control.Monad
-  (
-    forM
-  , forM_
-  , void
-  )
-import System.Posix.Process.ByteString
-  (
-    executeFile
-  , forkProcess
-  )
-import Data.ByteString.UTF8
-  (
-    fromString
-  )
-import qualified Data.ByteString as BS
-
-
-
-
-
-    ---------------
-    --[ Plugins ]--
-    ---------------
-
-
-
-
----- Global settings ----
-
-
-
--- |Where to start inserting plugins.
-insertPos :: Int
-insertPos = 4
-
-
--- |A list of plugins to add to the right-click menu at position
--- `insertPos`.
---
--- The left part of the triple is a function that returns the menuitem.
--- The middle part of the triple is a filter function that
--- decides whether the item is shown.
--- The right part of the triple is the callback, which is invoked
--- when the menu item is clicked.
---
--- Plugins are added in order of this list.
-myplugins :: [(IO MenuItem
-              ,[Item] -> MyGUI -> MyView -> IO Bool
-              ,[Item] -> MyGUI -> MyView -> IO ())
-             ]
-myplugins = [(diffItem, diffFilter, diffCallback)
-            ]
-
-
-
-
-
----- The plugins ----
-
-
-
-diffItem :: IO MenuItem
-diffItem = menuItemNewWithLabel "diff"
-
-diffFilter :: [Item] -> MyGUI -> MyView -> IO Bool
-diffFilter items _ _
-  | length items > 1 = return $ and $ fmap isFileC items
-  | otherwise        = return False
-
-diffCallback :: [Item] -> MyGUI -> MyView -> IO ()
-diffCallback items _ _ = void $
-  forkProcess $
-    executeFile
-      (fromString "meld")
-      True
-      ([fromString "--diff"] ++ fmap (fromAbs . path) items)
-      Nothing
-

src/HSFM/GUI/Gtk/Settings.hs

@@ -1,128 +0,0 @@
-{--
-HSFM, a filemanager written in Haskell.
-Copyright (C) 2016 Julian Ospald
-
-This program is free software; you can redistribute it and/or
-modify it under the terms of the GNU General Public License
-version 2 as published by the Free Software Foundation.
-
-This program is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with this program; if not, write to the Free Software
-Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
---}
-
-{-# LANGUAGE PatternSynonyms #-}
-
-
-module HSFM.GUI.Gtk.Settings where
-
-
-import Graphics.UI.Gtk
-
-
-
-
-    --------------------
-    --[ GUI Settings ]--
-    --------------------
-
-
-
----- Hotkey settings ----
-
-
-pattern QuitModifier :: [Modifier]
-pattern QuitModifier <- [Control]
-
-pattern QuitKey :: String
-pattern QuitKey <- "q"
-
-
-pattern ShowHiddenModifier :: [Modifier]
-pattern ShowHiddenModifier <- [Control]
-
-pattern ShowHiddenKey :: String
-pattern ShowHiddenKey <- "h"
-
-
-pattern UpDirModifier :: [Modifier]
-pattern UpDirModifier <- [Alt]
-
-pattern UpDirKey :: String
-pattern UpDirKey <- "Up"
-
-
-pattern HistoryBackModifier :: [Modifier]
-pattern HistoryBackModifier <- [Alt]
-
-pattern HistoryBackKey :: String
-pattern HistoryBackKey <- "Left"
-
-
-pattern HistoryForwardModifier :: [Modifier]
-pattern HistoryForwardModifier <- [Alt]
-
-pattern HistoryForwardKey :: String
-pattern HistoryForwardKey <- "Right"
-
-
-pattern DeleteModifier :: [Modifier]
-pattern DeleteModifier <- []
-
-pattern DeleteKey :: String
-pattern DeleteKey <- "Delete"
-
-
-pattern OpenModifier :: [Modifier]
-pattern OpenModifier <- []
-
-pattern OpenKey :: String
-pattern OpenKey <- "Return"
-
-
-pattern CopyModifier :: [Modifier]
-pattern CopyModifier <- [Control]
-
-pattern CopyKey :: String
-pattern CopyKey <- "c"
-
-
-pattern MoveModifier :: [Modifier]
-pattern MoveModifier <- [Control]
-
-pattern MoveKey :: String
-pattern MoveKey <- "x"
-
-
-pattern PasteModifier :: [Modifier]
-pattern PasteModifier <- [Control]
-
-pattern PasteKey :: String
-pattern PasteKey <- "v"
-
-
-pattern NewTabModifier :: [Modifier]
-pattern NewTabModifier <- [Control]
-
-pattern NewTabKey :: String
-pattern NewTabKey <- "t"
-
-
-pattern CloseTabModifier :: [Modifier]
-pattern CloseTabModifier <- [Control]
-
-pattern CloseTabKey :: String
-pattern CloseTabKey <- "w"
-
-
-pattern OpenTerminalModifier :: [Modifier]
-pattern OpenTerminalModifier <- []
-
-pattern OpenTerminalKey :: String
-pattern OpenTerminalKey <- "F4"
-

src/HSFM/GUI/Gtk/Utils.hs

@@ -1,154 +0,0 @@
-{--
-HSFM, a filemanager written in Haskell.
-Copyright (C) 2016 Julian Ospald
-
-This program is free software; you can redistribute it and/or
-modify it under the terms of the GNU General Public License
-version 2 as published by the Free Software Foundation.
-
-This program is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with this program; if not, write to the Free Software
-Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
---}
-
-{-# OPTIONS_HADDOCK ignore-exports #-}
-
-module HSFM.GUI.Gtk.Utils where
-
-
-import Control.Concurrent.MVar
-  (
-    readMVar
-  )
-import Control.Concurrent.STM
-  (
-    readTVarIO
-  )
-import Data.Maybe
-  (
-    catMaybes
-  , fromJust
-  )
-import Data.Traversable
-  (
-    forM
-  )
-import Graphics.UI.Gtk
-import HSFM.FileSystem.FileType
-import HSFM.GUI.Gtk.Data
-import Prelude hiding(getContents)
-
-
-
-    -----------------
-    --[ Utilities ]--
-    -----------------
-
-
-getSelectedTreePaths :: MyGUI -> MyView -> IO [TreePath]
-getSelectedTreePaths _ myview = do
-  view' <- readTVarIO $ view myview
-  case view' of
-    FMTreeView treeView -> do
-      tvs   <- treeViewGetSelection treeView
-      treeSelectionGetSelectedRows tvs
-    FMIconView iconView ->
-      iconViewGetSelectedItems iconView
-
-
--- |Gets the currently selected item of the treeView, if any.
-getSelectedItems :: MyGUI
-                 -> MyView
-                 -> IO [Item]
-getSelectedItems mygui myview = do
-  tps   <- getSelectedTreePaths mygui myview
-  catMaybes <$> mapM (rawPathToItem myview) tps
-
-
--- |Carry out an action on the currently selected item.
---
--- If there is no item selected, does nothing.
-withItems :: MyGUI
-          -> MyView
-          -> (   [Item]
-              -> MyGUI
-              -> MyView
-              -> IO a) -- ^ action to carry out
-          -> IO a
-withItems mygui myview io = do
-  items <- getSelectedItems mygui myview
-  io items mygui myview
-
-
--- |Create the 'ListStore' of files/directories from the current directory.
--- This is the function which maps the Data.DirTree data structures
--- into the GTK+ data structures.
-fileListStore :: Item  -- ^ current dir
-              -> MyView
-              -> IO (ListStore Item)
-fileListStore dt _ = do
-  cs <- getContents getFileInfo dt
-  listStoreNew cs
-
-
--- |Currently unsafe. This is used to obtain any item, which will
--- fail if there is none.
-getFirstItem :: MyView
-             -> IO Item
-getFirstItem myview = do
-  rawModel' <- readTVarIO $ rawModel myview
-  iter      <- fromJust <$> treeModelGetIterFirst rawModel'
-  treeModelGetRow rawModel' iter
-
-
--- |Reads the current directory from MyView.
---
--- This reads the MVar and may block the main thread if it's
--- empty.
-getCurrentDir :: MyView
-              -> IO Item
-getCurrentDir myview = readMVar (cwd myview)
-
-
--- |Push a message to the status bar.
-pushStatusBar :: MyGUI -> String -> IO (ContextId, MessageId)
-pushStatusBar mygui str = do
-  let sb = statusBar mygui
-  cid <- statusbarGetContextId sb "FM Status"
-  mid <- statusbarPush sb cid str
-  return (cid, mid)
-
-
--- |Pop a message from the status bar.
-popStatusbar :: MyGUI -> IO ()
-popStatusbar mygui = do
-  let sb = statusBar mygui
-  cid <- statusbarGetContextId sb "FM Status"
-  statusbarPop sb cid
-
-
--- |Turn a path on the rawModel into a path that we can
--- use at the outermost model layer.
-rawPathToIter :: MyView -> TreePath -> IO (Maybe TreeIter)
-rawPathToIter myview tp = do
-  fmodel <- readTVarIO (filteredModel myview)
-  smodel <- readTVarIO (sortedModel myview)
-  msiter <- treeModelGetIter smodel tp
-  forM msiter $ \siter -> do
-    cIter <- treeModelSortConvertIterToChildIter smodel siter
-    treeModelFilterConvertIterToChildIter fmodel cIter
-
-
--- |Turn a path on the rawModel into the corresponding item
--- that we can use at the outermost model layer.
-rawPathToItem :: MyView -> TreePath -> IO (Maybe Item)
-rawPathToItem myview tp = do
-  rawModel' <- readTVarIO $ rawModel myview
-  miter     <- rawPathToIter myview tp
-  forM miter $ \iter -> treeModelGetRow rawModel' iter
-

src/HSFM/History.hs

@@ -1,61 +0,0 @@
-{--
-HSFM, a filemanager written in Haskell.
-Copyright (C) 2016 Julian Ospald
-
-This program is free software; you can redistribute it and/or
-modify it under the terms of the GNU General Public License
-version 2 as published by the Free Software Foundation.
-
-This program is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with this program; if not, write to the Free Software
-Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
---}
-
-{-# OPTIONS_HADDOCK ignore-exports #-}
-
-module HSFM.History where
-
-
-import HPath
-  (
-    Abs
-  , Path
-  )
-
-
-
--- |Browsing history. For `forwardHistory` and `backwardsHistory`
--- the first item is the most recent one.
-data BrowsingHistory = BrowsingHistory {
-    backwardsHistory :: [Path Abs]
-  , currentDir       :: Path Abs
-  , forwardHistory   :: [Path Abs]
-  , maxSize          :: Int
-}
-
-
--- |This is meant to be called after e.g. a new path is entered
--- (not navigated to via the history) and the history needs updating.
-historyNewPath :: Path Abs -> BrowsingHistory -> BrowsingHistory
-historyNewPath p (BrowsingHistory b cd _ s) =
-  BrowsingHistory (take s $ cd:b) p [] s
-
-
--- |Go back one step in the history.
-historyBack :: BrowsingHistory -> BrowsingHistory
-historyBack bh@(BrowsingHistory [] _ _ _)   = bh
-historyBack (BrowsingHistory (b:bs) cd fs s) =
-  BrowsingHistory bs b (take s $ cd:fs) s
-
-
--- |Go forward one step in the history.
-historyForward :: BrowsingHistory -> BrowsingHistory
-historyForward bh@(BrowsingHistory _ _ [] _) = bh
-historyForward (BrowsingHistory bs cd (f:fs) s) =
-  BrowsingHistory (take s $ cd:bs) f fs s
-

src/HSFM/Settings.hs

@@ -1,67 +0,0 @@
-{--
-HSFM, a filemanager written in Haskell.
-Copyright (C) 2016 Julian Ospald
-
-This program is free software; you can redistribute it and/or
-modify it under the terms of the GNU General Public License
-version 2 as published by the Free Software Foundation.
-
-This program is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with this program; if not, write to the Free Software
-Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
---}
-
-{-# OPTIONS_HADDOCK ignore-exports #-}
-
-
-module HSFM.Settings where
-
-
-import Data.ByteString
-  (
-    ByteString
-  )
-import qualified Data.ByteString.UTF8 as BU
-import Data.Maybe
-import System.Posix.Env.ByteString
-import System.Posix.Process.ByteString
-
-
-
-    -----------------------
-    --[ Common Settings ]--
-    -----------------------
-
-
-
-
----- Command settings ----
-
-
-
--- |The terminal command. This should call `executeFile` in the end
--- with the appropriate arguments.
-terminalCommand :: ByteString  -- ^ current directory of the FM
-                -> IO a
-terminalCommand cwd =
-  executeFile                   -- executes the given command
-    (BU.fromString "sakura")    -- the terminal command
-    True                        -- whether to search PATH
-    [BU.fromString "-d", cwd]   -- arguments for the command
-    Nothing                     -- optional custom environment: `Just [(String, String)]`
-
-
--- |The home directory. If you want to set it explicitly, you might
--- want to do:
---
--- @
--- home = return "\/home\/wurst"
--- @
-home :: IO ByteString
-home = fromMaybe <$> return (BU.fromString "/") <*> getEnv (BU.fromString "HOME")
-

src/IO/Error.hs

@@ -0,0 +1,127 @@
+{--
+HSFM, a filemanager written in Haskell.
+Copyright (C) 2015 Julian Ospald
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+version 2 as published by the Free Software Foundation.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
+--}
+
+{-# OPTIONS_HADDOCK ignore-exports #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+
+-- |Provides error handling.
+module IO.Error where
+
+
+import Control.Applicative
+  (
+    (<$>)
+  )
+import Control.Exception
+import Control.Monad
+  (
+    unless
+  , void
+  , when
+  )
+import Data.List
+  (
+    isPrefixOf
+  )
+import Data.Typeable
+import IO.Utils
+import System.Directory
+  (
+    doesDirectoryExist
+  , doesFileExist
+  )
+import System.FilePath
+  (
+    equalFilePath
+  , isAbsolute
+  , takeFileName
+  )
+
+import qualified System.Posix.Files as PF
+
+
+data FmIOException = FileDoesNotExist String
+                   | DirDoesNotExist String
+                   | PathNotAbsolute String
+                   | FileNotExecutable String
+                   | SameFile String String
+                   | NotAFile String
+                   | NotADir String
+                   | DestinationInSource String String
+                   | FileDoesExist String
+                   | DirDoesExist String
+                   | IsSymlink String
+  deriving (Show, Typeable)
+
+
+instance Exception FmIOException
+
+
+-- Throws an exception if the filepath is not absolute
+-- or the file does not exist.
+fileSanityThrow :: FilePath -> IO ()
+fileSanityThrow fp = throwNotAbsolute fp >> throwFileDoesNotExist fp
+
+
+-- Throws an exception if the filepath is not absolute
+-- or the dir does not exist.
+dirSanityThrow :: FilePath -> IO ()
+dirSanityThrow fp = throwNotAbsolute fp >> throwDirDoesNotExist fp
+
+
+throwNotAbsolute :: FilePath -> IO ()
+throwNotAbsolute fp = unless (isAbsolute fp) (throw $ PathNotAbsolute fp)
+
+
+throwFileDoesExist :: FilePath -> IO ()
+throwFileDoesExist fp =
+  whenM (doesFileExist fp) (throw $ FileDoesExist fp)
+
+
+throwDirDoesExist :: FilePath -> IO ()
+throwDirDoesExist fp =
+  whenM (doesDirectoryExist fp) (throw $ DirDoesExist fp)
+
+
+throwDirDoesNotExist :: FilePath -> IO ()
+throwDirDoesNotExist fp =
+  unlessM (doesDirectoryExist fp) (throw $ DirDoesNotExist fp)
+
+
+throwFileDoesNotExist :: FilePath -> IO ()
+throwFileDoesNotExist fp =
+  unlessM (doesFileExist fp) (throw $ FileDoesNotExist fp)
+
+
+throwSameFile :: FilePath -- ^ should be canonicalized
+              -> FilePath -- ^ should be canonicalized
+              -> IO ()
+throwSameFile fp1 fp2 = when (equalFilePath fp1 fp2) (throw $ SameFile fp1 fp2)
+
+
+throwDestinationInSource :: FilePath -- ^ should be canonicalized
+                         -> FilePath -- ^ should be canonicalized
+                         -> IO ()
+throwDestinationInSource source dest =
+  when (source `isPrefixOf` dest) (throw $ DestinationInSource dest source)
+
+
+throwIsSymlink :: FilePath -> IO ()
+throwIsSymlink fp =
+  whenM (PF.isSymbolicLink <$> PF.getSymbolicLinkStatus fp)
+        (throw $ IsSymlink fp)

src/IO/File.hs

@@ -0,0 +1,443 @@
+{--
+HSFM, a filemanager written in Haskell.
+Copyright (C) 2015 Julian Ospald
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+version 2 as published by the Free Software Foundation.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
+--}
+
+{-# OPTIONS_HADDOCK ignore-exports #-}
+
+-- |This module provides all the atomic IO related file operations like
+-- copy, delete, move and so on. It operates only on FilePaths and reads
+-- all necessary file information manually in order to stay atomic and not
+-- rely on the state of passed objects.
+--
+-- It would be nicer to pass states around, but the filesystem state changes
+-- too quickly and cannot be relied upon. Lazy implementations of filesystem
+-- trees have been tried as well, but they can introduce subtle bugs.
+module IO.File where
+
+
+import Control.Applicative
+  (
+    (<$>)
+  )
+import Control.Exception
+  (
+    handle
+  , throw
+  , SomeException(..)
+  )
+import Control.Monad
+  (
+    unless
+  , void
+  )
+import Data.DirTree
+import Data.Foldable
+  (
+    for_
+  )
+import IO.Error
+import IO.Utils
+import System.Directory
+  (
+    doesDirectoryExist
+  , doesFileExist
+  , removeDirectoryRecursive
+  )
+import System.FilePath
+  (
+    equalFilePath
+  , isAbsolute
+  , takeFileName
+  , takeDirectory
+  , (</>)
+  )
+import System.Posix.Directory
+  (
+    createDirectory
+  , removeDirectory
+  )
+import System.Posix.Files
+  (
+    createSymbolicLink
+  , readSymbolicLink
+  , fileAccess
+  , getFileStatus
+  , groupExecuteMode
+  , groupReadMode
+  , groupWriteMode
+  , otherExecuteMode
+  , otherReadMode
+  , otherWriteMode
+  , ownerModes
+  , ownerReadMode
+  , ownerWriteMode
+  , rename
+  , touchFile
+  , unionFileModes
+  , removeLink
+  )
+import System.Posix.IO
+  (
+    closeFd
+  , createFile
+  )
+import System.Posix.Types
+  (
+    FileMode
+  )
+import System.Process
+  (
+    spawnProcess
+  , ProcessHandle
+  )
+
+import qualified System.Directory as SD
+
+import qualified System.Posix.Files as PF
+
+
+-- TODO: file operations should be threaded and not block the UI
+
+
+-- |Data type describing an actual file operation that can be
+-- carried out via `doFile`. Useful to build up a list of operations
+-- or delay operations.
+data FileOperation = FCopy    Copy
+                   | FMove    Move
+                   | FDelete  (AnchoredFile FileInfo)
+                   | FOpen    (AnchoredFile FileInfo)
+                   | FExecute (AnchoredFile FileInfo) [String]
+                   | None
+
+
+-- |Data type describing partial or complete file copy operation.
+-- CC stands for a complete operation and can be used for `runFileOp`.
+data Copy = CP1 (AnchoredFile FileInfo)
+          | CP2 (AnchoredFile FileInfo)
+                (AnchoredFile FileInfo)
+          | CC  (AnchoredFile FileInfo)
+                (AnchoredFile FileInfo)
+                DirCopyMode
+
+
+-- |Data type describing partial or complete file move operation.
+-- MC stands for a complete operation and can be used for `runFileOp`.
+data Move = MP1 (AnchoredFile FileInfo)
+          | MC  (AnchoredFile FileInfo)
+                (AnchoredFile FileInfo)
+
+
+-- |Directory copy modes.
+data DirCopyMode = Strict  -- ^ fail if the target directory already exists
+                 | Merge   -- ^ overwrite files if necessary
+                 | Replace -- ^ remove target directory before copying
+
+
+-- |Run a given FileOperation. If the FileOperation is partial, it will
+-- be returned.
+runFileOp :: FileOperation -> IO (Maybe FileOperation)
+runFileOp (FCopy (CC from to cm)) = easyCopy cm from to >> return Nothing
+runFileOp (FCopy fo)              = return              $ Just $ FCopy fo
+runFileOp (FMove (MC from to))    = moveFile from to    >> return Nothing
+runFileOp (FMove fo)              = return              $ Just $ FMove fo
+runFileOp (FDelete fp)            = easyDelete fp       >> return Nothing
+runFileOp (FOpen fp)              = openFile fp         >> return Nothing
+runFileOp (FExecute fp args)      = executeFile fp args >> return Nothing
+runFileOp _                       = return Nothing
+
+
+
+    --------------------
+    --[ File Copying ]--
+    --------------------
+
+
+-- TODO: allow renaming
+-- |Copies a directory to the given destination with the specified
+-- `DirCopyMode`. Excludes symlinks.
+copyDir :: DirCopyMode
+        -> AnchoredFile FileInfo  -- ^ source dir
+        -> AnchoredFile FileInfo  -- ^ destination dir
+        -> IO ()
+copyDir cm (_ :/ SymLink {}) _ = return ()
+copyDir cm from@(_ :/ Dir fromn _)
+             to@(_ :/ Dir {})
+  = do
+    let fromp    = fullPath from
+        top      = fullPath to
+        destdirp = top </> fromn
+    throwDestinationInSource fromp destdirp
+    throwSameFile fromp destdirp
+
+    createDestdir destdirp
+    destdir <- Data.DirTree.readFile destdirp
+
+    contents <- readDirectory' (fullPath from)
+
+    for_ contents $ \f ->
+      case f of
+        (_ :/ SymLink {})  -> recreateSymlink f destdir
+        (_ :/ Dir {}) -> copyDir cm f destdir
+        (_ :/ RegFile {}) -> copyFileToDir f destdir
+        _                 -> return ()
+  where
+    createDestdir destdir =
+      case cm of
+        Merge   ->
+          unlessM (doesDirectoryExist destdir)
+                  (createDirectory destdir newDirPerms)
+        Strict  -> do
+          throwDirDoesExist destdir
+          createDirectory destdir newDirPerms
+        Replace -> do
+          whenM (doesDirectoryExist destdir) (removeDirectoryRecursive destdir)
+          createDirectory destdir newDirPerms
+    recreateSymlink' f destdir = do
+      let destfilep = fullPath destdir </> (name . file $ f)
+      destfile <- Data.DirTree.readFile destfilep
+
+      _ <- case cm of
+        -- delete old file/dir to be able to create symlink
+        Merge -> easyDelete destfile
+        _     -> return ()
+
+      recreateSymlink f destdir
+copyDir _ _ _ = return ()
+
+
+-- |Recreate a symlink.
+recreateSymlink :: AnchoredFile FileInfo  -- ^ the old symlink file
+                -> AnchoredFile FileInfo  -- ^ destination dir of the
+                                                   --   new symlink file
+                -> IO ()
+recreateSymlink symf@(_ :/ SymLink {})
+                symdest@(_ :/ Dir {})
+  = do
+    symname <- readSymbolicLink (fullPath symf)
+    createSymbolicLink symname (fullPath symdest </> (name . file $ symf))
+recreateSymlink _ _ = return ()
+
+
+-- |Copies the given file to the given file destination.
+-- Excludes symlinks.
+copyFile :: AnchoredFile FileInfo  -- ^ source file
+         -> AnchoredFile FileInfo  -- ^ destination file
+         -> IO ()
+copyFile (_ :/ SymLink {}) _ = return ()
+copyFile from@(_ :/ RegFile {}) to@(_ :/ RegFile {}) = do
+  let from' = fullPath from
+      to'   = fullPath to
+  throwSameFile from' to'
+  SD.copyFile from' to'
+copyFile _ _ = return ()
+
+
+-- |Copies the given file to the given dir with the same filename.
+-- Excludes symlinks.
+copyFileToDir :: AnchoredFile FileInfo
+              -> AnchoredFile FileInfo
+              -> IO ()
+copyFileToDir (_ :/ SymLink {}) _ = return ()
+copyFileToDir from@(_ :/ RegFile fn _)
+                to@(_ :/ Dir {}) =
+  do
+    let from' = fullPath from
+        to'   = fullPath to </> fn
+    SD.copyFile from' to'
+copyFileToDir _ _ = return ()
+
+
+-- |Copies a file, directory or symlink. In case of a symlink, it is just
+-- recreated, even if it points to a directory.
+easyCopy :: DirCopyMode
+         -> AnchoredFile FileInfo
+         -> AnchoredFile FileInfo
+         -> IO ()
+easyCopy _ from@(_ :/ SymLink {}) to@(_ :/ Dir {}) = recreateSymlink from to
+easyCopy _ from@(_ :/ RegFile fn _)
+             to@(_ :/ Dir {})
+  = copyFileToDir from to
+easyCopy _ from@(_ :/ RegFile fn _)
+             to@(_ :/ RegFile {})
+  = copyFile from to
+easyCopy cm from@(_ :/ Dir fn _)
+              to@(_ :/ Dir {})
+  = copyDir cm from to
+easyCopy _ _ _ = return ()
+
+
+
+
+
+    ---------------------
+    --[ File Deletion ]--
+    ---------------------
+
+
+-- |Deletes a symlink, which can either point to a file or directory.
+deleteSymlink :: AnchoredFile FileInfo -> IO ()
+deleteSymlink f@(_ :/ SymLink {})
+  = removeLink (fullPath f)
+deleteSymlink _
+  = return ()
+
+
+-- |Deletes the given file, never symlinks.
+deleteFile :: AnchoredFile FileInfo -> IO ()
+deleteFile   (_ :/ SymLink {}) = return ()
+deleteFile f@(_ :/ RegFile {})
+  = removeLink (fullPath f)
+deleteFile _
+  = return ()
+
+
+-- |Deletes the given directory, never symlinks.
+deleteDir :: AnchoredFile FileInfo -> IO ()
+deleteDir   (_ :/ SymLink {}) = return ()
+deleteDir f@(_ :/ Dir {})
+  = removeDirectory (fullPath f)
+deleteDir _ = return ()
+
+
+-- |Deletes the given directory recursively, never symlinks.
+deleteDirRecursive :: AnchoredFile FileInfo -> IO ()
+deleteDirRecursive   (_ :/ SymLink {}) = return ()
+deleteDirRecursive f@(_ :/ Dir {})
+  = removeDirectoryRecursive (fullPath f)
+deleteDirRecursive _ = return ()
+
+
+-- |Deletes a file, directory or symlink, whatever it may be.
+-- In case of directory, performs recursive deletion. In case of
+-- a symlink, the symlink file is deleted.
+easyDelete :: AnchoredFile FileInfo -> IO ()
+easyDelete f@(_ :/ SymLink {}) = deleteSymlink f
+easyDelete f@(_ :/ RegFile {})
+  = deleteFile f
+easyDelete f@(_ :/ Dir {})
+  = deleteDirRecursive f
+easyDelete _
+  = return ()
+
+
+
+
+    --------------------
+    --[ File Opening ]--
+    --------------------
+
+
+-- |Opens a file appropriately by invoking xdg-open.
+openFile :: AnchoredFile a
+         -> IO ProcessHandle
+openFile f = spawnProcess "xdg-open" [fullPath f]
+
+
+-- |Executes a program with the given arguments.
+executeFile :: AnchoredFile FileInfo  -- ^ program
+            -> [String]               -- ^ arguments
+            -> IO (Maybe ProcessHandle)
+executeFile prog@(_ :/ RegFile {}) args
+  = Just <$> spawnProcess (fullPath prog) args
+executeFile _ _      = return Nothing
+
+
+
+
+    ---------------------
+    --[ File Creation ]--
+    ---------------------
+
+
+createFile :: AnchoredFile FileInfo -> FileName -> IO ()
+createFile (ADirOrSym td) (ValFN fn) = do
+  let fullp = fullPath td </> fn
+  throwFileDoesExist fullp
+  fd <- System.Posix.IO.createFile fullp newFilePerms
+  closeFd fd
+createFile _ _ = return ()
+
+
+createDir :: AnchoredFile FileInfo -> FileName -> IO ()
+createDir (ADirOrSym td) (ValFN fn) = do
+  let fullp = fullPath td </> fn
+  throwDirDoesExist fullp
+  createDirectory fullp newFilePerms
+createDir _ _ = return ()
+
+
+
+
+    ----------------------------
+    --[ File Renaming/Moving ]--
+    ----------------------------
+
+
+renameFile :: AnchoredFile FileInfo -> FileName -> IO ()
+renameFile (_ :/ Failed {}) _ = return ()
+renameFile af (ValFN fn) = do
+  let fromf = fullPath af
+      tof   = anchor af </> fn
+  throwFileDoesExist tof
+  throwSameFile fromf tof
+  rename fromf tof
+renameFile _ _ = return ()
+
+
+-- |Move a given file to the given target directory.
+moveFile :: AnchoredFile FileInfo -- ^ file to move
+         -> AnchoredFile FileInfo -- ^ base target directory
+         -> IO ()
+moveFile from to@(_ :/ Dir {}) = do
+  let from' = fullPath from
+      to'   = fullPath to </> (name . file $ from)
+  throwFileDoesExist to'
+  throwSameFile from' to'
+  -- TODO: don't catch all exceptions!
+  handle (\(SomeException e) -> do
+    easyCopy Strict from to
+    easyDelete from
+    ) $ rename from' to'
+moveFile _ _ = return ()
+
+
+
+
+
+    -----------------------
+    --[ File Permissions]--
+    -----------------------
+
+
+newFilePerms :: FileMode
+newFilePerms
+  =                  ownerWriteMode
+    `unionFileModes` ownerReadMode
+    `unionFileModes` groupWriteMode
+    `unionFileModes` groupReadMode
+    `unionFileModes` otherWriteMode
+    `unionFileModes` otherReadMode
+
+
+newDirPerms :: FileMode
+newDirPerms
+  =                  ownerModes
+    `unionFileModes` groupExecuteMode
+    `unionFileModes` groupReadMode
+    `unionFileModes` otherExecuteMode
+    `unionFileModes` otherReadMode
+

src/IO/Utils.hs

@@ -1,6 +1,6 @@
 {--
 HSFM, a filemanager written in Haskell.
-Copyright (C) 2016 Julian Ospald
+Copyright (C) 2015 Julian Ospald
 
 This program is free software; you can redistribute it and/or
 modify it under the terms of the GNU General Public License
@@ -18,9 +18,8 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
 
 {-# OPTIONS_HADDOCK ignore-exports #-}
 
-
 -- |Random and general IO utilities.
-module HSFM.Utils.IO where
+module IO.Utils where
 
 
 import Control.Concurrent.STM
@@ -33,14 +32,24 @@ import Control.Concurrent.STM.TVar
   , modifyTVar
   , TVar
   )
+import Control.Monad
+  (
+    when
+  , unless
+  )
 
 
--- |Atomically write a TVar.
 writeTVarIO :: TVar a -> a -> IO ()
 writeTVarIO tvar val = atomically $ writeTVar tvar val
 
 
--- |Atomically modify a TVar.
 modifyTVarIO :: TVar a -> (a -> a) -> IO ()
 modifyTVarIO tvar f = atomically $ modifyTVar tvar f
 
+
+whenM :: Monad m => m Bool -> m () -> m ()
+whenM mb a = mb >>= (`when` a)
+
+
+unlessM :: Monad m => m Bool -> m () -> m ()
+unlessM mb a = mb >>= (`unless` a)

src/MyPrelude.hs

@@ -1,6 +1,6 @@
 {--
 HSFM, a filemanager written in Haskell.
-Copyright (C) 2016 Julian Ospald
+Copyright (C) 2015 Julian Ospald
 
 This program is free software; you can redistribute it and/or
 modify it under the terms of the GNU General Public License
@@ -16,17 +16,12 @@ along with this program; if not, write to the Free Software
 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
 --}
 
-module HSFM.Utils.MyPrelude where
+module MyPrelude where
 
 
 import Data.List
 
 
 
--- |Turns any list into a list of the same length with the values
--- being the indices.
--- E.g.: "abdasd" -> [0,1,2,3,4,5]
 listIndices :: [a] -> [Int]
 listIndices = findIndices (const True)
-
-

update-gh-pages.sh

@@ -1,52 +0,0 @@
-#!/bin/bash
-
-SOURCE_BRANCH="master"
-TARGET_BRANCH="gh-pages"
-REPO="https://${GH_TOKEN}@github.com/hasufell/hsfm"
-DOC_LOCATION="/dist/doc/html/hsfm/hsfm-gtk"
-
-
-# Pull requests and commits to other branches shouldn't try to deploy,
-# just build to verify
-if [ "$TRAVIS_PULL_REQUEST" != "false" -o "$TRAVIS_BRANCH" != "$SOURCE_BRANCH" ]; then
-    echo "Skipping docs deploy."
-    exit 0
-fi
-
-
-cd "$HOME"
-git config --global user.email "travis@travis-ci.org"
-git config --global user.name "travis-ci"
-git clone --branch=${TARGET_BRANCH} ${REPO} ${TARGET_BRANCH} || exit 1
-
-# docs
-cd ${TARGET_BRANCH} || exit 1
-echo "Removing old docs."
-rm -rf *
-echo "Adding new docs."
-cp -rf "${TRAVIS_BUILD_DIR}${DOC_LOCATION}"/* . || exit 1
-
-# If there are no changes to the compiled out (e.g. this is a README update)
-# then just bail.
-if [ -z "`git diff --exit-code`" ]; then
-    echo "No changes to the output on this push; exiting."
-    exit 0
-fi
-
-git add -- .
-
-if [[ -e ./index.html ]] ; then
-	echo "Commiting docs."
-	git commit -m "Lastest docs updated
-
-travis build: $TRAVIS_BUILD_NUMBER
-commit: $TRAVIS_COMMIT
-auto-pushed to gh-pages"
-
-	git push origin $TARGET_BRANCH
-	echo "Published docs to gh-pages."
-else
-	echo "Error: docs are empty."
-	exit 1
-fi
-

update-index-state.sh

@@ -1,66 +0,0 @@
-#!/usr/bin/env bash
-
-set -eu
-
-status_message() {
-    printf "\\033[0;32m%s\\033[0m\\n" "$1"
-}
-
-error_message() {
-    printf "\\033[0;31m%s\\033[0m\\n" "$1"
-}
-
-SCRIPTPATH="$( cd "$(dirname "$0")" ; pwd -P )"
-CACHE_LOCATION="${HOME}/.cabal/packages/hackage.haskell.org/01-index.cache"
-
-if [ ! -f "${CACHE_LOCATION}" ] ; then
-	error_message "${CACHE_LOCATION} does not exist, did you run 'cabal update'?"
-	exit 1
-fi
-
-if [ ! -f "${SCRIPTPATH}/cabal.project" ] ; then
-	error_message "Could not find ${SCRIPTPATH}/cabal.project, skipping index state update."
-	exit 3
-fi
-
-cabal v2-update
-
-arch=$(getconf LONG_BIT)
-
-case "${arch}" in
-32)
-	byte_size=4
-	magic_word="CABA1002"
-    ;;
-64)
-	byte_size=8
-	magic_word="00000000CABA1002"
-    ;;
-*)
-	error_message "Unknown architecture (long bit): ${arch}"
-	exit 2
-    ;;
-esac
-
-# This is the logic to parse the binary format of 01-index.cache.
-# The first word is a magic 'caba1002', the second one is the timestamp in unix epoch.
-# Better than copying the cabal-install source code.
-if [ "$(xxd -u -p -l${byte_size} -s 0 "${CACHE_LOCATION}")" != "${magic_word}" ] ; then
-	error_message "Magic word does not match!"
-	exit 4
-fi
-cache_timestamp=$(echo "ibase=16;obase=A;$(xxd -u -p -l${byte_size} -s ${byte_size} "${CACHE_LOCATION}")" | bc)
-
-# If we got junk from the binary file, this should fail.
-cache_date=$(date --utc --date "@${cache_timestamp}" "+%FT%TZ")
-
-
-status_message "Updating index state in ${SCRIPTPATH}/cabal.project"
-
-if grep -q "^index-state: .*" "${SCRIPTPATH}/cabal.project" ; then
-	awk '/index-state:/ {gsub(/.*/, "index-state: '${cache_date}'")}; { print }' "${SCRIPTPATH}/cabal.project" > "${SCRIPTPATH}/cabal.project.tmp"
-	mv "${SCRIPTPATH}/cabal.project.tmp" "${SCRIPTPATH}/cabal.project"
-else
-	printf "index-state: %s\n" "${cache_date}" >> "${SCRIPTPATH}/cabal.project"
-fi
-