Compare commits

...

63 Commits

Author SHA1 Message Date
Julian Ospald 322c766ae5
Update freeze file 2020-01-24 22:32:35 +01:00
Julian Ospald 9370bb4e02
Update installation method and bump deps 2020-01-24 22:30:37 +01:00
Julian Ospald 68435e140d
Update to GHC-8.6.4 2019-03-13 21:28:26 +08:00
Julian Ospald cb2d0245a8
Update .gitignore 2018-09-24 00:15:22 +08:00
Julian Ospald 52567888ec
Update .gitignore 2018-09-23 23:28:51 +08:00
Julian Ospald 09e6729e11
Update freeze file 2018-09-23 23:24:05 +08:00
Julian Ospald e4f642318e
Add cabal.project with high optimization settings 2018-09-23 23:23:53 +08:00
Julian Ospald 2c36c39404
Remove stack.yaml, because stack sucks 2018-09-21 22:09:55 +08:00
Julian Ospald 0e8f6735c5
Add cabal.project.freeze 2018-09-21 22:09:32 +08:00
Julian Ospald 111581ef02
Remove last remnants of OverloadedStrings 2018-07-17 21:55:24 +08:00
Julian Ospald 0f247d55ab
Update .gitignore 2018-07-17 21:34:38 +08:00
Julian Ospald d31a7dc172
Add stack.yaml 2018-07-17 21:34:37 +08:00
Julian Ospald 1f4d35bcb1
Fix build with Cabal-2.2.0 2018-07-17 21:34:32 +08:00
Julian Ospald 10fc3155da
Update travis 2018-05-19 15:17:51 +02:00
Julian Ospald 0ce029de57
Fix build with Cabal<2 2018-05-19 14:04:27 +02:00
Julian Ospald 1953b152b4
Fix build 2018-05-19 11:41:51 +02:00
Julian Ospald 3cd7a246ab
Fix build with latest hpath library
This also touches some exception handling code, be careful.
2018-05-17 11:42:36 +02:00
Julian Ospald 6ff620d4ae Fix some compiler warnings
The Plugin module is supposed to be extendable so
there will be unused imports on purpose.
2018-02-06 00:59:50 +01:00
Julian Ospald 93369900f8
Update for GHC-8.2.2 2017-12-13 23:33:34 +01:00
Julian Ospald 7f5adf7962
GTK: cleanup obsolete widgets 2016-11-06 01:54:45 +01:00
Julian Ospald 0d38c8fafc
README: update image 2016-11-06 01:40:39 +01:00
Julian Ospald e2bf4d5f03
GTK: have two panels, fixes #52 2016-11-06 01:33:03 +01:00
Julian Ospald b495b3e89f
README: Use http link 2016-09-26 23:18:29 +02:00
Julian Ospald df0b5e3e16
LIB/GTK: cleanup 2016-06-12 23:40:55 +02:00
Julian Ospald 369278e734
GTK: cosmetics, docs 2016-06-08 21:39:55 +02:00
Julian Ospald e3a840b051
GTK: refactor plugins to allow filtering the items 2016-06-08 21:36:36 +02:00
Julian Ospald 841757857a
GTK: rename diffPlugin to diffItem 2016-06-08 18:37:01 +02:00
Julian Ospald a9238ab3d1
GTK: first take on Plugins system 2016-06-08 18:23:20 +02:00
Julian Ospald eb99c6fc43
Small internal doc fix 2016-06-07 20:08:20 +02:00
Julian Ospald 89710d9d1a
Add Settings modules wrt #22 2016-06-07 20:07:16 +02:00
Julian Ospald f6ec802898
README: update image 2016-06-05 19:46:00 +02:00
Julian Ospald 64fb9fbea0
Use new hpath API 2016-06-05 17:58:50 +02:00
Julian Ospald 46334687c9
GTK: only show stock icons, not labels 2016-06-04 19:10:24 +02:00
Julian Ospald 8ec925aa8f
GTK: improve sections 2016-06-04 19:09:56 +02:00
Julian Ospald 48b0b7b1d8
GTK: overhaul history feature
Allowing righ-click menu.
2016-06-04 18:58:33 +02:00
Julian Ospald 05a62cb382
GTK: use new History module 2016-06-04 17:28:15 +02:00
Julian Ospald d904b74629
LIB: add History module 2016-06-04 17:28:04 +02:00
Julian Ospald 7998ea33de
GTK: fix umlaut in error dialogs 2016-06-03 23:54:39 +02:00
Julian Ospald 1fec2983bd
GTK: fix closing tabs via [Control]+w when tab was switched 2016-06-03 22:34:49 +02:00
Julian Ospald e4bb5104e8
GTK: fix opening non-readable directory as tab 2016-06-03 14:46:23 +02:00
Julian Ospald 3e4621fe70
GTK: add "New -> Terminal" to right-click menu 2016-06-03 14:42:28 +02:00
Julian Ospald 077ac81227
GTK: improve tab opening
When multiple folders are selected, a regular 'open' will
open new tabs for each of them without changing the current view.
2016-06-03 14:25:17 +02:00
Julian Ospald e72bff4180
GTK: fix switchView 2016-06-03 14:06:18 +02:00
Julian Ospald e310879d61
GTK: add newTab{,Here} buttons and allow closing tabs via middle-click
This also fixes behavior of destroyView.
2016-06-03 13:44:59 +02:00
Julian Ospald 03fbae7999
LIB: fix build with GHC-7.10 2016-06-02 15:00:09 +02:00
Julian Ospald da2c7f8e8b
CABAL: raise hpath constraint 2016-06-02 13:56:21 +02:00
Julian Ospald dba15d43e1
LIB: add type signatures to pattern synonyms 2016-06-02 13:50:08 +02:00
Julian Ospald 5b749417c5
CABAL: relax Cabal version constraint 2016-06-02 13:45:57 +02:00
Julian Ospald d460b4ce11
LIB: simplify error handling in FileType
We don't have a Failed constructor anymore.
2016-06-02 13:44:47 +02:00
Julian Ospald 244a58d8c2
GTK: refactor refreshView a bit 2016-06-01 23:58:34 +02:00
Julian Ospald 89b231a2c9
GTK: fix various glitches when opening tabs 2016-06-01 23:24:00 +02:00
Julian Ospald d14caf5269
GTK: don't allow new-tab middle-click on non-directories 2016-06-01 22:26:32 +02:00
Julian Ospald 9549b40745
GTK: implement newTab on middle-click 2016-06-01 22:02:18 +02:00
Julian Ospald 01c241a01e
GTK: remove tab label side-effect from refreshView'
This would cause bugs when newtab on middle-click is implemented,
since creating a new tab creates also a new view, but doesn't
change the current tab to that view. refreshView' would then
update that view with the information from the wrong tab.
2016-06-01 22:00:37 +02:00
Julian Ospald 7fef11ecd2
TRAVIS: fix cwd 2016-06-01 19:43:59 +02:00
Julian Ospald c2bbaa26cf
TRAVIS: build gh-pages 2016-06-01 19:35:00 +02:00
Julian Ospald 837333d8e2
Add gitter badge 2016-05-30 15:46:12 +02:00
Julian Ospald eeb19a5d2f
TRAVIS: add travis support 2016-05-30 14:51:10 +02:00
Julian Ospald 23d3775d37
CABAL: add source-repository section 2016-05-30 14:50:58 +02:00
Julian Ospald 5f82c63aa7
CABAL: remove unnecessary ghc-options
These also caused problems with 'cabal check'.
2016-05-30 14:50:44 +02:00
Julian Ospald 812bf2fa73
CABAL: fix version constraints 2016-05-30 14:50:14 +02:00
Julian Ospald cbfa2e31ca
Update HACKING.md 2016-05-30 14:45:29 +02:00
Julian Ospald c817ea1392
Not that experimental anymore 2016-05-30 14:45:01 +02:00
27 changed files with 1599 additions and 508 deletions

16
.gitignore vendored
View File

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

68
.travis.yml Normal file
View File

@ -0,0 +1,68 @@
# 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

View File

@ -1,7 +1,8 @@
HSFM
====
__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.__
[![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)
[![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.
@ -15,17 +16,13 @@ Design goals:
Screenshots
-----------
![hsfm](https://cloud.githubusercontent.com/assets/1241845/14768900/06efd43c-0a4d-11e6-939e-6b067bdb47ce.png "hsfm-gtk")
![hsfm](https://cloud.githubusercontent.com/assets/1241845/20034565/6c3ae80e-a3c2-11e6-882c-9fe0ff202045.png "hsfm-gtk")
Installation
------------
```
cabal sandbox init
cabal install alex happy
export PATH="$(pwd)/.cabal-sandbox/bin:$PATH"
cabal install gtk2hs-buildtools
cabal install
./install.sh
```

10
cabal.project Normal file
View File

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

80
cabal.project.freeze Normal file
View File

@ -0,0 +1,80 @@
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

View File

@ -1,5 +1,5 @@
<?xml version="1.0" encoding="UTF-8"?>
<!-- Generated with glade 3.18.3 -->
<!-- Generated with glade 3.20.0 -->
<interface>
<requires lib="gtk+" version="3.16"/>
<object class="GtkGrid" id="fpropGrid">
@ -361,39 +361,123 @@
</packing>
</child>
<child>
<object class="GtkNotebook" id="notebook">
<object class="GtkBox">
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="scrollable">True</property>
<property name="can_focus">False</property>
<child>
<placeholder/>
</child>
<child type="tab">
<placeholder/>
</child>
<child>
<placeholder/>
</child>
<child type="tab">
<placeholder/>
</child>
<child>
<placeholder/>
</child>
<child type="tab">
<placeholder/>
<object class="GtkPaned">
<property name="visible">True</property>
<property name="can_focus">True</property>
<child>
<object class="GtkNotebook" id="notebook1">
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="scrollable">True</property>
<child>
<placeholder/>
</child>
<child type="tab">
<placeholder/>
</child>
<child>
<placeholder/>
</child>
<child type="tab">
<placeholder/>
</child>
<child>
<placeholder/>
</child>
<child type="tab">
<placeholder/>
</child>
</object>
<packing>
<property name="resize">True</property>
<property name="shrink">True</property>
</packing>
</child>
<child>
<object class="GtkNotebook" id="notebook2">
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="scrollable">True</property>
<child>
<placeholder/>
</child>
<child type="tab">
<placeholder/>
</child>
<child>
<placeholder/>
</child>
<child type="tab">
<placeholder/>
</child>
<child>
<placeholder/>
</child>
<child type="tab">
<placeholder/>
</child>
</object>
<packing>
<property name="resize">True</property>
<property name="shrink">True</property>
</packing>
</child>
</object>
<packing>
<property name="expand">True</property>
<property name="fill">True</property>
<property name="position">2</property>
</packing>
</child>
</object>
<packing>
<property name="expand">True</property>
<property name="fill">True</property>
<property name="position">2</property>
<property name="position">1</property>
</packing>
</child>
<child>
<object class="GtkBox" id="box3">
<property name="visible">True</property>
<property name="can_focus">False</property>
<child>
<object class="GtkToggleButton" id="leftNbBtn">
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="receives_default">True</property>
<property name="margin_left">5</property>
<property name="margin_right">5</property>
<property name="margin_top">5</property>
<property name="margin_bottom">5</property>
<property name="relief">none</property>
<property name="always_show_image">True</property>
<child>
<placeholder/>
</child>
</object>
<packing>
<property name="expand">False</property>
<property name="fill">True</property>
<property name="position">0</property>
</packing>
</child>
<child>
<object class="GtkSeparator">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="margin_left">2</property>
<property name="margin_right">2</property>
</object>
<packing>
<property name="expand">False</property>
<property name="fill">True</property>
<property name="position">1</property>
</packing>
</child>
<child>
<object class="GtkStatusbar" id="statusBar">
<property name="visible">True</property>
@ -410,7 +494,7 @@
<packing>
<property name="expand">True</property>
<property name="fill">True</property>
<property name="position">0</property>
<property name="position">2</property>
</packing>
</child>
<child>
@ -427,14 +511,48 @@
<packing>
<property name="expand">False</property>
<property name="fill">True</property>
<property name="position">1</property>
<property name="position">3</property>
</packing>
</child>
<child>
<object class="GtkSeparator">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="margin_left">2</property>
<property name="margin_right">2</property>
</object>
<packing>
<property name="expand">False</property>
<property name="fill">True</property>
<property name="position">4</property>
</packing>
</child>
<child>
<object class="GtkToggleButton" id="rightNbBtn">
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="receives_default">True</property>
<property name="margin_left">5</property>
<property name="margin_right">5</property>
<property name="margin_top">5</property>
<property name="margin_bottom">5</property>
<property name="relief">none</property>
<property name="always_show_image">True</property>
<child>
<placeholder/>
</child>
</object>
<packing>
<property name="expand">False</property>
<property name="fill">True</property>
<property name="position">5</property>
</packing>
</child>
</object>
<packing>
<property name="expand">False</property>
<property name="fill">True</property>
<property name="position">3</property>
<property name="position">2</property>
</packing>
</child>
</object>
@ -460,6 +578,16 @@
<property name="can_focus">False</property>
<property name="stock">gtk-zoom-fit</property>
</object>
<object class="GtkImage" id="image8">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="stock">gtk-add</property>
</object>
<object class="GtkImage" id="image9">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="icon_name">utilities-terminal</property>
</object>
<object class="GtkMenu" id="rcMenu">
<property name="visible">True</property>
<property name="can_focus">False</property>
@ -510,6 +638,30 @@
<property name="use_stock">False</property>
</object>
</child>
<child>
<object class="GtkSeparatorMenuItem" id="separatormenuitem4">
<property name="visible">True</property>
<property name="can_focus">False</property>
</object>
</child>
<child>
<object class="GtkImageMenuItem" id="rcFileNewTab">
<property name="label" translatable="yes">Tab</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="image">image8</property>
<property name="use_stock">False</property>
</object>
</child>
<child>
<object class="GtkImageMenuItem" id="rcFileNewTerm">
<property name="label" translatable="yes">Terminal</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="image">image9</property>
<property name="use_stock">False</property>
</object>
</child>
</object>
</child>
</object>
@ -543,7 +695,6 @@
<property name="label">Rename</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="image">image1</property>
<property name="use_stock">False</property>
</object>
</child>
@ -614,6 +765,16 @@
</object>
</child>
</object>
<object class="GtkImage" id="leftNbIcon">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="stock">gtk-yes</property>
</object>
<object class="GtkImage" id="rightNbIcon">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="stock">gtk-yes</property>
</object>
<object class="GtkBox" id="viewBox">
<property name="visible">True</property>
<property name="can_focus">False</property>
@ -623,24 +784,37 @@
<property name="visible">True</property>
<property name="can_focus">False</property>
<child>
<object class="GtkEntry" id="urlBar">
<object class="GtkButton" id="backViewB">
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="input_purpose">url</property>
<property name="receives_default">True</property>
<child>
<object class="GtkImage" id="imageGoBack">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="stock">gtk-go-back</property>
</object>
</child>
</object>
<packing>
<property name="expand">True</property>
<property name="expand">False</property>
<property name="fill">True</property>
<property name="padding">2</property>
<property name="position">0</property>
</packing>
</child>
<child>
<object class="GtkButton" id="upViewB">
<property name="label">gtk-go-up</property>
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="receives_default">True</property>
<property name="use_stock">True</property>
<child>
<object class="GtkImage" id="imageGoUp">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="stock">gtk-go-up</property>
</object>
</child>
</object>
<packing>
<property name="expand">False</property>
@ -650,26 +824,37 @@
</packing>
</child>
<child>
<object class="GtkButton" id="homeViewB">
<property name="label">gtk-home</property>
<object class="GtkButton" id="forwardViewB">
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="receives_default">True</property>
<property name="use_stock">True</property>
<child>
<object class="GtkImage" id="imageGoForward">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="stock">gtk-go-forward</property>
</object>
</child>
</object>
<packing>
<property name="expand">False</property>
<property name="fill">True</property>
<property name="padding">2</property>
<property name="position">2</property>
</packing>
</child>
<child>
<object class="GtkButton" id="refreshViewB">
<property name="label">gtk-refresh</property>
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="receives_default">True</property>
<property name="use_stock">True</property>
<child>
<object class="GtkImage" id="imageRefresh">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="stock">gtk-refresh</property>
</object>
</child>
</object>
<packing>
<property name="expand">False</property>
@ -678,6 +863,37 @@
<property name="position">3</property>
</packing>
</child>
<child>
<object class="GtkButton" id="homeViewB">
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="receives_default">True</property>
<child>
<object class="GtkImage" id="imageHome">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="stock">gtk-home</property>
</object>
</child>
</object>
<packing>
<property name="expand">False</property>
<property name="fill">True</property>
<property name="position">4</property>
</packing>
</child>
<child>
<object class="GtkEntry" id="urlBar">
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="input_purpose">url</property>
</object>
<packing>
<property name="expand">True</property>
<property name="fill">True</property>
<property name="position">5</property>
</packing>
</child>
</object>
<packing>
<property name="expand">False</property>
@ -699,7 +915,7 @@
<packing>
<property name="expand">True</property>
<property name="fill">True</property>
<property name="position">1</property>
<property name="position">2</property>
</packing>
</child>
</object>

View File

@ -61,6 +61,8 @@ This leads to the following benefits:
* 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.
@ -84,17 +86,10 @@ 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 via `runFileOp`, then the file at the given path is read and the copy/move/whatnot function carried out immediately
This means we should only interact with the `HSFM.FileSystem.FileOperation`
module via the operation data types `FileOperation`, `Copy` and `Move` and
the `runFileOp` function. This doesn't completely solve the problem, but for
the rest we have to trust the posix functions to throw the proper exceptions.
* 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 implement our own low-level wrappers around
the posix functions, so we have proper control over the internals
and know the possible exceptions.
and broken. Instead, we use the [HPath.IO](https://hackage.haskell.org/package/hpath/docs/HPath-IO.html).
### Exception handling
@ -102,7 +97,7 @@ 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 `FmIOException`.
`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

View File

@ -10,7 +10,7 @@ copyright: Copyright: (c) 2016 Julian Ospald
homepage: https://github.com/hasufell/hsfm
category: Desktop
build-type: Simple
cabal-version: >=1.10
cabal-version: >=1.22
data-files:
LICENSE
@ -26,16 +26,20 @@ library
exposed-modules:
HSFM.FileSystem.FileType
HSFM.FileSystem.UtilTypes
HSFM.History
HSFM.Settings
HSFM.Utils.IO
HSFM.Utils.MyPrelude
build-depends:
base >= 4.7,
IfElse,
base >= 4.8 && < 5,
bytestring,
data-default,
filepath >= 1.3.0.0,
hinotify-bytestring,
hpath >= 0.7.1,
hpath >= 0.11.0 ,
hpath-filepath >= 0.10.3,
hpath-io >= 0.12.0,
safe,
stm,
time >= 1.4.2,
@ -48,14 +52,14 @@ library
FlexibleInstances
ViewPatterns
ghc-options:
-O2
-threaded
-Wall
"-with-rtsopts=-N"
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
@ -65,20 +69,28 @@ executable hsfm-gtk
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,
base >= 4.7,
IfElse,
base >= 4.8 && < 5,
bytestring,
data-default,
filepath >= 1.3.0.0,
glib >= 0.13,
gtk3 >= 0.14.1,
hinotify-bytestring,
hpath >= 0.7.1,
hpath >= 0.11.0 ,
hpath-filepath >= 0.10.3,
hpath-io >= 0.12.0,
hsfm,
monad-loops,
old-locale >= 1,
process,
safe,
@ -97,8 +109,9 @@ executable hsfm-gtk
FlexibleInstances
ViewPatterns
ghc-options:
-O2
-threaded
-Wall
"-with-rtsopts=-N"
source-repository head
type: git
location: https://github.com/hasufell/hsfm

42
install.sh Executable file
View File

@ -0,0 +1,42 @@
#!/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"

View File

@ -42,7 +42,6 @@ import Data.ByteString.UTF8
(
toString
)
import Data.Default
import Data.Time.Clock.POSIX
(
POSIXTime
@ -57,13 +56,7 @@ import HPath
import qualified HPath as P
import HPath.IO hiding (FileType(..))
import HPath.IO.Errors
import HSFM.Utils.MyPrelude
import Prelude hiding(readFile)
import System.IO.Error
(
ioeGetErrorType
, isDoesNotExistErrorType
)
import System.Posix.FilePath
(
(</>)
@ -98,13 +91,9 @@ import System.Posix.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. We catch any IO errors in the Failed constructor.
-- think of.
data File a =
Failed {
path :: !(Path Abs)
, err :: IOError
}
| Dir {
Dir {
path :: !(Path Abs)
, fvar :: a
}
@ -115,8 +104,8 @@ data File a =
| SymLink {
path :: !(Path Abs)
, fvar :: a
, sdest :: File a -- ^ symlink madness,
-- we need to know where it points to
, sdest :: Maybe (File a) -- ^ symlink madness,
-- we need to know where it points to
, rawdest :: !ByteString
}
| BlockDev {
@ -187,28 +176,31 @@ fileLike f = (False, f)
sdir :: File FileInfo -> (Bool, File FileInfo)
sdir f@SymLink{ sdest = (s@SymLink{} )}
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 = Dir{} }
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))
@ -223,31 +215,33 @@ brokenSymlink f = (isBrokenSymlink f, f)
fileLikeSym :: File FileInfo -> (Bool, File FileInfo)
fileLikeSym f@SymLink{ sdest = s@SymLink{} }
fileLikeSym f@SymLink{ sdest = Just 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@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 = s@SymLink{} }
dirSym f@SymLink{ sdest = Just s@SymLink{} }
= case dirSym s of
(True, _) -> (True, f)
_ -> (False, f)
dirSym f@SymLink{ sdest = Dir{} } = (True, 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))
@ -255,9 +249,11 @@ pattern BrokenSymlink f <- (brokenSymlink -> (True, f))
-- 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
@ -265,6 +261,7 @@ pattern DirSym f <- (dirSym -> (True, f))
-- 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))
@ -303,11 +300,10 @@ instance Ord (File FileInfo) where
-- |Reads a file or directory Path into an `AnchoredFile`, filling the free
-- variables via the given function.
readFile :: (Path Abs -> IO a)
-> Path Abs
-> IO (File a)
readFile ff p =
handleDT p $ do
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
@ -317,11 +313,12 @@ readFile ff p =
-- symlink madness, we need to make sure we save the correct
-- File
x <- PF.readSymbolicLink (P.fromAbs p')
resolvedSyml <- handleDT p' $ do
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
readFile ff =<< P.parseAbs rsfp
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
@ -329,8 +326,7 @@ readFile ff p =
| PF.isCharacterDevice fs = return $ CharDev p' fv
| PF.isNamedPipe fs = return $ NamedPipe p' fv
| PF.isSocket fs = return $ Socket p' fv
| otherwise = return $ Failed p' (userError
"Unknown filetype!")
| otherwise = ioError $ userError "Unknown filetype!"
-- |Get the contents of a given directory and return them as a list
@ -340,8 +336,7 @@ readDirectoryContents :: (Path Abs -> IO a) -- ^ fills free a variable
-> IO [File a]
readDirectoryContents ff p = do
files <- getDirsFiles p
fcs <- mapM (readFile ff) files
return fcs
mapM (pathToFile ff) files
-- |A variant of `readDirectoryContents` where the second argument
@ -357,12 +352,12 @@ getContents _ _ = return []
-- |Go up one directory in the filesystem hierarchy.
goUp :: File FileInfo -> IO (File FileInfo)
goUp file = readFile getFileInfo (P.dirname . path $ file)
goUp file = pathToFile getFileInfo (P.dirname . path $ file)
-- |Go up one directory in the filesystem hierarchy.
goUp' :: Path Abs -> IO (File FileInfo)
goUp' fp = readFile getFileInfo $ P.dirname fp
goUp' fp = pathToFile getFileInfo $ P.dirname fp
@ -373,28 +368,6 @@ goUp' fp = readFile getFileInfo $ P.dirname fp
---- 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 ----
@ -402,11 +375,7 @@ failures = filter failed
-- 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:
@ -466,8 +435,6 @@ isSocketC _ = False
-- |Gets all file information.
getFileInfo :: Path Abs -> IO FileInfo
getFileInfo fp = do
@ -490,17 +457,6 @@ getFileInfo fp = do
---- FAILURE HELPERS: ----
-- Handles an IO exception by returning a Failed constructor filled with that
-- exception. Does not handle FmIOExceptions.
handleDT :: Path Abs
-> IO (File a)
-> IO (File a)
handleDT p
= handleIOError $ \e -> return $ Failed p e
---- SYMLINK HELPERS: ----
@ -511,7 +467,7 @@ handleDT p
--
-- When called on a non-symlink, returns False.
isBrokenSymlink :: File FileInfo -> Bool
isBrokenSymlink (SymLink _ _ Failed{} _) = True
isBrokenSymlink (SymLink _ _ Nothing _) = True
isBrokenSymlink _ = False
@ -523,13 +479,13 @@ isBrokenSymlink _ = False
-- |Pack the modification time into a string.
packModTime :: File FileInfo
-> String
packModTime = fromFreeVar $ epochToString . modificationTime
packModTime = epochToString . modificationTime . fvar
-- |Pack the modification time into a string.
packAccessTime :: File FileInfo
-> String
packAccessTime = fromFreeVar $ epochToString . accessTime
packAccessTime = epochToString . accessTime . fvar
epochToString :: EpochTime -> String
@ -539,12 +495,12 @@ epochToString = show . posixSecondsToUTCTime . realToFrac
-- |Pack the permissions into a string, similar to what "ls -l" does.
packPermissions :: File FileInfo
-> String
packPermissions dt = fromFreeVar (pStr . fileMode) dt
packPermissions file = (pStr . fileMode) . fvar $ file
where
pStr :: FileMode -> String
pStr ffm = typeModeStr ++ ownerModeStr ++ groupModeStr ++ otherModeStr
where
typeModeStr = case dt of
typeModeStr = case file of
Dir {} -> "d"
RegFile {} -> "-"
SymLink {} -> "l"
@ -552,7 +508,6 @@ packPermissions dt = fromFreeVar (pStr . fileMode) dt
CharDev {} -> "c"
NamedPipe {} -> "p"
Socket {} -> "s"
_ -> "?"
ownerModeStr = hasFmStr PF.ownerReadMode "r"
++ hasFmStr PF.ownerWriteMode "w"
++ hasFmStr PF.ownerExecuteMode "x"
@ -577,7 +532,6 @@ packFileType file = case file of
CharDev {} -> "Char Device"
NamedPipe {} -> "Named Pipe"
Socket {} -> "Socket"
_ -> "Unknown"
packLinkDestination :: File a -> Maybe ByteString
@ -591,24 +545,6 @@ packLinkDestination file = case file of
---- OTHER: ----
-- |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
getFPasStr :: File a -> String
getFPasStr = toString . P.fromAbs . path
-- |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

View File

@ -16,7 +16,6 @@ along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK ignore-exports #-}
@ -48,7 +47,7 @@ import HPath
(
Path
, Abs
, Fn
, Rel
)
@ -80,5 +79,5 @@ data FCollisonMode = Strict -- ^ fail if the target already exists
| Overwrite
| OverwriteAll
| Skip
| Rename (Path Fn)
| Rename (Path Rel)

View File

@ -16,7 +16,6 @@ along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK ignore-exports #-}
@ -67,7 +66,7 @@ instance GlibString BS.ByteString where
newUTFStringLen = newUTFStringLen . toString
genUTFOfs = genUTFOfs . toString
stringLength = BS.length
unPrintf s = BS.intercalate "%%" (BS.split _percent s)
unPrintf s = BS.intercalate (BS.pack [_percent, _percent]) (BS.split _percent s)
foreign import ccall unsafe "string.h strlen" c_strlen

View File

@ -16,40 +16,52 @@ along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# LANGUAGE OverloadedStrings #-}
{-# 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
_ <- initGUI
args <- SPE.getArgs
let mdir = fromMaybe (fromJust $ P.parseAbs "/")
(P.parseAbs . headDef "/" $ args)
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 createTreeView mdir
_ <- newTab mygui (notebook1 mygui) createTreeView file (-1)
_ <- newTab mygui (notebook2 mygui) createTreeView file (-1)
setGUICallbacks mygui

View File

@ -16,7 +16,7 @@ along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_HADDOCK ignore-exports #-}
module HSFM.GUI.Gtk.Callbacks where
@ -32,14 +32,21 @@ import Control.Exception
)
import Control.Monad
(
forM_
forM
, forM_
, join
, void
, when
)
import Control.Monad.IfElse
import Control.Monad.IO.Class
(
liftIO
)
import Control.Monad.Loops
(
iterateUntil
)
import Data.ByteString
(
ByteString
@ -56,36 +63,45 @@ import Data.Foldable
import Graphics.UI.Gtk
import qualified HPath as P
import HPath
(
Abs
, Path
)
(
fromAbs
, Abs
, Path
)
import HPath.IO
import HPath.IO.Errors
import HPath.IO.Utils
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 System.Posix.Env.ByteString
(
getEnv
)
import qualified System.Posix.Process.ByteString as SPP
import System.Posix.Types
(
ProcessID
)
import Control.Concurrent.MVar
(
putMVar
, readMVar
, takeMVar
)
import Paths_hsfm
(
getDataFileName
)
@ -104,6 +120,18 @@ import System.Posix.Types
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
@ -119,8 +147,8 @@ setGUICallbacks mygui = do
-- key events
_ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"q" <- fmap glibToString eventKeyName
QuitModifier <- eventModifier
QuitKey <- fmap glibToString eventKeyName
liftIO mainQuit
return ()
@ -175,7 +203,45 @@ setViewCallbacks mygui myview = do
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
@ -183,69 +249,68 @@ setViewCallbacks mygui myview = do
goHome mygui myview
_ <- refreshViewB myview `on` buttonActivated $ do
cdir <- liftIO $ getCurrentDir myview
refreshView' mygui myview cdir
refreshView mygui myview cdir
-- key events
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"h" <- fmap glibToString eventKeyName
ShowHiddenModifier <- eventModifier
ShowHiddenKey <- fmap glibToString eventKeyName
cdir <- liftIO $ getCurrentDir myview
liftIO $ modifyTVarIO (settings mygui)
(\x -> x { showHidden = not . showHidden $ x})
>> refreshView' mygui myview cdir
>> refreshView mygui myview cdir
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
[Alt] <- eventModifier
"Up" <- fmap glibToString eventKeyName
UpDirModifier <- eventModifier
UpDirKey <- fmap glibToString eventKeyName
liftIO $ upDir mygui myview
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
[Alt] <- eventModifier
"Left" <- fmap glibToString eventKeyName
liftIO $ goHistoryPrev mygui myview
HistoryBackModifier <- eventModifier
HistoryBackKey <- fmap glibToString eventKeyName
liftIO $ void $ goHistoryBack mygui myview
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
[Alt] <- eventModifier
"Right" <- fmap glibToString eventKeyName
liftIO $ goHistoryNext mygui myview
HistoryForwardModifier <- eventModifier
HistoryForwardKey <- fmap glibToString eventKeyName
liftIO $ void $ goHistoryForward mygui myview
_ <- view `on` keyPressEvent $ tryEvent $ do
"Delete" <- fmap glibToString eventKeyName
DeleteModifier <- eventModifier
DeleteKey <- fmap glibToString eventKeyName
liftIO $ withItems mygui myview del
_ <- view `on` keyPressEvent $ tryEvent $ do
[] <- eventModifier
"Return" <- fmap glibToString eventKeyName
OpenModifier <- eventModifier
OpenKey <- fmap glibToString eventKeyName
liftIO $ withItems mygui myview open
_ <- view `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"c" <- fmap glibToString eventKeyName
CopyModifier <- eventModifier
CopyKey <- fmap glibToString eventKeyName
liftIO $ withItems mygui myview copyInit
_ <- view `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"x" <- fmap glibToString eventKeyName
MoveModifier <- eventModifier
MoveKey <- fmap glibToString eventKeyName
liftIO $ withItems mygui myview moveInit
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"v" <- fmap glibToString eventKeyName
PasteModifier <- eventModifier
PasteKey <- fmap glibToString eventKeyName
liftIO $ operationFinal mygui myview Nothing
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"t" <- fmap glibToString eventKeyName
liftIO $ void $ do
cwd <- getCurrentDir myview
newTab mygui createTreeView (path cwd)
NewTabModifier <- eventModifier
NewTabKey <- fmap glibToString eventKeyName
liftIO $ void $ newTab' mygui myview
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"w" <- fmap glibToString eventKeyName
CloseTabModifier <- eventModifier
CloseTabKey <- fmap glibToString eventKeyName
liftIO $ void $ closeTab mygui myview
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
"F4" <- fmap glibToString eventKeyName
OpenTerminalModifier <- eventModifier
OpenTerminalKey <- fmap glibToString eventKeyName
liftIO $ void $ openTerminalHere myview
-- righ-click
-- mouse button click
_ <- view `on` buttonPressEvent $ do
eb <- eventButton
t <- eventTime
case eb of
RightButton -> do
_ <- liftIO $ menuPopup (rcMenu . rcmenu $ myview)
$ Just (RightButton, t)
_ <- liftIO $ showPopup mygui myview t
-- this is just to not screw with current selection
-- on right-click
-- TODO: this misbehaves under IconView
@ -260,42 +325,32 @@ setViewCallbacks mygui myview = do
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 $ goHistoryPrev mygui myview
liftIO $ void $ goHistoryBack mygui myview
return False
OtherButton 9 -> do
liftIO $ goHistoryNext mygui myview
liftIO $ void $ goHistoryForward mygui myview
return False
-- not right-click, so pass on the signal
_ -> return False
-- right click menu
_ <- (rcFileOpen . rcmenu) myview `on` menuItemActivated $
liftIO $ withItems mygui myview open
_ <- (rcFileExecute . rcmenu) myview `on` menuItemActivated $
liftIO $ withItems mygui myview execute
_ <- (rcFileNewRegFile . rcmenu) myview `on` menuItemActivated $
liftIO $ newFile mygui myview
_ <- (rcFileNewDir . rcmenu) myview `on` menuItemActivated $
liftIO $ newDir mygui myview
_ <- (rcFileCopy . rcmenu) myview `on` menuItemActivated $
liftIO $ withItems mygui myview copyInit
_ <- (rcFileRename . rcmenu) myview `on` menuItemActivated $
liftIO $ withItems mygui myview renameF
_ <- (rcFilePaste . rcmenu) myview `on` menuItemActivated $
liftIO $ operationFinal mygui myview Nothing
_ <- (rcFileDelete . rcmenu) myview `on` menuItemActivated $
liftIO $ withItems mygui myview del
_ <- (rcFileProperty . rcmenu) myview `on` menuItemActivated $
liftIO $ withItems mygui myview showFilePropertyDialog
_ <- (rcFileCut . rcmenu) myview `on` menuItemActivated $
liftIO $ withItems mygui myview moveInit
_ <- (rcFileIconView . rcmenu) myview `on` menuItemActivated $
liftIO $ switchView mygui myview createIconView
_ <- (rcFileTreeView . rcmenu) myview `on` menuItemActivated $
liftIO $ switchView mygui myview createTreeView
return ()
getPathAtPos fmv (x, y) =
case fmv of
FMTreeView treeView -> do
@ -314,8 +369,7 @@ setViewCallbacks mygui myview = do
openTerminalHere :: MyView -> IO ProcessID
openTerminalHere myview = do
cwd <- (P.fromAbs . path) <$> getCurrentDir myview
-- TODO: make terminal configurable
SPP.forkProcess $ SPP.executeFile "sakura" True ["-d", cwd] Nothing
SPP.forkProcess $ terminalCommand cwd
@ -325,9 +379,23 @@ openTerminalHere myview = do
-- |Closes the current tab, but only if there is more than one tab.
closeTab :: MyGUI -> MyView -> IO ()
closeTab mygui myview = do
n <- notebookGetNPages (notebook mygui)
when (n > 1) $ void $ destroyView mygui myview
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 ()
@ -346,7 +414,7 @@ del items@(_:_) _ _ = withErrorDialog $ do
withConfirmationDialog cmsg
$ forM_ items $ \item -> easyDelete . path $ item
del _ _ _ = withErrorDialog
. throwIO $ InvalidOperation
. ioError $ userError
"Operation not supported on multiple files"
@ -361,7 +429,7 @@ moveInit items@(_:_) mygui _ = do
popStatusbar mygui
void $ pushStatusBar mygui sbmsg
moveInit _ _ _ = withErrorDialog
. throwIO $ InvalidOperation
. ioError $ userError
"No file selected!"
-- |Supposed to be used with 'withRows'. Initializes a file copy operation.
@ -375,7 +443,7 @@ copyInit items@(_:_) mygui _ = do
popStatusbar mygui
void $ pushStatusBar mygui sbmsg
copyInit _ _ _ = withErrorDialog
. throwIO $ InvalidOperation
. ioError $ userError
"No file selected!"
@ -410,27 +478,27 @@ operationFinal mygui myview mitem = withErrorDialog $ do
newFile :: MyGUI -> MyView -> IO ()
newFile _ myview = withErrorDialog $ do
mfn <- textInputDialog "Enter file name" ("" :: String)
let pmfn = P.parseFn =<< fromString <$> mfn
let pmfn = P.parseRel =<< fromString <$> mfn
for_ pmfn $ \fn -> do
cdir <- getCurrentDir myview
createRegularFile (path cdir P.</> fn)
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.parseFn =<< fromString <$> mfn
let pmfn = P.parseRel =<< fromString <$> mfn
for_ pmfn $ \fn -> do
cdir <- getCurrentDir myview
createDir (path cdir P.</> fn)
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.parseFn =<< fromString <$> mfn
let pmfn = P.parseRel =<< fromString <$> mfn
for_ pmfn $ \fn -> do
let cmsg = "Really rename \"" ++ getFPasStr item
++ "\"" ++ " to \""
@ -440,7 +508,7 @@ renameF [item] _ _ = withErrorDialog $ do
HPath.IO.renameFile (path item)
((P.dirname $ path item) P.</> fn)
renameF _ _ _ = withErrorDialog
. throwIO $ InvalidOperation
. ioError $ userError
"Operation not supported on multiple files"
@ -458,15 +526,15 @@ urlGoTo mygui myview = withErrorDialog $ do
fp <- entryGetText (urlBar myview)
forM_ (P.parseAbs fp :: Maybe (Path Abs)) $ \fp' ->
whenM (canOpenDirectory fp')
(goDir mygui myview =<< (readFile getFileInfo $ fp'))
(goDir True mygui myview =<< (pathToFile getFileInfo $ fp'))
goHome :: MyGUI -> MyView -> IO ()
goHome mygui myview = withErrorDialog $ do
mhomedir <- getEnv "HOME"
forM_ (P.parseAbs =<< mhomedir :: Maybe (Path Abs)) $ \fp' ->
homedir <- home
forM_ (P.parseAbs homedir :: Maybe (Path Abs)) $ \fp' ->
whenM (canOpenDirectory fp')
(goDir mygui myview =<< (readFile getFileInfo $ fp'))
(goDir True mygui myview =<< (pathToFile getFileInfo $ fp'))
-- |Execute a given file.
@ -474,7 +542,7 @@ execute :: [Item] -> MyGUI -> MyView -> IO ()
execute [item] _ _ = withErrorDialog $
void $ executeFile (path item) []
execute _ _ _ = withErrorDialog
. throwIO $ InvalidOperation
. ioError $ userError
"Operation not supported on multiple files"
@ -483,16 +551,15 @@ open :: [Item] -> MyGUI -> MyView -> IO ()
open [item] mygui myview = withErrorDialog $
case item of
DirOrSym r -> do
nv <- readFile getFileInfo $ path r
goDir mygui myview nv
nv <- pathToFile getFileInfo $ path r
goDir True mygui myview nv
r ->
void $ openFile . path $ r
-- this throws on the first error that occurs
open (FileLikeList fs) _ _ = withErrorDialog $
forM_ fs $ \f -> void $ openFile . path $ f
open _ _ _ = withErrorDialog
. throwIO $ InvalidOperation
"Operation not supported on multiple files"
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.
@ -500,33 +567,162 @@ upDir :: MyGUI -> MyView -> IO ()
upDir mygui myview = withErrorDialog $ do
cdir <- getCurrentDir myview
nv <- goUp cdir
goDir mygui myview nv
goDir True mygui myview nv
---- HISTORY CALLBACKS ----
-- |Go "back" in the history.
goHistoryPrev :: MyGUI -> MyView -> IO ()
goHistoryPrev mygui myview = do
hs <- readTVarIO (history myview)
case hs of
([], _) -> return ()
(x:xs, _) -> do
cdir <- getCurrentDir myview
nv <- readFile getFileInfo $ x
modifyTVarIO (history myview)
(\(_, n) -> (xs, path cdir `addHistory` n))
refreshView' mygui myview nv
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 "forth" in the history.
goHistoryNext :: MyGUI -> MyView -> IO ()
goHistoryNext mygui myview = do
hs <- readTVarIO (history myview)
case hs of
(_, []) -> return ()
(_, x:xs) -> do
cdir <- getCurrentDir myview
nv <- readFile getFileInfo $ x
modifyTVarIO (history myview)
(\(p, _) -> (path cdir `addHistory` p, xs))
refreshView' mygui myview nv
-- |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 {..}

View File

@ -16,7 +16,6 @@ along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_HADDOCK ignore-exports #-}
@ -26,12 +25,16 @@ module HSFM.GUI.Gtk.Callbacks.Utils where
import Control.Monad
(
forM
, forM_
forM_
, when
)
import Control.Monad.IO.Class
import Data.Foldable
(
liftIO
for_
)
import Data.Maybe
(
fromJust
)
import GHC.IO.Exception
(
@ -42,19 +45,16 @@ import qualified HPath as P
import HPath.IO
import HPath.IO.Errors
import HSFM.FileSystem.FileType
import HSFM.FileSystem.UtilTypes
import qualified HSFM.FileSystem.UtilTypes as UT
import HSFM.GUI.Gtk.Data
import HSFM.GUI.Gtk.Dialogs
import HSFM.GUI.Gtk.MyView
import HSFM.GUI.Gtk.Utils
import HSFM.Utils.IO
(
modifyTVarIO
)
import HSFM.History
import Prelude hiding(readFile)
import Control.Concurrent.STM.TVar
import Control.Concurrent.MVar
(
readTVarIO
putMVar
, tryTakeMVar
)
@ -62,49 +62,67 @@ import Control.Concurrent.STM.TVar
-- |Carries out a file operation with the appropriate error handling
-- allowing the user to react to various exceptions with further input.
doFileOperation :: FileOperation -> IO ()
doFileOperation (FCopy (Copy (f':fs') to)) =
_doFileOperation (f':fs') to easyCopyOverwrite easyCopy
$ doFileOperation (FCopy $ Copy fs' to)
doFileOperation (FMove (Move (f':fs') to)) =
_doFileOperation (f':fs') to moveFileOverwrite moveFile
$ doFileOperation (FMove $ Move fs' to)
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 -> IO b)
-> (P.Path b1 -> P.Path P.Abs -> IO a)
-> (P.Path b1 -> P.Path P.Abs -> CopyMode -> IO b)
-> IO ()
-> IO ()
_doFileOperation [] _ _ _ _ = return ()
_doFileOperation (f:fs) to mcOverwrite mc rest = do
_doFileOperation [] _ _ _ = return ()
_doFileOperation (f:fs) to mc rest = do
toname <- P.basename f
let topath = to P.</> toname
reactOnError (mc f topath >> rest)
reactOnError (mc f topath Strict >> rest)
-- TODO: how safe is 'AlreadyExists' here?
[(AlreadyExists , collisionAction fileCollisionDialog topath)]
[(FileDoesExist{}, collisionAction fileCollisionDialog topath)
,(DirDoesExist{} , collisionAction fileCollisionDialog topath)
,(SameFile{} , collisionAction renameDialog topath)]
[(SameFile{} , collisionAction renameDialog topath)]
where
collisionAction diag topath = do
mcm <- diag . P.fromAbs $ topath
forM_ mcm $ \cm -> case cm of
Overwrite -> mcOverwrite f topath >> rest
OverwriteAll -> forM_ (f:fs) $ \x -> do
UT.Overwrite -> mc f topath Overwrite >> rest
UT.OverwriteAll -> forM_ (f:fs) $ \x -> do
toname' <- P.basename x
mcOverwrite x (to P.</> toname')
Skip -> rest
Rename newn -> mc f (to P.</> newn) >> rest
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 :: MyGUI -> MyView -> Item -> IO ()
goDir mygui myview item = do
cdir <- getCurrentDir myview
modifyTVarIO (history myview)
(\(p, _) -> (path cdir `addHistory` p, []))
refreshView' mygui myview item
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)

View File

@ -30,13 +30,9 @@ import Control.Concurrent.STM
TVar
)
import Graphics.UI.Gtk hiding (MenuBar)
import HPath
(
Abs
, Path
)
import HSFM.FileSystem.FileType
import HSFM.FileSystem.UtilTypes
import HSFM.History
import System.INotify
(
INotify
@ -61,7 +57,14 @@ data MyGUI = MkMyGUI {
, menubar :: !MenuBar
, statusBar :: !Statusbar
, clearStatusBar :: !Button
, notebook :: !Notebook
, notebook1 :: !Notebook
, leftNbBtn :: !ToggleButton
, leftNbIcon :: !Image
, notebook2 :: !Notebook
, rightNbBtn :: !ToggleButton
, rightNbIcon :: !Image
-- other
, fprop :: !FilePropertyGrid
@ -80,16 +83,18 @@ data MyView = MkMyView {
, 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 :: !(TVar ([Path Abs], [Path Abs]))
, history :: !(MVar BrowsingHistory)
-- sub-widgets
, scroll :: !ScrolledWindow
, viewBox :: !Box
, rcmenu :: !RightClickMenu
, backViewB :: !Button
, upViewB :: !Button
, forwardViewB :: !Button
, homeViewB :: !Button
, refreshViewB :: !Button
, urlBar :: !Entry
@ -107,6 +112,8 @@ data RightClickMenu = MkRightClickMenu {
, rcFileExecute :: !ImageMenuItem
, rcFileNewRegFile :: !ImageMenuItem
, rcFileNewDir :: !ImageMenuItem
, rcFileNewTab :: !ImageMenuItem
, rcFileNewTerm :: !ImageMenuItem
, rcFileCut :: !ImageMenuItem
, rcFileCopy :: !ImageMenuItem
, rcFileRename :: !ImageMenuItem

View File

@ -16,17 +16,22 @@ 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
(
displayException
catches
, displayException
, throwIO
, IOException
, catches
, Handler(..)
)
import Control.Monad
@ -44,23 +49,39 @@ 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
)
import Distribution.Package
(
PackageIdentifier(..)
, PackageName(..)
)
#endif
import Distribution.PackageDescription
(
GenericPackageDescription(..)
, PackageDescription(..)
)
#if MIN_VERSION_Cabal(2,2,0)
import Distribution.PackageDescription.Parsec
#else
import Distribution.PackageDescription.Parse
#endif
(
readPackageDescription
#if MIN_VERSION_Cabal(2,0,0)
readGenericPackageDescription,
#else
readPackageDescription,
#endif
)
import Distribution.Verbosity
(
@ -93,7 +114,6 @@ import System.Posix.FilePath
---------------------
--[ Dialog popups ]--
---------------------
@ -151,7 +171,7 @@ fileCollisionDialog t = do
ResponseUser 4 -> do
mfn <- textInputDialog (fromString "Enter new name") (takeFileName t)
forM mfn $ \fn -> do
pfn <- P.parseFn (fromString fn)
pfn <- P.parseRel (fromString fn)
return $ Rename pfn
_ -> throwIO UnknownDialogButton
@ -176,7 +196,7 @@ renameDialog t = do
ResponseUser 2 -> do
mfn <- textInputDialog (fromString "Enter new name") (takeFileName t)
forM mfn $ \fn -> do
pfn <- P.parseFn (fromString fn)
pfn <- P.parseRel (fromString fn)
return $ Rename pfn
_ -> throwIO UnknownDialogButton
@ -188,12 +208,16 @@ showAboutDialog = do
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 . pkgVersion . package) pdesc
, aboutDialogVersion := (showVersion . packageVersion . package) pdesc
, aboutDialogCopyright := copyright pdesc
, aboutDialogComments := description pdesc
, aboutDialogLicense := Just lstr
@ -220,7 +244,9 @@ withErrorDialog :: IO a -> IO ()
withErrorDialog io =
catches (void io)
[ Handler (\e -> showErrorDialog
$ displayException (e :: IOException))
. decodeString
. displayException
$ (e :: IOException))
, Handler (\e -> showErrorDialog
$ displayException (e :: HPathIOException))
]
@ -228,9 +254,9 @@ withErrorDialog io =
-- |Asks the user which directory copy mode he wants via dialog popup
-- and returns 'DirCopyMode'.
textInputDialog :: GlibString string
=> string -- ^ window title
-> string -- ^ initial text in input widget
textInputDialog :: (GlibString s1, GlibString s2)
=> s1 -- ^ window title
-> s2 -- ^ initial text in input widget
-> IO (Maybe String)
textInputDialog title inittext = do
chooserDialog <- messageDialogNew Nothing
@ -269,7 +295,7 @@ showFilePropertyDialog [item] mygui _ = do
entrySetText (fpropFnEntry fprop') (maybe BS.empty P.fromRel
$ P.basename . path $ item)
entrySetText (fpropLocEntry fprop') (P.fromAbs . P.dirname . path $ item)
entrySetText (fpropTsEntry fprop') (fromFreeVar (show . fileSize) item)
entrySetText (fpropTsEntry fprop') (show . fileSize $ fvar item)
entrySetText (fpropModEntry fprop') (packModTime item)
entrySetText (fpropAcEntry fprop') (packAccessTime item)
entrySetText (fpropFTEntry fprop') (packFileType item)

View File

@ -45,7 +45,6 @@ import Paths_hsfm
-- |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
@ -82,8 +81,32 @@ createMyGUI = do
"fpropPermEntry"
fpropLDEntry <- builderGetObject builder castToEntry
"fpropLDEntry"
notebook <- builderGetObject builder castToNotebook
"notebook"
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 {..}

View File

@ -16,6 +16,7 @@ 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
@ -32,16 +33,16 @@ import Control.Concurrent.STM
newTVarIO
, readTVarIO
)
import Control.Exception
(
try
, SomeException
)
import Control.Monad
(
forM_
unless
, void
, when
)
import Control.Monad.IO.Class
(
liftIO
)
import qualified Data.ByteString as BS
import Data.Foldable
(
for_
@ -51,23 +52,19 @@ import Data.Maybe
catMaybes
, fromJust
)
import HPath.IO.Errors
import Data.String
(
canOpenDirectory
fromString
)
import Graphics.UI.Gtk
import {-# SOURCE #-} HSFM.GUI.Gtk.Callbacks (setViewCallbacks)
import HPath
(
Path
, Abs
)
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
(
@ -81,36 +78,72 @@ import System.INotify
, killINotify
, EventVariety(..)
)
import System.IO.Error
(
catchIOError
, ioError
, isUserError
)
import System.Posix.FilePath
(
pathSeparator
, hiddenFile
hiddenFile
)
-- |Creates a new tab with its own view and refreshes the view.
newTab :: MyGUI -> IO FMView -> Path Abs -> IO MyView
newTab mygui iofmv path = do
myview <- createMyView mygui iofmv
i <- notebookAppendPage (notebook mygui) (viewBox myview)
(maybe (P.fromAbs path) P.fromRel $ P.basename path)
mpage <- notebookGetNthPage (notebook mygui) i
forM_ mpage $ \page -> notebookSetTabReorderable (notebook mygui)
page
True
refreshView mygui myview (Just path)
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 iofmv = do
createMyView mygui nb iofmv = do
inotify <- newEmptyMVar
history <- newTVarIO ([],[])
history <- newEmptyMVar
builder <- builderNew
builderAddFromFile builder =<< getDataFileName "data/Gtk/builder.xml"
@ -127,34 +160,13 @@ createMyView mygui iofmv = do
urlBar <- builderGetObject builder castToEntry
"urlBar"
rcMenu <- builderGetObject builder castToMenu
"rcMenu"
rcFileOpen <- builderGetObject builder castToImageMenuItem
"rcFileOpen"
rcFileExecute <- builderGetObject builder castToImageMenuItem
"rcFileExecute"
rcFileNewRegFile <- builderGetObject builder castToImageMenuItem
"rcFileNewRegFile"
rcFileNewDir <- builderGetObject builder castToImageMenuItem
"rcFileNewDir"
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"
rcFileProperty <- builderGetObject builder castToImageMenuItem
"rcFileProperty"
rcFileIconView <- builderGetObject builder castToImageMenuItem
"rcFileIconView"
rcFileTreeView <- builderGetObject builder castToImageMenuItem
"rcFileTreeView"
backViewB <- builderGetObject builder castToButton
"backViewB"
upViewB <- builderGetObject builder castToButton
"upViewB"
forwardViewB <- builderGetObject builder castToButton
"forwardViewB"
homeViewB <- builderGetObject builder castToButton
"homeViewB"
refreshViewB <- builderGetObject builder castToButton
@ -164,7 +176,7 @@ createMyView mygui iofmv = do
viewBox <- builderGetObject builder castToBox
"viewBox"
let rcmenu = MkRightClickMenu {..}
let notebook = nb
let myview = MkMyView {..}
-- set the bindings
@ -185,37 +197,38 @@ switchView :: MyGUI -> MyView -> IO FMView -> IO ()
switchView mygui myview iofmv = do
cwd <- getCurrentDir myview
oldpage <- destroyView mygui myview
let nb = notebook myview
oldpage <- destroyView myview
-- create new view and tab page where the previous one was
nview <- createMyView mygui iofmv
newpage <- notebookInsertPage (notebook mygui) (viewBox nview)
(maybe (P.fromAbs $ path cwd) P.fromRel
$ P.basename . path $ cwd) oldpage
notebookSetCurrentPage (notebook mygui) newpage
nview <- newTab mygui nb iofmv cwd oldpage
refreshView' mygui nview cwd
page <- fromJust <$> notebookPageNum nb (viewBox nview)
notebookSetCurrentPage nb page
refreshView mygui nview cwd
-- |Destroys the current view by disconnecting the watcher
-- |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 :: MyGUI -> MyView -> IO Int
destroyView mygui myview = do
destroyView :: MyView -> IO Int
destroyView myview = do
-- disconnect watcher
mi <- tryTakeMVar (inotify myview)
for_ mi $ \i -> killINotify i
page <- notebookGetCurrentPage (notebook mygui)
page <- fromJust <$> notebookPageNum (notebook myview) (viewBox myview)
-- destroy old view and tab page
view' <- readTVarIO $ view myview
widgetDestroy (fmViewToContainer view')
notebookRemovePage (notebook mygui) page
notebookRemovePage (notebook myview) page
return page
@ -291,46 +304,18 @@ createTreeView = do
return $ FMTreeView treeView
-- |Re-reads the current directory or the given one and updates the View.
-- This is more or less a wrapper around `refreshView'`
--
-- If the third argument is Nothing, it tries to re-read the current directory.
-- If that fails, it reads "/" instead.
--
-- If the third argument is (Just path) it tries to read "path". If that
-- fails, it reads "/" instead.
refreshView :: MyGUI
-> MyView
-> Maybe (Path Abs)
-> IO ()
refreshView mygui myview mfp =
case mfp of
Just fp -> do
canopen <- canOpenDirectory fp
if canopen
then refreshView' mygui myview =<< readFile getFileInfo fp
else refreshView mygui myview =<< getAlternativeDir
Nothing -> refreshView mygui myview =<< getAlternativeDir
where
getAlternativeDir = do
ecd <- try (getCurrentDir myview) :: IO (Either SomeException
Item)
case ecd of
Right dir -> return (Just $ path dir)
Left _ -> return (P.parseAbs $ BS.singleton pathSeparator)
-- |Refreshes the View based on the given directory.
--
-- If the directory is not a Dir or a Symlink pointing to a Dir, then
-- calls `refreshView` with the 3rd argument being Nothing.
refreshView' :: MyGUI
-- Throws:
--
-- - `userError` on inappropriate type
refreshView :: MyGUI
-> MyView
-> Item
-> IO ()
refreshView' mygui myview SymLink { sdest = d@Dir{} } =
refreshView' mygui myview d
refreshView' mygui myview item@Dir{} = do
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
@ -345,12 +330,6 @@ refreshView' mygui myview item@Dir{} = do
constructView mygui myview
-- set notebook tab label
page <- notebookGetCurrentPage (notebook mygui)
child <- fromJust <$> notebookGetNthPage (notebook mygui) page
notebookSetTabLabelText (notebook mygui) child
(maybe (P.fromAbs $ path item) P.fromRel $ P.basename . path $ item)
-- reselect selected items
-- TODO: not implemented for icon view yet
case view' of
@ -359,8 +338,7 @@ refreshView' mygui myview item@Dir{} = do
ntps <- mapM treeRowReferenceGetPath trs
mapM_ (treeSelectionSelectPath tvs) ntps
_ -> return ()
refreshView' mygui myview Failed{} = refreshView mygui myview Nothing
refreshView' _ _ _ = return ()
refreshView _ _ _ = ioError $ userError "Inappropriate type!"
-- |Constructs the visible View with the current underlying mutable models,
@ -385,14 +363,14 @@ constructView mygui myview = do
dirtreePix FileLike{} = filePix
dirtreePix DirSym{} = folderSymPix
dirtreePix FileLikeSym{} = fileSymPix
dirtreePix Failed{} = errorPix
dirtreePix BrokenSymlink{} = errorPix
dirtreePix _ = errorPix
view' <- readTVarIO $ view myview
cdirp <- path <$> getCurrentDir myview
cdir <- getCurrentDir myview
let cdirp = path cdir
-- update urlBar
entrySetText (urlBar myview) (P.fromAbs cdirp)
@ -433,7 +411,7 @@ constructView mygui myview = do
-- update model of view
case view' of
FMTreeView treeView -> do
treeViewSetModel treeView sortedModel'
treeViewSetModel treeView (Just sortedModel')
treeViewSetRubberBanding treeView True
FMIconView iconView -> do
iconViewSetModel iconView (Just sortedModel')
@ -450,7 +428,7 @@ constructView mygui myview = do
newi
[Move, MoveIn, MoveOut, MoveSelf, Create, Delete, DeleteSelf]
(P.fromAbs cdirp)
(\_ -> postGUIAsync $ refreshView mygui myview (Just $ cdirp))
(\_ -> postGUIAsync $ refreshView mygui myview cdir)
putMVar (inotify myview) newi
return ()

112
src/HSFM/GUI/Gtk/Plugins.hs Normal file
View File

@ -0,0 +1,112 @@
{--
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

View File

@ -0,0 +1,128 @@
{--
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"

View File

@ -78,8 +78,8 @@ withItems :: MyGUI
-> ( [Item]
-> MyGUI
-> MyView
-> IO ()) -- ^ action to carry out
-> IO ()
-> IO a) -- ^ action to carry out
-> IO a
withItems mygui myview io = do
items <- getSelectedItems mygui myview
io items mygui myview
@ -152,15 +152,3 @@ rawPathToItem myview tp = do
miter <- rawPathToIter myview tp
forM miter $ \iter -> treeModelGetRow rawModel' iter
-- |Makes sure the list is max 5. This is probably not very efficient
-- but we don't care, since it's a small list anyway.
addHistory :: Eq a => a -> [a] -> [a]
addHistory i [] = [i]
addHistory i xs@(x:_)
| i == x = xs
| length xs == maxLength = i : take (maxLength - 1) xs
| otherwise = i : xs
where
maxLength = 10

61
src/HSFM/History.hs Normal file
View File

@ -0,0 +1,61 @@
{--
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

67
src/HSFM/Settings.hs Normal file
View File

@ -0,0 +1,67 @@
{--
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")

View File

@ -19,7 +19,6 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
module HSFM.Utils.MyPrelude where
import Data.Default
import Data.List
@ -31,6 +30,3 @@ listIndices :: [a] -> [Int]
listIndices = findIndices (const True)
-- |A `maybe` flavor using the `Default` class.
maybeD :: (Default b) => (a -> b) -> Maybe a -> b
maybeD = maybe def

52
update-gh-pages.sh Executable file
View File

@ -0,0 +1,52 @@
#!/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

66
update-index-state.sh Executable file
View File

@ -0,0 +1,66 @@
#!/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