Compare commits
30 Commits
| Author | SHA1 | Date | |
|---|---|---|---|
| a452b44cfe | |||
| 8bcdb84efd | |||
| 746daf9ba6 | |||
| 251a20e881 | |||
| c29693fbd0 | |||
| 9420af15a1 | |||
| 3008e4463b | |||
|
44fc047223 | ||
|
|
8348f34a4a | ||
| a4c8995299 | |||
| 0ff24002e5 | |||
| 7608d838aa | |||
| d432c2146b | |||
| 064d5a1032 | |||
| 39bc0cba24 | |||
| 07c5fa2d62 | |||
| 5c57551438 | |||
| 3c6aca04b4 | |||
| 9d572c8a6e | |||
| 680a75f5be | |||
| 4b0e3ba89a | |||
| 02f04d92f3 | |||
| a61b409486 | |||
| a7ba20ae00 | |||
| 9b43814846 | |||
| 8b8c9a669f | |||
| 7f538f4fae | |||
| 1d2bf37a44 | |||
| 2e16e0ae48 | |||
| 260e7ea01c |
2
3rdparty/hpath
vendored
2
3rdparty/hpath
vendored
Submodule 3rdparty/hpath updated: a5360f29a3...45b515d1db
1
HACKING.md
Symbolic link
1
HACKING.md
Symbolic link
@@ -0,0 +1 @@
|
||||
hacking/HACKING.md
|
||||
11
README.md
11
README.md
@@ -15,12 +15,21 @@ Design goals:
|
||||
Screenshots
|
||||
-----------
|
||||
|
||||
|
||||
|
||||
|
||||
Installation
|
||||
------------
|
||||
|
||||
```
|
||||
git submodule update --init --recursive
|
||||
cabal sandbox init
|
||||
cabal sandbox add-source 3rdparty/hinotify
|
||||
cabal sandbox add-source 3rdparty/hpath
|
||||
cabal sandbox add-source 3rdparty/hpath/3rdparty/posix-paths
|
||||
cabal sandbox add-source 3rdparty/simple-sendfile
|
||||
cabal install alex happy
|
||||
export PATH="$(pwd)/.cabal-sandbox/bin:$PATH"
|
||||
cabal install gtk2hs-buildtools
|
||||
cabal install
|
||||
```
|
||||
|
||||
|
||||
@@ -2,113 +2,281 @@
|
||||
<!-- Generated with glade 3.18.3 -->
|
||||
<interface>
|
||||
<requires lib="gtk+" version="3.16"/>
|
||||
<object class="GtkGrid" id="fpropGrid">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="row_spacing">2</property>
|
||||
<property name="column_spacing">2</property>
|
||||
<property name="row_homogeneous">True</property>
|
||||
<child>
|
||||
<object class="GtkLabel" id="label1">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="halign">start</property>
|
||||
<property name="margin_left">5</property>
|
||||
<property name="label" translatable="yes">File Name:</property>
|
||||
<attributes>
|
||||
<attribute name="weight" value="bold"/>
|
||||
</attributes>
|
||||
</object>
|
||||
<packing>
|
||||
<property name="left_attach">0</property>
|
||||
<property name="top_attach">0</property>
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkEntry" id="fpropFnEntry">
|
||||
<property name="width_request">350</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">True</property>
|
||||
<property name="margin_left">5</property>
|
||||
<property name="margin_right">5</property>
|
||||
<property name="margin_top">2</property>
|
||||
<property name="margin_bottom">2</property>
|
||||
<property name="editable">False</property>
|
||||
</object>
|
||||
<packing>
|
||||
<property name="left_attach">1</property>
|
||||
<property name="top_attach">0</property>
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkLabel" id="label2">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="halign">start</property>
|
||||
<property name="margin_left">5</property>
|
||||
<property name="label" translatable="yes">Location:</property>
|
||||
<attributes>
|
||||
<attribute name="weight" value="bold"/>
|
||||
</attributes>
|
||||
</object>
|
||||
<packing>
|
||||
<property name="left_attach">0</property>
|
||||
<property name="top_attach">1</property>
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkLabel" id="label3">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="halign">start</property>
|
||||
<property name="margin_left">5</property>
|
||||
<property name="label" translatable="yes">Total Size:</property>
|
||||
<attributes>
|
||||
<attribute name="weight" value="bold"/>
|
||||
</attributes>
|
||||
</object>
|
||||
<packing>
|
||||
<property name="left_attach">0</property>
|
||||
<property name="top_attach">2</property>
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkEntry" id="fpropLocEntry">
|
||||
<property name="width_request">350</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">True</property>
|
||||
<property name="margin_left">5</property>
|
||||
<property name="margin_right">5</property>
|
||||
<property name="margin_top">2</property>
|
||||
<property name="margin_bottom">2</property>
|
||||
<property name="editable">False</property>
|
||||
</object>
|
||||
<packing>
|
||||
<property name="left_attach">1</property>
|
||||
<property name="top_attach">1</property>
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkEntry" id="fpropTsEntry">
|
||||
<property name="width_request">350</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">True</property>
|
||||
<property name="margin_left">5</property>
|
||||
<property name="margin_right">5</property>
|
||||
<property name="margin_top">2</property>
|
||||
<property name="margin_bottom">2</property>
|
||||
<property name="editable">False</property>
|
||||
</object>
|
||||
<packing>
|
||||
<property name="left_attach">1</property>
|
||||
<property name="top_attach">2</property>
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkLabel" id="label5">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="halign">start</property>
|
||||
<property name="margin_left">5</property>
|
||||
<property name="label" translatable="yes">Accessed:</property>
|
||||
<attributes>
|
||||
<attribute name="weight" value="bold"/>
|
||||
</attributes>
|
||||
</object>
|
||||
<packing>
|
||||
<property name="left_attach">0</property>
|
||||
<property name="top_attach">7</property>
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkLabel" id="label4">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="halign">start</property>
|
||||
<property name="margin_left">5</property>
|
||||
<property name="label" translatable="yes">Modified:</property>
|
||||
<attributes>
|
||||
<attribute name="weight" value="bold"/>
|
||||
</attributes>
|
||||
</object>
|
||||
<packing>
|
||||
<property name="left_attach">0</property>
|
||||
<property name="top_attach">6</property>
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkEntry" id="fpropModEntry">
|
||||
<property name="width_request">350</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">True</property>
|
||||
<property name="margin_left">5</property>
|
||||
<property name="margin_right">5</property>
|
||||
<property name="margin_top">2</property>
|
||||
<property name="margin_bottom">2</property>
|
||||
<property name="editable">False</property>
|
||||
</object>
|
||||
<packing>
|
||||
<property name="left_attach">1</property>
|
||||
<property name="top_attach">6</property>
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkEntry" id="fpropAcEntry">
|
||||
<property name="width_request">350</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">True</property>
|
||||
<property name="margin_left">5</property>
|
||||
<property name="margin_right">5</property>
|
||||
<property name="margin_top">2</property>
|
||||
<property name="margin_bottom">2</property>
|
||||
<property name="editable">False</property>
|
||||
</object>
|
||||
<packing>
|
||||
<property name="left_attach">1</property>
|
||||
<property name="top_attach">7</property>
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkLabel" id="label6">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="halign">start</property>
|
||||
<property name="margin_left">5</property>
|
||||
<property name="label" translatable="yes">File Type:</property>
|
||||
<attributes>
|
||||
<attribute name="weight" value="bold"/>
|
||||
</attributes>
|
||||
</object>
|
||||
<packing>
|
||||
<property name="left_attach">0</property>
|
||||
<property name="top_attach">3</property>
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkEntry" id="fpropFTEntry">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">True</property>
|
||||
<property name="margin_left">5</property>
|
||||
<property name="margin_right">5</property>
|
||||
<property name="margin_top">2</property>
|
||||
<property name="margin_bottom">2</property>
|
||||
<property name="editable">False</property>
|
||||
</object>
|
||||
<packing>
|
||||
<property name="left_attach">1</property>
|
||||
<property name="top_attach">3</property>
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkEntry" id="fpropPermEntry">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">True</property>
|
||||
<property name="margin_left">5</property>
|
||||
<property name="margin_right">5</property>
|
||||
<property name="margin_top">2</property>
|
||||
<property name="margin_bottom">2</property>
|
||||
<property name="editable">False</property>
|
||||
</object>
|
||||
<packing>
|
||||
<property name="left_attach">1</property>
|
||||
<property name="top_attach">4</property>
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkLabel" id="label7">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="halign">start</property>
|
||||
<property name="margin_left">5</property>
|
||||
<property name="label" translatable="yes">Link Destination:</property>
|
||||
<attributes>
|
||||
<attribute name="weight" value="bold"/>
|
||||
</attributes>
|
||||
</object>
|
||||
<packing>
|
||||
<property name="left_attach">0</property>
|
||||
<property name="top_attach">5</property>
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkLabel" id="label8">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="halign">start</property>
|
||||
<property name="margin_left">5</property>
|
||||
<property name="label" translatable="yes">Permissions:</property>
|
||||
<attributes>
|
||||
<attribute name="weight" value="bold"/>
|
||||
</attributes>
|
||||
</object>
|
||||
<packing>
|
||||
<property name="left_attach">0</property>
|
||||
<property name="top_attach">4</property>
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkEntry" id="fpropLDEntry">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">True</property>
|
||||
<property name="margin_left">5</property>
|
||||
<property name="margin_right">5</property>
|
||||
<property name="margin_top">2</property>
|
||||
<property name="margin_bottom">2</property>
|
||||
<property name="editable">False</property>
|
||||
</object>
|
||||
<packing>
|
||||
<property name="left_attach">1</property>
|
||||
<property name="top_attach">5</property>
|
||||
</packing>
|
||||
</child>
|
||||
</object>
|
||||
<object class="GtkImage" id="image1">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="stock">gtk-edit</property>
|
||||
</object>
|
||||
<object class="GtkMenu" id="rcMenu">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="rcFileOpen">
|
||||
<property name="label">gtk-open</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="use_underline">True</property>
|
||||
<property name="use_stock">True</property>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="rcFileExecute">
|
||||
<property name="label">gtk-execute</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="use_underline">True</property>
|
||||
<property name="use_stock">True</property>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="rcFileNew">
|
||||
<property name="label">gtk-new</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="use_underline">True</property>
|
||||
<property name="use_stock">True</property>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkSeparatorMenuItem" id="separatormenuitem2">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="rcFileCut">
|
||||
<property name="label">gtk-cut</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="use_underline">True</property>
|
||||
<property name="use_stock">True</property>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="rcFileCopy">
|
||||
<property name="label">gtk-copy</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="use_underline">True</property>
|
||||
<property name="use_stock">True</property>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="rcFileRename">
|
||||
<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>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="rcFilePaste">
|
||||
<property name="label">gtk-paste</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="use_underline">True</property>
|
||||
<property name="use_stock">True</property>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="rcFileDelete">
|
||||
<property name="label">gtk-delete</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="use_underline">True</property>
|
||||
<property name="use_stock">True</property>
|
||||
</object>
|
||||
</child>
|
||||
</object>
|
||||
<object class="GtkImage" id="image2">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="stock">gtk-edit</property>
|
||||
<property name="stock">gtk-open</property>
|
||||
</object>
|
||||
<object class="GtkImage" id="image3">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="stock">gtk-cancel</property>
|
||||
</object>
|
||||
<object class="GtkImage" id="image4">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="stock">gtk-zoom-fit</property>
|
||||
</object>
|
||||
<object class="GtkImage" id="image5">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="stock">gtk-zoom-fit</property>
|
||||
</object>
|
||||
<object class="GtkApplicationWindow" id="rootWin">
|
||||
<property name="can_focus">False</property>
|
||||
<child>
|
||||
@@ -130,33 +298,6 @@
|
||||
<object class="GtkMenu" id="menu1">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="menubarFileOpen">
|
||||
<property name="label">gtk-open</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="use_underline">True</property>
|
||||
<property name="use_stock">True</property>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="menubarFileExecute">
|
||||
<property name="label">gtk-execute</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="use_underline">True</property>
|
||||
<property name="use_stock">True</property>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="menubarFileNew">
|
||||
<property name="label">gtk-new</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="use_underline">True</property>
|
||||
<property name="use_stock">True</property>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkSeparatorMenuItem" id="separatormenuitem1">
|
||||
<property name="visible">True</property>
|
||||
@@ -176,65 +317,6 @@
|
||||
</child>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkMenuItem" id="menubarEdit">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="label" translatable="yes">_Edit</property>
|
||||
<property name="use_underline">True</property>
|
||||
<child type="submenu">
|
||||
<object class="GtkMenu" id="menu2">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="menubarEditCut">
|
||||
<property name="label">gtk-cut</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="use_underline">True</property>
|
||||
<property name="use_stock">True</property>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="menubarEditCopy">
|
||||
<property name="label">gtk-copy</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="use_underline">True</property>
|
||||
<property name="use_stock">True</property>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="menubarEditRename">
|
||||
<property name="label">Move</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="image">image2</property>
|
||||
<property name="use_stock">False</property>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="menubarEditPaste">
|
||||
<property name="label">gtk-paste</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="use_underline">True</property>
|
||||
<property name="use_stock">True</property>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="menubarEditDelete">
|
||||
<property name="label">gtk-delete</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="use_underline">True</property>
|
||||
<property name="use_stock">True</property>
|
||||
</object>
|
||||
</child>
|
||||
</object>
|
||||
</child>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkMenuItem" id="menubarView">
|
||||
<property name="visible">True</property>
|
||||
@@ -244,24 +326,6 @@
|
||||
<object class="GtkMenu" id="menu5">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="menubarViewTree">
|
||||
<property name="label">Tree View</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="image">image4</property>
|
||||
<property name="use_stock">False</property>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="menubarViewIcon">
|
||||
<property name="label">Icon view</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="image">image5</property>
|
||||
<property name="use_stock">False</property>
|
||||
</object>
|
||||
</child>
|
||||
</object>
|
||||
</child>
|
||||
</object>
|
||||
@@ -297,82 +361,27 @@
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkBox" id="box2">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<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">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>
|
||||
</object>
|
||||
<packing>
|
||||
<property name="expand">False</property>
|
||||
<property name="fill">True</property>
|
||||
<property name="padding">2</property>
|
||||
<property name="position">1</property>
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkButton" id="homeViewB">
|
||||
<property name="label">gtk-home</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">True</property>
|
||||
<property name="receives_default">True</property>
|
||||
<property name="use_stock">True</property>
|
||||
</object>
|
||||
<packing>
|
||||
<property name="expand">False</property>
|
||||
<property name="fill">True</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>
|
||||
</object>
|
||||
<packing>
|
||||
<property name="expand">False</property>
|
||||
<property name="fill">True</property>
|
||||
<property name="padding">2</property>
|
||||
<property name="position">3</property>
|
||||
</packing>
|
||||
</child>
|
||||
</object>
|
||||
<packing>
|
||||
<property name="expand">False</property>
|
||||
<property name="fill">True</property>
|
||||
<property name="position">1</property>
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkScrolledWindow" id="mainScroll">
|
||||
<property name="width_request">300</property>
|
||||
<property name="height_request">500</property>
|
||||
<object class="GtkNotebook" id="notebook">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">True</property>
|
||||
<property name="shadow_type">in</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="expand">True</property>
|
||||
@@ -430,4 +439,267 @@
|
||||
</object>
|
||||
</child>
|
||||
</object>
|
||||
<object class="GtkImage" id="image4">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="stock">gtk-zoom-in</property>
|
||||
</object>
|
||||
<object class="GtkImage" id="image5">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="stock">gtk-zoom-out</property>
|
||||
</object>
|
||||
<object class="GtkImage" id="image6">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="stock">gtk-directory</property>
|
||||
</object>
|
||||
<object class="GtkImage" id="image7">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="stock">gtk-zoom-fit</property>
|
||||
</object>
|
||||
<object class="GtkMenu" id="rcMenu">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="rcFileOpen">
|
||||
<property name="label">gtk-open</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="use_underline">True</property>
|
||||
<property name="use_stock">True</property>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="rcFileExecute">
|
||||
<property name="label">gtk-execute</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="use_underline">True</property>
|
||||
<property name="use_stock">True</property>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="rcFileNew">
|
||||
<property name="label">gtk-new</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="use_underline">True</property>
|
||||
<property name="use_stock">True</property>
|
||||
<child type="submenu">
|
||||
<object class="GtkMenu" id="menu6">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="rcFileNewRegFile">
|
||||
<property name="label">gtk-file</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="use_underline">True</property>
|
||||
<property name="use_stock">True</property>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="rcFileNewDir">
|
||||
<property name="label" translatable="yes">directory</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="image">image6</property>
|
||||
<property name="use_stock">False</property>
|
||||
</object>
|
||||
</child>
|
||||
</object>
|
||||
</child>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkSeparatorMenuItem" id="separatormenuitem2">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="rcFileCut">
|
||||
<property name="label">gtk-cut</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="use_underline">True</property>
|
||||
<property name="use_stock">True</property>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="rcFileCopy">
|
||||
<property name="label">gtk-copy</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="use_underline">True</property>
|
||||
<property name="use_stock">True</property>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="rcFileRename">
|
||||
<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>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="rcFilePaste">
|
||||
<property name="label">gtk-paste</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="use_underline">True</property>
|
||||
<property name="use_stock">True</property>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="rcFileDelete">
|
||||
<property name="label">gtk-delete</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="use_underline">True</property>
|
||||
<property name="use_stock">True</property>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="rcFileProperty">
|
||||
<property name="label">gtk-properties</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="use_underline">True</property>
|
||||
<property name="use_stock">True</property>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkSeparatorMenuItem" id="separatormenuitem3">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="rcFileView">
|
||||
<property name="label">View</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="image">image7</property>
|
||||
<property name="use_stock">False</property>
|
||||
<child type="submenu">
|
||||
<object class="GtkMenu" id="menu2">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="rcFileIconView">
|
||||
<property name="label">icon view</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="image">image4</property>
|
||||
<property name="use_stock">False</property>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="rcFileTreeView">
|
||||
<property name="label" translatable="yes">tree view</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="image">image5</property>
|
||||
<property name="use_stock">False</property>
|
||||
</object>
|
||||
</child>
|
||||
</object>
|
||||
</child>
|
||||
</object>
|
||||
</child>
|
||||
</object>
|
||||
<object class="GtkBox" id="viewBox">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="orientation">vertical</property>
|
||||
<child>
|
||||
<object class="GtkBox" id="box2">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<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">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>
|
||||
</object>
|
||||
<packing>
|
||||
<property name="expand">False</property>
|
||||
<property name="fill">True</property>
|
||||
<property name="padding">2</property>
|
||||
<property name="position">1</property>
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkButton" id="homeViewB">
|
||||
<property name="label">gtk-home</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">True</property>
|
||||
<property name="receives_default">True</property>
|
||||
<property name="use_stock">True</property>
|
||||
</object>
|
||||
<packing>
|
||||
<property name="expand">False</property>
|
||||
<property name="fill">True</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>
|
||||
</object>
|
||||
<packing>
|
||||
<property name="expand">False</property>
|
||||
<property name="fill">True</property>
|
||||
<property name="padding">2</property>
|
||||
<property name="position">3</property>
|
||||
</packing>
|
||||
</child>
|
||||
</object>
|
||||
<packing>
|
||||
<property name="expand">False</property>
|
||||
<property name="fill">True</property>
|
||||
<property name="position">0</property>
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkScrolledWindow" id="mainScroll">
|
||||
<property name="width_request">300</property>
|
||||
<property name="height_request">500</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">True</property>
|
||||
<property name="shadow_type">in</property>
|
||||
<child>
|
||||
<placeholder/>
|
||||
</child>
|
||||
</object>
|
||||
<packing>
|
||||
<property name="expand">True</property>
|
||||
<property name="fill">True</property>
|
||||
<property name="position">1</property>
|
||||
</packing>
|
||||
</child>
|
||||
</object>
|
||||
</interface>
|
||||
|
||||
@@ -1,25 +1,23 @@
|
||||
HACKING
|
||||
=======
|
||||
# HACKING
|
||||
|
||||
Check out the [issue tracker](https://github.com/hasufell/hsfm/issues)
|
||||
if you don't know yet what you want to hack on.
|
||||
|
||||
Coding style
|
||||
------------
|
||||
## Coding style
|
||||
|
||||
- match the sorroundings
|
||||
- no overcomplicated pointfree style
|
||||
- normal indenting 2 whitespaces
|
||||
- just make things pretty and readable
|
||||
- use the provided [hsimport.hs](hsimport.hs)
|
||||
- you can use the provided [hsimport.hs](hsimport.hs)
|
||||
|
||||
Documentation
|
||||
-------------
|
||||
## Documentation
|
||||
|
||||
__Everything__ must be documented. :)
|
||||
Don't assume people know what you mean. Type signatures are not sufficient
|
||||
documentation.
|
||||
|
||||
Hacking Guide
|
||||
-------------
|
||||
## Hacking Overview
|
||||
|
||||
The main data structure for the IO related File type is in
|
||||
[HSFM.FileSystem.FileType](./../src/HSFM/FileSystem/FileType.hs#L93), which
|
||||
@@ -28,6 +26,8 @@ should be seen as a library. This is the entry point where
|
||||
and the File type in general [is constructed](./../src/HSFM/FileSystem/FileType.hs#L302).
|
||||
The File type uses a safe Path type under the hood instead of Strings,
|
||||
utilizing the [hpath](https://github.com/hasufell/hpath) library.
|
||||
Note that mostly only absolute paths are allowed on type level to improve
|
||||
path and thread safety.
|
||||
|
||||
File operations (like copy, delete etc) are defined at
|
||||
[HSFM.FileSystem.FileOperation](./../src/HSFM/FileSystem/FileOperations.hs)
|
||||
@@ -52,3 +52,73 @@ following files:
|
||||
* [HSFM.GUI.Gtk.MyGUI](./../src/HSFM/GUI/Gtk/MyGUI.hs): add initializers for the GUI buttons to be fetched from the GTK builder.xml file
|
||||
* [HSFM.GUI.Gtk.Callbacks](./../src/HSFM/GUI/Gtk/Callbacks.hs): define the callbacks and the actual functionality here
|
||||
|
||||
## Concepts
|
||||
|
||||
### Path safety
|
||||
|
||||
Paths are usually represented in haskell libraries as `type FilePath = String`.
|
||||
This is bad, because of a number of reasons:
|
||||
* encoding issues, since the low-level representation of filepaths is in fact an array of C chars
|
||||
* weak typing... we could pass arbitrary invalid/malicious filepaths or other random strings
|
||||
* no information about any property at type level (e.g. is it an absolute path?)
|
||||
* no filepath constructors that do sanity checks and proper parsing
|
||||
* no guarantee whether the filepath is normalised or not or even valid
|
||||
|
||||
Because of that, the solution is:
|
||||
* use `ByteString` under the hood
|
||||
* wrap it inside `Path t` where `t` can be either `Abs` (for absolute), `Rel` (for relative) or `Fn` (for filename)
|
||||
* construct filepaths via smart constructors only that reject certain paths (like `.` or `..`) and normalise the path
|
||||
|
||||
This leads to the following benefits:
|
||||
* we have guarantees about whether a path is absolute or not, which is important for runtime safety in general, predictable behavior and thread safety
|
||||
* we don't mess with the filepath representation we get from low-level posix functions, so encoding issues are pretty much out
|
||||
* we can reason about filepaths and rely on them to be valid (don't confuse that with "they exist")
|
||||
* filepath functions like `(</>)` are now predictable and safe in contrast to the version from the `filepath` package
|
||||
|
||||
The only problem with this approach is that most libraries are still String
|
||||
based. Some provide dedicated `Foo.ByteString` modules though, but it
|
||||
might be necessary to fork libraries.
|
||||
We also need to keep track of the [Abstract FilePath proposal](https://ghc.haskell.org/trac/ghc/wiki/Proposal/AbstractFilePath).
|
||||
|
||||
Almost all paths in HSFM are only allowed to be absolute (`Path Abs`), unless
|
||||
they are filenames (`Path Fn`) and processed for GUI purposes. This is as
|
||||
already mentioned for the purpose of runtime safety, predictability and
|
||||
thread safety.
|
||||
|
||||
### File IO safety
|
||||
|
||||
This is a pretty difficult problem. One thing to ensure safety on IO level
|
||||
is simply the strong haskell type system, since we push everything
|
||||
into our `File a` type and can then pattern match easily against the different
|
||||
types of files.
|
||||
|
||||
The only problem with this approach is that we are examining a file at point
|
||||
`a` in time, safe the information and then use that information further down
|
||||
the call stack at point `b` in time, when the file information in memory
|
||||
could already be out of date. There are two approaches to make this less
|
||||
sucky:
|
||||
* use the hinotify library on GUI level to refresh the view (and the File representation in memory) whenever the contents of a directory changes
|
||||
* when we stuff something into the copy buffer, it is not saved as type `File a`, but as `Path Abs`... when the operation is finalized 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.
|
||||
|
||||
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.
|
||||
|
||||
### Exception handling
|
||||
|
||||
Exceptions are good. We don't want to wrap everything in Maybe/Either types
|
||||
unless we want to handle failure immediately. Otherwise we need to make
|
||||
sure that at least at some point IOExceptions are caught and visualized
|
||||
to the user. This is often done via e.g. `withErrorDialog` which catches
|
||||
`IOException` and `FmIOException`.
|
||||
|
||||
It's also important to clean up stuff like filedescriptors via
|
||||
functions like `bracket` directly in our low-level code in case
|
||||
something goes wrong.
|
||||
|
||||
|
||||
@@ -8,7 +8,7 @@ main = hsimport $ defaultConfig { prettyPrint = prettyPrint
|
||||
where
|
||||
prettyPrint :: HS.ImportDecl -> String
|
||||
prettyPrint (HS.ImportDecl sloc modname qual _ _ mpkg mas mspec) =
|
||||
"import " ++ (ifStr qual "qualified") ++
|
||||
"import " ++ (ifStr qual "qualified ") ++
|
||||
(maybe "" (\pkg -> " \"" ++ pkg ++ "\" ") mpkg) ++
|
||||
getMN modname ++ (maybe "" (\name -> " as " ++ getMN name) $ mas) ++
|
||||
specprint mspec
|
||||
@@ -16,9 +16,9 @@ main = hsimport $ defaultConfig { prettyPrint = prettyPrint
|
||||
specprint :: Maybe (Bool, [HS.ImportSpec]) -> String
|
||||
specprint Nothing = ""
|
||||
specprint (Just (False, xs))
|
||||
= "\n (\n" ++ printImportSpecs xs ++ "\n )"
|
||||
= "\n (\n" ++ printImportSpecs xs ++ " )"
|
||||
specprint (Just (True, xs))
|
||||
= "\n hiding (\n" ++ printImportSpecs xs ++ "\n )"
|
||||
= "\n hiding (\n" ++ printImportSpecs xs ++ " )"
|
||||
|
||||
printImportSpecs :: [HS.ImportSpec] -> String
|
||||
printImportSpecs ins
|
||||
@@ -26,7 +26,7 @@ main = hsimport $ defaultConfig { prettyPrint = prettyPrint
|
||||
in " " ++ printSpec x ++ "\n" ++ go xs
|
||||
where
|
||||
go [] = ""
|
||||
go [x'] = " , " ++ printSpec x'
|
||||
go [x'] = " , " ++ printSpec x' ++ "\n"
|
||||
go (x':xs') = " , " ++ printSpec x' ++ "\n" ++ go xs'
|
||||
printSpec :: HS.ImportSpec -> String
|
||||
printSpec = HS.prettyPrint
|
||||
|
||||
@@ -27,17 +27,21 @@ library
|
||||
HSFM.FileSystem.Errors
|
||||
HSFM.FileSystem.FileOperations
|
||||
HSFM.FileSystem.FileType
|
||||
HSFM.Settings.Bookmarks
|
||||
HSFM.Utils.IO
|
||||
HSFM.Utils.MyPrelude
|
||||
|
||||
build-depends:
|
||||
attoparsec,
|
||||
base >= 4.7,
|
||||
bytestring,
|
||||
containers,
|
||||
data-default,
|
||||
errors,
|
||||
filepath >= 1.3.0.0,
|
||||
hinotify,
|
||||
hpath,
|
||||
monad-loops,
|
||||
mtl >= 2.2,
|
||||
old-locale >= 1,
|
||||
posix-paths,
|
||||
@@ -48,7 +52,8 @@ library
|
||||
time >= 1.4.2,
|
||||
unix,
|
||||
unix-bytestring,
|
||||
utf8-string
|
||||
utf8-string,
|
||||
word8
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
Default-Extensions: RecordWildCards
|
||||
|
||||
@@ -37,10 +37,15 @@ import Control.Exception
|
||||
)
|
||||
import Control.Monad
|
||||
(
|
||||
unless
|
||||
forM_
|
||||
, unless
|
||||
, void
|
||||
, when
|
||||
)
|
||||
import Control.Monad.Loops
|
||||
(
|
||||
dropWhileM
|
||||
)
|
||||
import Data.ByteString
|
||||
(
|
||||
ByteString
|
||||
@@ -81,7 +86,7 @@ import qualified HPath as P
|
||||
import HSFM.FileSystem.Errors
|
||||
import HSFM.FileSystem.FileType
|
||||
import HSFM.Utils.IO
|
||||
import Prelude hiding (readFile)
|
||||
import Prelude hiding (readFile, writeFile)
|
||||
import System.Posix.Directory.ByteString
|
||||
(
|
||||
createDirectory
|
||||
@@ -117,9 +122,10 @@ import System.Posix.IO.Sendfile.ByteString
|
||||
import qualified System.Posix.Process.ByteString as SPP
|
||||
import System.Posix.Types
|
||||
(
|
||||
FileMode
|
||||
, ProcessID
|
||||
ByteCount
|
||||
, Fd
|
||||
, FileMode
|
||||
, ProcessID
|
||||
)
|
||||
|
||||
|
||||
@@ -408,6 +414,31 @@ easyCopy cm from@Dir{}
|
||||
easyCopy _ _ _ = throw $ InvalidOperation "wrong input type"
|
||||
|
||||
|
||||
-- |Write a ByteString to a file, overwriting the file. Follows
|
||||
-- symbolic links.
|
||||
writeFile :: File a -> ByteString -> IO ByteCount
|
||||
writeFile RegFile { path = fp } bs = P.withAbsPath fp $ \p ->
|
||||
bracket (SPI.openFd p SPI.WriteOnly (Just PF.stdFileMode)
|
||||
SPI.defaultFileFlags)
|
||||
SPI.closeFd
|
||||
$ \fd -> SPB.fdWrite fd bs
|
||||
writeFile SymLink { sdest = file@RegFile{} } bs =
|
||||
writeFile file bs
|
||||
writeFile _ _ = throw $ InvalidOperation "wrong input type"
|
||||
|
||||
|
||||
readFileContents :: File FileInfo -> IO ByteString
|
||||
readFileContents RegFile { path = fp } =
|
||||
P.withAbsPath fp $ \p ->
|
||||
bracket (SPI.openFd p SPI.ReadOnly Nothing SPI.defaultFileFlags)
|
||||
SPI.closeFd
|
||||
$ \fd -> do
|
||||
fs <- PF.getFdStatus fd
|
||||
SPB.fdRead fd (fromIntegral $ PF.fileSize fs)
|
||||
readFileContents SymLink { sdest = file@RegFile{} } =
|
||||
readFileContents file
|
||||
readFileContents _ = throw $ InvalidOperation "wrong input type"
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -525,10 +556,18 @@ createDir :: File FileInfo -> Path Fn -> IO ()
|
||||
createDir (DirOrSym td) fn = do
|
||||
let fullp = path td P.</> fn
|
||||
throwDirDoesExist fullp
|
||||
createDirectory (P.fromAbs fullp) newFilePerms
|
||||
createDirectory (P.fromAbs fullp) newDirPerms
|
||||
createDir _ _ = throw $ InvalidOperation "wrong input type"
|
||||
|
||||
|
||||
-- |Create a directory at the given path, creating all parents if
|
||||
-- necessary.
|
||||
mkdirP :: Path Abs -> IO ()
|
||||
mkdirP p = do
|
||||
mkps <- dropWhileM canOpenDirectory (reverse $ p : P.getAllParents p)
|
||||
forM_ mkps $ \mkp -> createDirectory (P.fromAbs mkp) newDirPerms
|
||||
|
||||
|
||||
|
||||
|
||||
----------------------------
|
||||
|
||||
@@ -97,58 +97,58 @@ import System.Posix.Types
|
||||
-- can be converted to a String with 'show'.
|
||||
data File a =
|
||||
Failed {
|
||||
path :: Path Abs
|
||||
path :: !(Path Abs)
|
||||
, err :: IOError
|
||||
}
|
||||
| Dir {
|
||||
path :: Path Abs
|
||||
path :: !(Path Abs)
|
||||
, fvar :: a
|
||||
}
|
||||
| RegFile {
|
||||
path :: Path Abs
|
||||
path :: !(Path Abs)
|
||||
, fvar :: a
|
||||
}
|
||||
| SymLink {
|
||||
path :: Path Abs
|
||||
path :: !(Path Abs)
|
||||
, fvar :: a
|
||||
, sdest :: File a -- ^ symlink madness,
|
||||
-- we need to know where it points to
|
||||
, rawdest :: ByteString
|
||||
, rawdest :: !ByteString
|
||||
}
|
||||
| BlockDev {
|
||||
path :: Path Abs
|
||||
path :: !(Path Abs)
|
||||
, fvar :: a
|
||||
}
|
||||
| CharDev {
|
||||
path :: Path Abs
|
||||
path :: !(Path Abs)
|
||||
, fvar :: a
|
||||
}
|
||||
| NamedPipe {
|
||||
path :: Path Abs
|
||||
path :: !(Path Abs)
|
||||
, fvar :: a
|
||||
}
|
||||
| Socket {
|
||||
path :: Path Abs
|
||||
path :: !(Path Abs)
|
||||
, fvar :: a
|
||||
} deriving (Show, Eq)
|
||||
|
||||
|
||||
-- |Low-level file information.
|
||||
data FileInfo = FileInfo {
|
||||
deviceID :: DeviceID
|
||||
, fileID :: FileID
|
||||
, fileMode :: FileMode
|
||||
, linkCount :: LinkCount
|
||||
, fileOwner :: UserID
|
||||
, fileGroup :: GroupID
|
||||
, specialDeviceID :: DeviceID
|
||||
, fileSize :: FileOffset
|
||||
, accessTime :: EpochTime
|
||||
, modificationTime :: EpochTime
|
||||
, statusChangeTime :: EpochTime
|
||||
, accessTimeHiRes :: POSIXTime
|
||||
, modificationTimeHiRes :: POSIXTime
|
||||
, statusChangeTimeHiRes :: POSIXTime
|
||||
deviceID :: !DeviceID
|
||||
, fileID :: !FileID
|
||||
, fileMode :: !FileMode
|
||||
, linkCount :: !LinkCount
|
||||
, fileOwner :: !UserID
|
||||
, fileGroup :: !GroupID
|
||||
, specialDeviceID :: !DeviceID
|
||||
, fileSize :: !FileOffset
|
||||
, accessTime :: !EpochTime
|
||||
, modificationTime :: !EpochTime
|
||||
, statusChangeTime :: !EpochTime
|
||||
, accessTimeHiRes :: !POSIXTime
|
||||
, modificationTimeHiRes :: !POSIXTime
|
||||
, statusChangeTimeHiRes :: !POSIXTime
|
||||
} deriving (Show, Eq, Ord)
|
||||
|
||||
|
||||
@@ -563,9 +563,17 @@ getFreeVar _ = Nothing
|
||||
-- |Pack the modification time into a string.
|
||||
packModTime :: File FileInfo
|
||||
-> String
|
||||
packModTime =
|
||||
fromFreeVar
|
||||
$ show . posixSecondsToUTCTime . realToFrac . modificationTime
|
||||
packModTime = fromFreeVar $ epochToString . modificationTime
|
||||
|
||||
|
||||
-- |Pack the modification time into a string.
|
||||
packAccessTime :: File FileInfo
|
||||
-> String
|
||||
packAccessTime = fromFreeVar $ epochToString . accessTime
|
||||
|
||||
|
||||
epochToString :: EpochTime -> String
|
||||
epochToString = show . posixSecondsToUTCTime . realToFrac
|
||||
|
||||
|
||||
-- |Pack the permissions into a string, similar to what "ls -l" does.
|
||||
@@ -599,3 +607,21 @@ packPermissions dt = fromFreeVar (pStr . fileMode) dt
|
||||
| otherwise = "-"
|
||||
hasFM fm = ffm `PF.intersectFileModes` fm == fm
|
||||
|
||||
|
||||
packFileType :: File a -> String
|
||||
packFileType file = case file of
|
||||
Dir {} -> "Directory"
|
||||
RegFile {} -> "Regular File"
|
||||
SymLink {} -> "Symbolic Link"
|
||||
BlockDev {} -> "Block Device"
|
||||
CharDev {} -> "Char Device"
|
||||
NamedPipe {} -> "Named Pipe"
|
||||
Socket {} -> "Socket"
|
||||
_ -> "Unknown"
|
||||
|
||||
|
||||
packLinkDestination :: File a -> Maybe ByteString
|
||||
packLinkDestination file = case file of
|
||||
SymLink { rawdest = dest } -> Just dest
|
||||
_ -> Nothing
|
||||
|
||||
|
||||
@@ -29,6 +29,7 @@ import Data.Maybe
|
||||
)
|
||||
import Graphics.UI.Gtk
|
||||
import qualified HPath as P
|
||||
import HSFM.GUI.Gtk.Callbacks
|
||||
import HSFM.GUI.Gtk.Data
|
||||
import HSFM.GUI.Gtk.MyGUI
|
||||
import HSFM.GUI.Gtk.MyView
|
||||
@@ -44,14 +45,13 @@ main = do
|
||||
_ <- initGUI
|
||||
|
||||
args <- SPE.getArgs
|
||||
|
||||
mygui <- createMyGUI
|
||||
|
||||
myview <- createMyView mygui createTreeView
|
||||
|
||||
let mdir = fromMaybe (fromJust $ P.parseAbs "/")
|
||||
(P.parseAbs . headDef "/" $ args)
|
||||
refreshView mygui myview (Just $ mdir)
|
||||
|
||||
mygui <- createMyGUI
|
||||
_ <- newTab mygui createTreeView mdir
|
||||
|
||||
setGUICallbacks mygui
|
||||
|
||||
widgetShowAll (rootWin mygui)
|
||||
|
||||
|
||||
@@ -32,8 +32,9 @@ import Control.Exception
|
||||
)
|
||||
import Control.Monad
|
||||
(
|
||||
void
|
||||
, forM_
|
||||
forM_
|
||||
, void
|
||||
, when
|
||||
)
|
||||
import Control.Monad.IO.Class
|
||||
(
|
||||
@@ -67,6 +68,12 @@ import System.Posix.Env.ByteString
|
||||
(
|
||||
getEnv
|
||||
)
|
||||
import qualified System.Posix.Process.ByteString as SPP
|
||||
import System.Posix.Types
|
||||
(
|
||||
ProcessID
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -76,14 +83,75 @@ import System.Posix.Env.ByteString
|
||||
-----------------
|
||||
|
||||
|
||||
-- |Set callbacks, on hotkeys, events and stuff.
|
||||
setCallbacks :: MyGUI -> MyView -> IO ()
|
||||
setCallbacks mygui myview = do
|
||||
|
||||
|
||||
---- MAIN CALLBACK ENTRYPOINT ----
|
||||
|
||||
|
||||
-- |Set callbacks for the whole gui, on hotkeys, events and stuff.
|
||||
setGUICallbacks :: MyGUI -> IO ()
|
||||
setGUICallbacks mygui = do
|
||||
|
||||
_ <- clearStatusBar mygui `on` buttonActivated $ do
|
||||
popStatusbar mygui
|
||||
writeTVarIO (operationBuffer mygui) None
|
||||
|
||||
-- menubar-file
|
||||
_ <- (menubarFileQuit . menubar) mygui `on` menuItemActivated $
|
||||
mainQuit
|
||||
|
||||
-- menubar-help
|
||||
_ <- (menubarHelpAbout . menubar) mygui `on` menuItemActivated $
|
||||
liftIO showAboutDialog
|
||||
return ()
|
||||
|
||||
-- key events
|
||||
_ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
|
||||
[Control] <- eventModifier
|
||||
"q" <- fmap glibToString eventKeyName
|
||||
liftIO mainQuit
|
||||
|
||||
return ()
|
||||
|
||||
|
||||
-- |Set callbacks specific to a given view, on hotkeys, events and stuff.
|
||||
setViewCallbacks :: MyGUI -> MyView -> IO ()
|
||||
setViewCallbacks mygui myview = do
|
||||
view' <- readTVarIO $ view myview
|
||||
case view' of
|
||||
fmv@(FMTreeView treeView) -> do
|
||||
_ <- treeView `on` rowActivated
|
||||
$ (\_ _ -> withItems mygui myview open)
|
||||
|
||||
-- drag events
|
||||
_ <- treeView `on` dragBegin $
|
||||
\_ -> withItems mygui myview moveInit
|
||||
_ <- treeView `on` dragDrop $
|
||||
\dc p ts -> do
|
||||
p' <- treeViewConvertWidgetToTreeCoords treeView p
|
||||
mpath <- treeViewGetPathAtPos treeView p'
|
||||
case mpath of
|
||||
Nothing -> do
|
||||
dragFinish dc False False ts
|
||||
return False
|
||||
Just _ -> do
|
||||
atom <- atomNew ("HSFM" :: String)
|
||||
dragGetData treeView dc atom ts
|
||||
return True
|
||||
_ <- treeView `on` dragDataReceived $
|
||||
\dc p _ ts ->
|
||||
liftIO $ do
|
||||
signalStopEmission treeView "drag_data_received"
|
||||
p' <- treeViewConvertWidgetToTreeCoords treeView p
|
||||
mpath <- treeViewGetPathAtPos treeView p'
|
||||
case mpath of
|
||||
Nothing -> dragFinish dc False False ts
|
||||
Just (tp, _, _) -> do
|
||||
mitem <- rawPathToItem myview tp
|
||||
forM_ mitem $ \item ->
|
||||
operationFinal mygui myview (Just item)
|
||||
dragFinish dc True False ts
|
||||
|
||||
commonGuiEvents fmv
|
||||
return ()
|
||||
fmv@(FMIconView iconView) -> do
|
||||
@@ -91,73 +159,40 @@ setCallbacks mygui myview = do
|
||||
$ (\_ -> withItems mygui myview open)
|
||||
commonGuiEvents fmv
|
||||
return ()
|
||||
menubarCallbacks
|
||||
where
|
||||
menubarCallbacks = do
|
||||
-- menubar-file
|
||||
_ <- menubarFileQuit mygui `on` menuItemActivated $ mainQuit
|
||||
_ <- menubarFileOpen mygui `on` menuItemActivated $
|
||||
liftIO $ withItems mygui myview open
|
||||
_ <- menubarFileExecute mygui `on` menuItemActivated $
|
||||
liftIO $ withItems mygui myview execute
|
||||
_ <- menubarFileNew mygui `on` menuItemActivated $
|
||||
liftIO $ newFile mygui myview
|
||||
|
||||
-- menubar-edit
|
||||
_ <- menubarEditCut mygui `on` menuItemActivated $
|
||||
liftIO $ withItems mygui myview moveInit
|
||||
_ <- menubarEditCopy mygui `on` menuItemActivated $
|
||||
liftIO $ withItems mygui myview copyInit
|
||||
_ <- menubarEditRename mygui `on` menuItemActivated $
|
||||
liftIO $ withItems mygui myview renameF
|
||||
_ <- menubarEditPaste mygui `on` menuItemActivated $
|
||||
liftIO $ operationFinal mygui myview
|
||||
_ <- menubarEditDelete mygui `on` menuItemActivated $
|
||||
liftIO $ withItems mygui myview del
|
||||
|
||||
-- mewnubar-view
|
||||
_ <- menubarViewIcon mygui `on` menuItemActivated $
|
||||
liftIO $ switchView mygui myview createIconView
|
||||
_ <- menubarViewTree mygui `on` menuItemActivated $
|
||||
liftIO $ switchView mygui myview createTreeView
|
||||
|
||||
-- menubar-help
|
||||
_ <- menubarHelpAbout mygui `on` menuItemActivated $
|
||||
liftIO showAboutDialog
|
||||
return ()
|
||||
commonGuiEvents fmv = do
|
||||
let view = fmViewToContainer fmv
|
||||
|
||||
-- GUI events
|
||||
_ <- urlBar mygui `on` entryActivated $ urlGoTo mygui myview
|
||||
|
||||
_ <- upViewB mygui `on` buttonActivated $
|
||||
_ <- urlBar myview `on` entryActivated $ urlGoTo mygui myview
|
||||
_ <- upViewB myview `on` buttonActivated $
|
||||
upDir mygui myview
|
||||
_ <- homeViewB mygui `on` buttonActivated $
|
||||
_ <- homeViewB myview `on` buttonActivated $
|
||||
goHome mygui myview
|
||||
_ <- refreshViewB mygui `on` buttonActivated $ do
|
||||
_ <- refreshViewB myview `on` buttonActivated $ do
|
||||
cdir <- liftIO $ getCurrentDir myview
|
||||
refreshView' mygui myview cdir
|
||||
_ <- clearStatusBar mygui `on` buttonActivated $ do
|
||||
popStatusbar mygui
|
||||
writeTVarIO (operationBuffer myview) None
|
||||
|
||||
-- key events
|
||||
_ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
|
||||
[Control] <- eventModifier
|
||||
"q" <- fmap glibToString eventKeyName
|
||||
liftIO mainQuit
|
||||
_ <- view `on` keyPressEvent $ tryEvent $ do
|
||||
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
||||
[Control] <- eventModifier
|
||||
"h" <- fmap glibToString eventKeyName
|
||||
cdir <- liftIO $ getCurrentDir myview
|
||||
liftIO $ modifyTVarIO (settings mygui)
|
||||
(\x -> x { showHidden = not . showHidden $ x})
|
||||
>> refreshView' mygui myview cdir
|
||||
_ <- view `on` keyPressEvent $ tryEvent $ do
|
||||
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
||||
[Alt] <- eventModifier
|
||||
"Up" <- fmap glibToString eventKeyName
|
||||
liftIO $ upDir mygui myview
|
||||
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
||||
[Alt] <- eventModifier
|
||||
"Left" <- fmap glibToString eventKeyName
|
||||
liftIO $ goHistoryPrev mygui myview
|
||||
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
||||
[Alt] <- eventModifier
|
||||
"Right" <- fmap glibToString eventKeyName
|
||||
liftIO $ goHistoryNext mygui myview
|
||||
_ <- view `on` keyPressEvent $ tryEvent $ do
|
||||
"Delete" <- fmap glibToString eventKeyName
|
||||
liftIO $ withItems mygui myview del
|
||||
@@ -173,10 +208,23 @@ setCallbacks mygui myview = do
|
||||
[Control] <- eventModifier
|
||||
"x" <- fmap glibToString eventKeyName
|
||||
liftIO $ withItems mygui myview moveInit
|
||||
_ <- view `on` keyPressEvent $ tryEvent $ do
|
||||
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
||||
[Control] <- eventModifier
|
||||
"v" <- fmap glibToString eventKeyName
|
||||
liftIO $ operationFinal mygui myview
|
||||
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)
|
||||
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
||||
[Control] <- eventModifier
|
||||
"w" <- fmap glibToString eventKeyName
|
||||
liftIO $ void $ closeTab mygui myview
|
||||
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
||||
"F4" <- fmap glibToString eventKeyName
|
||||
liftIO $ void $ openTerminalHere myview
|
||||
|
||||
-- righ-click
|
||||
_ <- view `on` buttonPressEvent $ do
|
||||
@@ -184,7 +232,7 @@ setCallbacks mygui myview = do
|
||||
t <- eventTime
|
||||
case eb of
|
||||
RightButton -> do
|
||||
_ <- liftIO $ menuPopup (rcMenu mygui)
|
||||
_ <- liftIO $ menuPopup (rcMenu . rcmenu $ myview)
|
||||
$ Just (RightButton, t)
|
||||
-- this is just to not screw with current selection
|
||||
-- on right-click
|
||||
@@ -200,25 +248,42 @@ setCallbacks mygui myview = do
|
||||
return $ elem tp selectedTps
|
||||
-- no item under the cursor, pass on the signal
|
||||
Nothing -> return False
|
||||
OtherButton 8 -> do
|
||||
liftIO $ goHistoryPrev mygui myview
|
||||
return False
|
||||
OtherButton 9 -> do
|
||||
liftIO $ goHistoryNext mygui myview
|
||||
return False
|
||||
-- not right-click, so pass on the signal
|
||||
_ -> return False
|
||||
_ <- rcFileOpen mygui `on` menuItemActivated $
|
||||
|
||||
-- right click menu
|
||||
_ <- (rcFileOpen . rcmenu) myview `on` menuItemActivated $
|
||||
liftIO $ withItems mygui myview open
|
||||
_ <- rcFileExecute mygui `on` menuItemActivated $
|
||||
_ <- (rcFileExecute . rcmenu) myview `on` menuItemActivated $
|
||||
liftIO $ withItems mygui myview execute
|
||||
_ <- rcFileNew mygui `on` menuItemActivated $
|
||||
_ <- (rcFileNewRegFile . rcmenu) myview `on` menuItemActivated $
|
||||
liftIO $ newFile mygui myview
|
||||
_ <- rcFileCopy mygui `on` menuItemActivated $
|
||||
_ <- (rcFileNewDir . rcmenu) myview `on` menuItemActivated $
|
||||
liftIO $ newDir mygui myview
|
||||
_ <- (rcFileCopy . rcmenu) myview `on` menuItemActivated $
|
||||
liftIO $ withItems mygui myview copyInit
|
||||
_ <- rcFileRename mygui `on` menuItemActivated $
|
||||
_ <- (rcFileRename . rcmenu) myview `on` menuItemActivated $
|
||||
liftIO $ withItems mygui myview renameF
|
||||
_ <- rcFilePaste mygui `on` menuItemActivated $
|
||||
liftIO $ operationFinal mygui myview
|
||||
_ <- rcFileDelete mygui `on` menuItemActivated $
|
||||
_ <- (rcFilePaste . rcmenu) myview `on` menuItemActivated $
|
||||
liftIO $ operationFinal mygui myview Nothing
|
||||
_ <- (rcFileDelete . rcmenu) myview `on` menuItemActivated $
|
||||
liftIO $ withItems mygui myview del
|
||||
_ <- rcFileCut mygui `on` menuItemActivated $
|
||||
_ <- (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
|
||||
@@ -230,47 +295,31 @@ setCallbacks mygui myview = do
|
||||
|
||||
|
||||
|
||||
-- |Go to the url given at the 'urlBar' and visualize it in the given
|
||||
-- treeView.
|
||||
--
|
||||
-- If the url is invalid, does nothing.
|
||||
urlGoTo :: MyGUI -> MyView -> IO ()
|
||||
urlGoTo mygui myview = withErrorDialog $ do
|
||||
fp <- entryGetText (urlBar mygui)
|
||||
forM_ (P.parseAbs fp :: Maybe (Path Abs)) $ \fp' ->
|
||||
refreshView mygui myview (Just fp')
|
||||
|
||||
---- OTHER ----
|
||||
|
||||
|
||||
goHome :: MyGUI -> MyView -> IO ()
|
||||
goHome mygui myview = withErrorDialog $ do
|
||||
mhomedir <- getEnv "HOME"
|
||||
refreshView mygui myview (P.parseAbs =<< mhomedir)
|
||||
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
|
||||
|
||||
|
||||
-- |Supposed to be used with 'withRows'. Opens a file or directory.
|
||||
open :: [Item] -> MyGUI -> MyView -> IO ()
|
||||
open [item] mygui myview = withErrorDialog $
|
||||
case item of
|
||||
DirOrSym r -> do
|
||||
nv <- readFile getFileInfo $ path r
|
||||
refreshView' mygui myview nv
|
||||
r ->
|
||||
void $ openFile r
|
||||
-- this throws on the first error that occurs
|
||||
open (FileLikeList fs) _ _ = withErrorDialog $
|
||||
forM_ fs $ \f -> void $ openFile f
|
||||
open _ _ _ = withErrorDialog
|
||||
. throw $ InvalidOperation
|
||||
"Operation not supported on multiple files"
|
||||
|
||||
|
||||
-- |Execute a given file.
|
||||
execute :: [Item] -> MyGUI -> MyView -> IO ()
|
||||
execute [item] _ _ = withErrorDialog $
|
||||
void $ executeFile item []
|
||||
execute _ _ _ = withErrorDialog
|
||||
. throw $ InvalidOperation
|
||||
"Operation not supported on multiple files"
|
||||
---- TAB OPERATIONS ----
|
||||
|
||||
|
||||
-- |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
|
||||
|
||||
|
||||
|
||||
---- FILE OPERATION CALLBACKS (COPY, MOVE, ...) ----
|
||||
|
||||
|
||||
-- |Supposed to be used with 'withRows'. Deletes a file or directory.
|
||||
@@ -291,8 +340,8 @@ del _ _ _ = withErrorDialog
|
||||
|
||||
-- |Initializes a file move operation.
|
||||
moveInit :: [Item] -> MyGUI -> MyView -> IO ()
|
||||
moveInit items@(_:_) mygui myview = do
|
||||
writeTVarIO (operationBuffer myview) (FMove . MP1 . map path $ items)
|
||||
moveInit items@(_:_) mygui _ = do
|
||||
writeTVarIO (operationBuffer mygui) (FMove . MP1 . map path $ items)
|
||||
let sbmsg = case items of
|
||||
(item:[]) -> "Move buffer: " ++ getFPasStr item
|
||||
_ -> "Move buffer: " ++ (show . length $ items)
|
||||
@@ -305,8 +354,8 @@ moveInit _ _ _ = withErrorDialog
|
||||
|
||||
-- |Supposed to be used with 'withRows'. Initializes a file copy operation.
|
||||
copyInit :: [Item] -> MyGUI -> MyView -> IO ()
|
||||
copyInit items@(_:_) mygui myview = do
|
||||
writeTVarIO (operationBuffer myview) (FCopy . CP1 . map path $ items)
|
||||
copyInit items@(_:_) mygui _ = do
|
||||
writeTVarIO (operationBuffer mygui) (FCopy . CP1 . map path $ items)
|
||||
let sbmsg = case items of
|
||||
(item:[]) -> "Copy buffer: " ++ getFPasStr item
|
||||
_ -> "Copy buffer: " ++ (show . length $ items)
|
||||
@@ -319,25 +368,28 @@ copyInit _ _ _ = withErrorDialog
|
||||
|
||||
|
||||
-- |Finalizes a file operation, such as copy or move.
|
||||
operationFinal :: MyGUI -> MyView -> IO ()
|
||||
operationFinal _ myview = withErrorDialog $ do
|
||||
op <- readTVarIO (operationBuffer myview)
|
||||
cdir <- path <$> getCurrentDir myview
|
||||
operationFinal :: MyGUI -> MyView -> Maybe Item -> IO ()
|
||||
operationFinal mygui myview mitem = withErrorDialog $ do
|
||||
op <- readTVarIO (operationBuffer mygui)
|
||||
cdir <- case mitem of
|
||||
Nothing -> path <$> getCurrentDir myview
|
||||
Just x -> return $ path x
|
||||
case op of
|
||||
FMove (MP1 s) -> do
|
||||
let cmsg = "Really move " ++ imsg s
|
||||
++ " to \"" ++ P.fpToString (P.fromAbs cdir)
|
||||
++ "\"?"
|
||||
withConfirmationDialog cmsg . withCopyModeDialog
|
||||
$ \cm -> void $ runFileOp (FMove . MC s cdir $ cm)
|
||||
return ()
|
||||
$ \cm -> do
|
||||
void $ runFileOp (FMove . MC s cdir $ cm)
|
||||
popStatusbar mygui
|
||||
writeTVarIO (operationBuffer mygui) None
|
||||
FCopy (CP1 s) -> do
|
||||
let cmsg = "Really copy " ++ imsg s
|
||||
++ " to \"" ++ P.fpToString (P.fromAbs cdir)
|
||||
++ "\"?"
|
||||
withConfirmationDialog cmsg . withCopyModeDialog
|
||||
$ \cm -> void $ runFileOp (FCopy . CC s cdir $ cm)
|
||||
return ()
|
||||
_ -> return ()
|
||||
where
|
||||
imsg s = case s of
|
||||
@@ -345,15 +397,7 @@ operationFinal _ myview = withErrorDialog $ do
|
||||
items -> (show . length $ items) ++ " items"
|
||||
|
||||
|
||||
-- |Go up one directory and visualize it in the treeView.
|
||||
upDir :: MyGUI -> MyView -> IO ()
|
||||
upDir mygui myview = withErrorDialog $ do
|
||||
cdir <- getCurrentDir myview
|
||||
nv <- goUp cdir
|
||||
refreshView' mygui myview nv
|
||||
|
||||
|
||||
-- |Go up one directory and visualize it in the treeView.
|
||||
-- |Create a new file.
|
||||
newFile :: MyGUI -> MyView -> IO ()
|
||||
newFile _ myview = withErrorDialog $ do
|
||||
mfn <- textInputDialog "Enter file name"
|
||||
@@ -363,6 +407,16 @@ newFile _ myview = withErrorDialog $ do
|
||||
createFile cdir fn
|
||||
|
||||
|
||||
-- |Create a new directory.
|
||||
newDir :: MyGUI -> MyView -> IO ()
|
||||
newDir _ myview = withErrorDialog $ do
|
||||
mfn <- textInputDialog "Enter directory name"
|
||||
let pmfn = P.parseFn =<< P.userStringToFP <$> mfn
|
||||
for_ pmfn $ \fn -> do
|
||||
cdir <- getCurrentDir myview
|
||||
createDir cdir fn
|
||||
|
||||
|
||||
renameF :: [Item] -> MyGUI -> MyView -> IO ()
|
||||
renameF [item] _ _ = withErrorDialog $ do
|
||||
mfn <- textInputDialog "Enter new file name"
|
||||
@@ -377,3 +431,100 @@ renameF [item] _ _ = withErrorDialog $ do
|
||||
renameF _ _ _ = withErrorDialog
|
||||
. throw $ InvalidOperation
|
||||
"Operation not supported on multiple files"
|
||||
|
||||
|
||||
|
||||
|
||||
---- DIRECTORY TRAVERSAL AND FILE OPENING CALLBACKS ----
|
||||
|
||||
|
||||
-- |Go to the url given at the 'urlBar' and visualize it in the given
|
||||
-- treeView.
|
||||
--
|
||||
-- If the url is invalid, does nothing.
|
||||
urlGoTo :: MyGUI -> MyView -> IO ()
|
||||
urlGoTo mygui myview = withErrorDialog $ do
|
||||
fp <- entryGetText (urlBar myview)
|
||||
forM_ (P.parseAbs fp :: Maybe (Path Abs)) $ \fp' ->
|
||||
whenM (canOpenDirectory fp')
|
||||
(goDir mygui myview =<< (readFile getFileInfo $ fp'))
|
||||
|
||||
|
||||
goHome :: MyGUI -> MyView -> IO ()
|
||||
goHome mygui myview = withErrorDialog $ do
|
||||
mhomedir <- getEnv "HOME"
|
||||
forM_ (P.parseAbs =<< mhomedir :: Maybe (Path Abs)) $ \fp' ->
|
||||
whenM (canOpenDirectory fp')
|
||||
(goDir mygui myview =<< (readFile getFileInfo $ fp'))
|
||||
|
||||
|
||||
-- |Execute a given file.
|
||||
execute :: [Item] -> MyGUI -> MyView -> IO ()
|
||||
execute [item] _ _ = withErrorDialog $
|
||||
void $ executeFile item []
|
||||
execute _ _ _ = withErrorDialog
|
||||
. throw $ InvalidOperation
|
||||
"Operation not supported on multiple files"
|
||||
|
||||
|
||||
-- |Supposed to be used with 'withRows'. Opens a file or directory.
|
||||
open :: [Item] -> MyGUI -> MyView -> IO ()
|
||||
open [item] mygui myview = withErrorDialog $
|
||||
case item of
|
||||
DirOrSym r -> do
|
||||
nv <- readFile getFileInfo $ path r
|
||||
goDir mygui myview nv
|
||||
r ->
|
||||
void $ openFile r
|
||||
-- this throws on the first error that occurs
|
||||
open (FileLikeList fs) _ _ = withErrorDialog $
|
||||
forM_ fs $ \f -> void $ openFile f
|
||||
open _ _ _ = withErrorDialog
|
||||
. throw $ InvalidOperation
|
||||
"Operation not supported on multiple files"
|
||||
|
||||
|
||||
-- |Go up one directory and visualize it in the treeView.
|
||||
upDir :: MyGUI -> MyView -> IO ()
|
||||
upDir mygui myview = withErrorDialog $ do
|
||||
cdir <- getCurrentDir myview
|
||||
nv <- goUp cdir
|
||||
goDir mygui myview nv
|
||||
|
||||
|
||||
-- |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
|
||||
|
||||
|
||||
-- |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
|
||||
|
||||
|
||||
-- |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
|
||||
|
||||
|
||||
@@ -22,4 +22,4 @@ module HSFM.GUI.Gtk.Callbacks where
|
||||
import HSFM.GUI.Gtk.Data
|
||||
|
||||
|
||||
setCallbacks :: MyGUI -> MyView -> IO ()
|
||||
setViewCallbacks :: MyGUI -> MyView -> IO ()
|
||||
|
||||
@@ -29,7 +29,12 @@ import Control.Concurrent.STM
|
||||
(
|
||||
TVar
|
||||
)
|
||||
import Graphics.UI.Gtk
|
||||
import Graphics.UI.Gtk hiding (MenuBar)
|
||||
import HPath
|
||||
(
|
||||
Abs
|
||||
, Path
|
||||
)
|
||||
import HSFM.FileSystem.FileOperations
|
||||
import HSFM.FileSystem.FileType
|
||||
import System.INotify.ByteString
|
||||
@@ -50,65 +55,96 @@ import System.INotify.ByteString
|
||||
-- runtime.
|
||||
data MyGUI = MkMyGUI {
|
||||
-- |main Window
|
||||
rootWin :: Window
|
||||
, menubarFileQuit :: ImageMenuItem
|
||||
, menubarFileOpen :: ImageMenuItem
|
||||
, menubarFileExecute :: ImageMenuItem
|
||||
, menubarFileNew :: ImageMenuItem
|
||||
, menubarEditCut :: ImageMenuItem
|
||||
, menubarEditCopy :: ImageMenuItem
|
||||
, menubarEditRename :: ImageMenuItem
|
||||
, menubarEditPaste :: ImageMenuItem
|
||||
, menubarEditDelete :: ImageMenuItem
|
||||
, menubarViewTree :: ImageMenuItem
|
||||
, menubarViewIcon :: ImageMenuItem
|
||||
, menubarHelpAbout :: ImageMenuItem
|
||||
, rcMenu :: Menu
|
||||
, rcFileOpen :: ImageMenuItem
|
||||
, rcFileExecute :: ImageMenuItem
|
||||
, rcFileNew :: ImageMenuItem
|
||||
, rcFileCut :: ImageMenuItem
|
||||
, rcFileCopy :: ImageMenuItem
|
||||
, rcFileRename :: ImageMenuItem
|
||||
, rcFilePaste :: ImageMenuItem
|
||||
, rcFileDelete :: ImageMenuItem
|
||||
, upViewB :: Button
|
||||
, homeViewB :: Button
|
||||
, refreshViewB :: Button
|
||||
, urlBar :: Entry
|
||||
, statusBar :: Statusbar
|
||||
, clearStatusBar :: Button
|
||||
, settings :: TVar FMSettings
|
||||
, scroll :: ScrolledWindow
|
||||
rootWin :: !Window
|
||||
|
||||
-- widgets on the main window
|
||||
, menubar :: !MenuBar
|
||||
, statusBar :: !Statusbar
|
||||
, clearStatusBar :: !Button
|
||||
, notebook :: !Notebook
|
||||
|
||||
-- other
|
||||
, fprop :: !FilePropertyGrid
|
||||
, settings :: !(TVar FMSettings)
|
||||
|
||||
, operationBuffer :: !(TVar FileOperation)
|
||||
}
|
||||
|
||||
|
||||
-- |This describes the contents of the current view and is separated from MyGUI,
|
||||
-- because we might want to have multiple views.
|
||||
data MyView = MkMyView {
|
||||
view :: !(TVar FMView)
|
||||
, cwd :: !(MVar Item)
|
||||
, rawModel :: !(TVar (ListStore Item))
|
||||
, sortedModel :: !(TVar (TypedTreeModelSort Item))
|
||||
, filteredModel :: !(TVar (TypedTreeModelFilter Item))
|
||||
, inotify :: !(MVar INotify)
|
||||
|
||||
-- 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]))
|
||||
|
||||
-- sub-widgets
|
||||
, scroll :: !ScrolledWindow
|
||||
, viewBox :: !Box
|
||||
, rcmenu :: !RightClickMenu
|
||||
, upViewB :: !Button
|
||||
, homeViewB :: !Button
|
||||
, refreshViewB :: !Button
|
||||
, urlBar :: !Entry
|
||||
}
|
||||
|
||||
|
||||
data MenuBar = MkMenuBar {
|
||||
menubarFileQuit :: !ImageMenuItem
|
||||
, menubarHelpAbout :: !ImageMenuItem
|
||||
}
|
||||
|
||||
data RightClickMenu = MkRightClickMenu {
|
||||
rcMenu :: !Menu
|
||||
, rcFileOpen :: !ImageMenuItem
|
||||
, rcFileExecute :: !ImageMenuItem
|
||||
, rcFileNewRegFile :: !ImageMenuItem
|
||||
, rcFileNewDir :: !ImageMenuItem
|
||||
, rcFileCut :: !ImageMenuItem
|
||||
, rcFileCopy :: !ImageMenuItem
|
||||
, rcFileRename :: !ImageMenuItem
|
||||
, rcFilePaste :: !ImageMenuItem
|
||||
, rcFileDelete :: !ImageMenuItem
|
||||
, rcFileProperty :: !ImageMenuItem
|
||||
, rcFileIconView :: !ImageMenuItem
|
||||
, rcFileTreeView :: !ImageMenuItem
|
||||
}
|
||||
|
||||
data FilePropertyGrid = MkFilePropertyGrid {
|
||||
fpropGrid :: !Grid
|
||||
, fpropFnEntry :: !Entry
|
||||
, fpropLocEntry :: !Entry
|
||||
, fpropTsEntry :: !Entry
|
||||
, fpropModEntry :: !Entry
|
||||
, fpropAcEntry :: !Entry
|
||||
, fpropFTEntry :: !Entry
|
||||
, fpropPermEntry :: !Entry
|
||||
, fpropLDEntry :: !Entry
|
||||
}
|
||||
|
||||
|
||||
-- |FM-wide settings.
|
||||
data FMSettings = MkFMSettings {
|
||||
showHidden :: Bool
|
||||
, isLazy :: Bool
|
||||
, iconSize :: Int
|
||||
showHidden :: !Bool
|
||||
, isLazy :: !Bool
|
||||
, iconSize :: !Int
|
||||
}
|
||||
|
||||
data FMView = FMTreeView TreeView
|
||||
| FMIconView IconView
|
||||
data FMView = FMTreeView !TreeView
|
||||
| FMIconView !IconView
|
||||
|
||||
type Item = File FileInfo
|
||||
|
||||
|
||||
-- |This describes the contents of the current vie and is separated from MyGUI,
|
||||
-- because we might want to have multiple views.
|
||||
data MyView = MkMyView {
|
||||
view :: TVar FMView
|
||||
, cwd :: MVar Item
|
||||
, rawModel :: TVar (ListStore Item)
|
||||
, sortedModel :: TVar (TypedTreeModelSort Item)
|
||||
, filteredModel :: TVar (TypedTreeModelFilter Item)
|
||||
, operationBuffer :: TVar FileOperation
|
||||
, inotify :: MVar INotify
|
||||
}
|
||||
|
||||
|
||||
fmViewToContainer :: FMView -> Container
|
||||
fmViewToContainer (FMTreeView x) = castToContainer . toGObject $ x
|
||||
fmViewToContainer (FMIconView x) = castToContainer . toGObject $ x
|
||||
|
||||
|
||||
@@ -36,6 +36,7 @@ import Control.Monad
|
||||
, when
|
||||
, void
|
||||
)
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.Version
|
||||
(
|
||||
showVersion
|
||||
@@ -62,6 +63,9 @@ import Graphics.UI.Gtk
|
||||
import qualified HPath as P
|
||||
import HSFM.FileSystem.Errors
|
||||
import HSFM.FileSystem.FileOperations
|
||||
import HSFM.FileSystem.FileType
|
||||
import HSFM.GUI.Glib.GlibString()
|
||||
import HSFM.GUI.Gtk.Data
|
||||
import HSFM.GUI.Gtk.Errors
|
||||
import Paths_hsfm
|
||||
(
|
||||
@@ -180,7 +184,7 @@ withCopyModeDialog fa =
|
||||
showAboutDialog :: IO ()
|
||||
showAboutDialog = do
|
||||
ad <- aboutDialogNew
|
||||
lstr <- readFile =<< getDataFileName "LICENSE"
|
||||
lstr <- Prelude.readFile =<< getDataFileName "LICENSE"
|
||||
hsfmicon <- pixbufNewFromFile =<< getDataFileName "data/Gtk/icons/hsfm.png"
|
||||
pdesc <- fmap packageDescription
|
||||
(readPackageDescription silent
|
||||
@@ -244,3 +248,50 @@ textInputDialog title = do
|
||||
_ -> throw UnknownDialogButton
|
||||
widgetDestroy chooserDialog
|
||||
return ret
|
||||
|
||||
|
||||
showFilePropertyDialog :: [Item] -> MyGUI -> MyView -> IO ()
|
||||
showFilePropertyDialog [item] mygui _ = do
|
||||
dialog <- messageDialogNew Nothing
|
||||
[DialogDestroyWithParent]
|
||||
MessageInfo
|
||||
ButtonsNone
|
||||
"File Properties"
|
||||
|
||||
let fprop' = fprop mygui
|
||||
grid = fpropGrid fprop'
|
||||
|
||||
entrySetText (fpropFnEntry fprop') (maybe BS.empty P.fromRel
|
||||
$ P.basename . path $ item)
|
||||
entrySetText (fpropLocEntry fprop') (P.fromAbs . P.dirname . path $ item)
|
||||
entrySetText (fpropTsEntry fprop') (fromFreeVar (show . fileSize) item)
|
||||
entrySetText (fpropModEntry fprop') (packModTime item)
|
||||
entrySetText (fpropAcEntry fprop') (packAccessTime item)
|
||||
entrySetText (fpropFTEntry fprop') (packFileType item)
|
||||
entrySetText (fpropPermEntry fprop')
|
||||
(tail $ packPermissions item) -- throw away the filetype part
|
||||
case packLinkDestination item of
|
||||
(Just dest) -> do
|
||||
widgetSetSensitive (fpropLDEntry fprop') True
|
||||
entrySetText (fpropLDEntry fprop') dest
|
||||
Nothing -> do
|
||||
widgetSetSensitive (fpropLDEntry fprop') False
|
||||
entrySetText (fpropLDEntry fprop') "( Not a symlink )"
|
||||
|
||||
|
||||
cbox <- dialogGetActionArea dialog
|
||||
_ <- dialogAddButton dialog "Ok" (ResponseUser 0)
|
||||
_ <- dialogAddButton dialog "Cancel" (ResponseUser 1)
|
||||
boxPackStart (castToBox cbox) grid PackNatural 5
|
||||
|
||||
widgetShowAll dialog
|
||||
_ <- dialogRun dialog
|
||||
|
||||
-- make sure our grid does not get destroyed
|
||||
containerRemove (castToBox cbox) grid
|
||||
|
||||
widgetDestroy dialog
|
||||
|
||||
return ()
|
||||
showFilePropertyDialog _ _ _ = return ()
|
||||
|
||||
|
||||
@@ -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 #-}
|
||||
{-# OPTIONS_HADDOCK ignore-exports #-}
|
||||
|
||||
module HSFM.GUI.Gtk.MyGUI where
|
||||
@@ -26,6 +27,7 @@ import Control.Concurrent.STM
|
||||
newTVarIO
|
||||
)
|
||||
import Graphics.UI.Gtk
|
||||
import HSFM.FileSystem.FileOperations
|
||||
import HSFM.GUI.Gtk.Data
|
||||
import Paths_hsfm
|
||||
(
|
||||
@@ -46,6 +48,7 @@ createMyGUI = do
|
||||
|
||||
let settings' = MkFMSettings False True 24
|
||||
settings <- newTVarIO settings'
|
||||
operationBuffer <- newTVarIO None
|
||||
|
||||
builder <- builderNew
|
||||
builderAddFromFile builder =<< getDataFileName "data/Gtk/builder.xml"
|
||||
@@ -53,64 +56,38 @@ createMyGUI = do
|
||||
-- get the pre-defined gui widgets
|
||||
rootWin <- builderGetObject builder castToWindow
|
||||
"rootWin"
|
||||
scroll <- builderGetObject builder castToScrolledWindow
|
||||
"mainScroll"
|
||||
menubarFileQuit <- builderGetObject builder castToImageMenuItem
|
||||
"menubarFileQuit"
|
||||
menubarFileOpen <- builderGetObject builder castToImageMenuItem
|
||||
"menubarFileOpen"
|
||||
menubarFileExecute <- builderGetObject builder castToImageMenuItem
|
||||
"menubarFileExecute"
|
||||
menubarFileNew <- builderGetObject builder castToImageMenuItem
|
||||
"menubarFileNew"
|
||||
menubarEditCut <- builderGetObject builder castToImageMenuItem
|
||||
"menubarEditCut"
|
||||
menubarEditCopy <- builderGetObject builder castToImageMenuItem
|
||||
"menubarEditCopy"
|
||||
menubarEditRename <- builderGetObject builder castToImageMenuItem
|
||||
"menubarEditRename"
|
||||
menubarEditPaste <- builderGetObject builder castToImageMenuItem
|
||||
"menubarEditPaste"
|
||||
menubarEditDelete <- builderGetObject builder castToImageMenuItem
|
||||
"menubarEditDelete"
|
||||
menubarHelpAbout <- builderGetObject builder castToImageMenuItem
|
||||
"menubarHelpAbout"
|
||||
urlBar <- builderGetObject builder castToEntry
|
||||
"urlBar"
|
||||
statusBar <- builderGetObject builder castToStatusbar
|
||||
"statusBar"
|
||||
clearStatusBar <- builderGetObject builder castToButton
|
||||
"clearStatusBar"
|
||||
rcMenu <- builderGetObject builder castToMenu
|
||||
"rcMenu"
|
||||
rcFileOpen <- builderGetObject builder castToImageMenuItem
|
||||
"rcFileOpen"
|
||||
rcFileExecute <- builderGetObject builder castToImageMenuItem
|
||||
"rcFileExecute"
|
||||
rcFileNew <- builderGetObject builder castToImageMenuItem
|
||||
"rcFileNew"
|
||||
rcFileCut <- builderGetObject builder castToImageMenuItem
|
||||
"rcFileCut"
|
||||
rcFileCopy <- builderGetObject builder castToImageMenuItem
|
||||
"rcFileCopy"
|
||||
rcFileRename <- builderGetObject builder castToImageMenuItem
|
||||
"rcFileRename"
|
||||
rcFilePaste <- builderGetObject builder castToImageMenuItem
|
||||
"rcFilePaste"
|
||||
rcFileDelete <- builderGetObject builder castToImageMenuItem
|
||||
"rcFileDelete"
|
||||
upViewB <- builderGetObject builder castToButton
|
||||
"upViewB"
|
||||
homeViewB <- builderGetObject builder castToButton
|
||||
"homeViewB"
|
||||
refreshViewB <- builderGetObject builder castToButton
|
||||
"refreshViewB"
|
||||
menubarViewTree <- builderGetObject builder castToImageMenuItem
|
||||
"menubarViewTree"
|
||||
menubarViewIcon <- builderGetObject builder castToImageMenuItem
|
||||
"menubarViewIcon"
|
||||
fpropGrid <- builderGetObject builder castToGrid
|
||||
"fpropGrid"
|
||||
fpropFnEntry <- builderGetObject builder castToEntry
|
||||
"fpropFnEntry"
|
||||
fpropLocEntry <- builderGetObject builder castToEntry
|
||||
"fpropLocEntry"
|
||||
fpropTsEntry <- builderGetObject builder castToEntry
|
||||
"fpropTsEntry"
|
||||
fpropModEntry <- builderGetObject builder castToEntry
|
||||
"fpropModEntry"
|
||||
fpropAcEntry <- builderGetObject builder castToEntry
|
||||
"fpropAcEntry"
|
||||
fpropFTEntry <- builderGetObject builder castToEntry
|
||||
"fpropFTEntry"
|
||||
fpropPermEntry <- builderGetObject builder castToEntry
|
||||
"fpropPermEntry"
|
||||
fpropLDEntry <- builderGetObject builder castToEntry
|
||||
"fpropLDEntry"
|
||||
notebook <- builderGetObject builder castToNotebook
|
||||
"notebook"
|
||||
|
||||
-- construct the gui object
|
||||
let menubar = MkMenuBar {..}
|
||||
let fprop = MkFilePropertyGrid {..}
|
||||
let mygui = MkMyGUI {..}
|
||||
|
||||
-- sets the default icon
|
||||
|
||||
@@ -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,21 +47,28 @@ import Data.Maybe
|
||||
catMaybes
|
||||
, fromJust
|
||||
)
|
||||
import HSFM.FileSystem.Errors
|
||||
(
|
||||
canOpenDirectory
|
||||
)
|
||||
import Graphics.UI.Gtk
|
||||
import {-# SOURCE #-} HSFM.GUI.Gtk.Callbacks (setCallbacks)
|
||||
import {-# SOURCE #-} HSFM.GUI.Gtk.Callbacks (setViewCallbacks)
|
||||
import HPath
|
||||
(
|
||||
Path
|
||||
, Abs
|
||||
)
|
||||
import qualified HPath as P
|
||||
import HSFM.FileSystem.FileOperations
|
||||
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.Utils.IO
|
||||
import Paths_hsfm
|
||||
(
|
||||
getDataFileName
|
||||
)
|
||||
import Prelude hiding(readFile)
|
||||
import System.INotify.ByteString
|
||||
(
|
||||
@@ -71,13 +77,18 @@ import System.INotify.ByteString
|
||||
, killINotify
|
||||
, EventVariety(..)
|
||||
)
|
||||
import System.IO.Error
|
||||
(
|
||||
tryIOError
|
||||
)
|
||||
|
||||
|
||||
|
||||
-- |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
|
||||
_ <- notebookAppendPage (notebook mygui) (viewBox myview)
|
||||
(maybe (P.fromAbs path) P.fromRel $ P.basename path)
|
||||
refreshView mygui myview (Just path)
|
||||
return myview
|
||||
|
||||
|
||||
-- |Constructs the initial MyView object with a few dummy models.
|
||||
-- It also initializes the callbacks.
|
||||
@@ -85,9 +96,11 @@ createMyView :: MyGUI
|
||||
-> IO FMView
|
||||
-> IO MyView
|
||||
createMyView mygui iofmv = do
|
||||
operationBuffer <- newTVarIO None
|
||||
|
||||
inotify <- newEmptyMVar
|
||||
history <- newTVarIO ([],[])
|
||||
|
||||
builder <- builderNew
|
||||
builderAddFromFile builder =<< getDataFileName "data/Gtk/builder.xml"
|
||||
|
||||
-- create dummy models, so we don't have to use MVar
|
||||
rawModel <- newTVarIO =<< listStoreNew []
|
||||
@@ -99,14 +112,56 @@ createMyView mygui iofmv = do
|
||||
view' <- iofmv
|
||||
view <- newTVarIO view'
|
||||
|
||||
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"
|
||||
upViewB <- builderGetObject builder castToButton
|
||||
"upViewB"
|
||||
homeViewB <- builderGetObject builder castToButton
|
||||
"homeViewB"
|
||||
refreshViewB <- builderGetObject builder castToButton
|
||||
"refreshViewB"
|
||||
scroll <- builderGetObject builder castToScrolledWindow
|
||||
"mainScroll"
|
||||
viewBox <- builderGetObject builder castToBox
|
||||
"viewBox"
|
||||
|
||||
let rcmenu = MkRightClickMenu {..}
|
||||
let myview = MkMyView {..}
|
||||
|
||||
-- set the bindings
|
||||
setCallbacks mygui myview
|
||||
setViewCallbacks mygui myview
|
||||
|
||||
-- add the treeview to the scroll container
|
||||
let oview = fmViewToContainer view'
|
||||
containerAdd (scroll mygui) oview
|
||||
containerAdd scroll oview
|
||||
|
||||
widgetShowAll viewBox
|
||||
|
||||
return myview
|
||||
|
||||
@@ -115,22 +170,41 @@ createMyView mygui iofmv = do
|
||||
-- io action returns.
|
||||
switchView :: MyGUI -> MyView -> IO FMView -> IO ()
|
||||
switchView mygui myview iofmv = do
|
||||
cwd <- getCurrentDir myview
|
||||
|
||||
oldpage <- destroyView mygui 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
|
||||
|
||||
refreshView' mygui nview cwd
|
||||
|
||||
|
||||
-- |Destroys the current 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
|
||||
-- disconnect watcher
|
||||
mi <- tryTakeMVar (inotify myview)
|
||||
for_ mi $ \i -> killINotify i
|
||||
|
||||
page <- notebookGetCurrentPage (notebook mygui)
|
||||
|
||||
-- destroy old view and tab page
|
||||
view' <- readTVarIO $ view myview
|
||||
let oview = fmViewToContainer view'
|
||||
widgetDestroy (fmViewToContainer view')
|
||||
notebookRemovePage (notebook mygui) page
|
||||
|
||||
widgetDestroy oview
|
||||
|
||||
nview' <- iofmv
|
||||
let nview = fmViewToContainer nview'
|
||||
|
||||
writeTVarIO (view myview) nview'
|
||||
|
||||
setCallbacks mygui myview
|
||||
|
||||
containerAdd (scroll mygui) nview
|
||||
widgetShow nview
|
||||
|
||||
refreshView mygui myview Nothing
|
||||
return page
|
||||
|
||||
|
||||
-- |Createss an IconView.
|
||||
@@ -156,6 +230,13 @@ createTreeView = do
|
||||
tvs <- treeViewGetSelection treeView
|
||||
treeSelectionSetMode tvs SelectionMultiple
|
||||
|
||||
-- set drag and drop
|
||||
tl <- targetListNew
|
||||
atom <- atomNew ("HSFM" :: String)
|
||||
targetListAdd tl atom [TargetSameApp] 0
|
||||
treeViewEnableModelDragDest treeView tl [ActionCopy]
|
||||
treeViewEnableModelDragSource treeView [Button1] tl [ActionCopy]
|
||||
|
||||
-- create final tree model columns
|
||||
renderTxt <- cellRendererTextNew
|
||||
renderPix <- cellRendererPixbufNew
|
||||
@@ -212,16 +293,10 @@ refreshView :: MyGUI
|
||||
refreshView mygui myview mfp =
|
||||
case mfp of
|
||||
Just fp -> do
|
||||
-- readFileWithFileInfo can just outright fail...
|
||||
ecdir <- tryIOError (readFile getFileInfo fp)
|
||||
case ecdir of
|
||||
Right cdir ->
|
||||
-- ...or return an `AnchordFile` with a Failed constructor,
|
||||
-- both of which need to be handled here
|
||||
if (failed cdir)
|
||||
then refreshView mygui myview =<< getAlternativeDir
|
||||
else refreshView' mygui myview cdir
|
||||
Left _ -> refreshView mygui myview =<< getAlternativeDir
|
||||
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
|
||||
@@ -229,7 +304,7 @@ refreshView mygui myview mfp =
|
||||
Item)
|
||||
case ecd of
|
||||
Right dir -> return (Just $ path dir)
|
||||
Left _ -> return (P.parseAbs "/")
|
||||
Left _ -> return (P.parseAbs P.pathSeparator')
|
||||
|
||||
|
||||
-- |Refreshes the View based on the given directory.
|
||||
@@ -240,14 +315,14 @@ refreshView' :: MyGUI
|
||||
-> MyView
|
||||
-> Item
|
||||
-> IO ()
|
||||
refreshView' mygui myview dt@(DirOrSym _) = do
|
||||
newRawModel <- fileListStore dt myview
|
||||
refreshView' mygui myview item@(DirOrSym _) = do
|
||||
newRawModel <- fileListStore item myview
|
||||
writeTVarIO (rawModel myview) newRawModel
|
||||
|
||||
view' <- readTVarIO $ view myview
|
||||
|
||||
_ <- tryTakeMVar (cwd myview)
|
||||
putMVar (cwd myview) dt
|
||||
putMVar (cwd myview) item
|
||||
|
||||
-- get selected items
|
||||
tps <- getSelectedTreePaths mygui myview
|
||||
@@ -255,6 +330,12 @@ refreshView' mygui myview dt@(DirOrSym _) = 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
|
||||
@@ -299,7 +380,7 @@ constructView mygui myview = do
|
||||
cdirp <- path <$> getCurrentDir myview
|
||||
|
||||
-- update urlBar
|
||||
entrySetText (urlBar mygui) (P.fromAbs cdirp)
|
||||
entrySetText (urlBar myview) (P.fromAbs cdirp)
|
||||
|
||||
rawModel' <- readTVarIO $ rawModel myview
|
||||
|
||||
|
||||
@@ -67,24 +67,7 @@ getSelectedItems :: MyGUI
|
||||
-> IO [Item]
|
||||
getSelectedItems mygui myview = do
|
||||
tps <- getSelectedTreePaths mygui myview
|
||||
getSelectedItems' mygui myview tps
|
||||
|
||||
|
||||
getSelectedItems' :: MyGUI
|
||||
-> MyView
|
||||
-> [TreePath]
|
||||
-> IO [Item]
|
||||
getSelectedItems' _ myview tps = do
|
||||
rawModel' <- readTVarIO $ rawModel myview
|
||||
sortedModel' <- readTVarIO $ sortedModel myview
|
||||
filteredModel' <- readTVarIO $ filteredModel myview
|
||||
iters <- catMaybes <$> mapM (treeModelGetIter sortedModel') tps
|
||||
forM iters $ \iter -> do
|
||||
cIter' <- treeModelSortConvertIterToChildIter sortedModel' iter
|
||||
cIter <- treeModelFilterConvertIterToChildIter filteredModel' cIter'
|
||||
treeModelGetRow rawModel' cIter
|
||||
|
||||
|
||||
catMaybes <$> mapM (rawPathToItem myview) tps
|
||||
|
||||
|
||||
-- |Carry out an action on the currently selected item.
|
||||
@@ -124,13 +107,14 @@ getFirstItem myview = do
|
||||
|
||||
|
||||
-- |Reads the current directory from MyView.
|
||||
--
|
||||
-- This reads the MVar and may block the main thread if it's
|
||||
-- empty.
|
||||
getCurrentDir :: MyView
|
||||
-> IO Item
|
||||
getCurrentDir myview = readMVar (cwd myview)
|
||||
|
||||
|
||||
|
||||
|
||||
-- |Push a message to the status bar.
|
||||
pushStatusBar :: MyGUI -> String -> IO (ContextId, MessageId)
|
||||
pushStatusBar mygui str = do
|
||||
@@ -146,3 +130,37 @@ popStatusbar mygui = do
|
||||
let sb = statusBar mygui
|
||||
cid <- statusbarGetContextId sb "FM Status"
|
||||
statusbarPop sb cid
|
||||
|
||||
|
||||
-- |Turn a path on the rawModel into a path that we can
|
||||
-- use at the outermost model layer.
|
||||
rawPathToIter :: MyView -> TreePath -> IO (Maybe TreeIter)
|
||||
rawPathToIter myview tp = do
|
||||
fmodel <- readTVarIO (filteredModel myview)
|
||||
smodel <- readTVarIO (sortedModel myview)
|
||||
msiter <- treeModelGetIter smodel tp
|
||||
forM msiter $ \siter -> do
|
||||
cIter <- treeModelSortConvertIterToChildIter smodel siter
|
||||
treeModelFilterConvertIterToChildIter fmodel cIter
|
||||
|
||||
|
||||
-- |Turn a path on the rawModel into the corresponding item
|
||||
-- that we can use at the outermost model layer.
|
||||
rawPathToItem :: MyView -> TreePath -> IO (Maybe Item)
|
||||
rawPathToItem myview tp = do
|
||||
rawModel' <- readTVarIO $ rawModel myview
|
||||
miter <- rawPathToIter myview tp
|
||||
forM miter $ \iter -> treeModelGetRow rawModel' iter
|
||||
|
||||
|
||||
-- |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
|
||||
|
||||
|
||||
139
src/HSFM/Settings/Bookmarks.hs
Normal file
139
src/HSFM/Settings/Bookmarks.hs
Normal file
@@ -0,0 +1,139 @@
|
||||
{--
|
||||
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 OverloadedStrings #-}
|
||||
{-# OPTIONS_HADDOCK ignore-exports #-}
|
||||
|
||||
module HSFM.Settings.Bookmarks where
|
||||
|
||||
|
||||
import Control.Monad
|
||||
(
|
||||
void
|
||||
)
|
||||
import Data.Attoparsec.ByteString
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.ByteString
|
||||
(
|
||||
ByteString
|
||||
)
|
||||
import Data.Maybe
|
||||
(
|
||||
catMaybes
|
||||
, fromJust
|
||||
)
|
||||
import Data.Word8
|
||||
(
|
||||
_nul
|
||||
)
|
||||
import qualified HPath as P
|
||||
import HPath
|
||||
(
|
||||
Abs
|
||||
, Fn
|
||||
, Path
|
||||
)
|
||||
import HSFM.FileSystem.FileOperations
|
||||
import HSFM.FileSystem.FileType
|
||||
import Prelude hiding (readFile, writeFile)
|
||||
import System.Posix.Env.ByteString
|
||||
(
|
||||
getEnv
|
||||
)
|
||||
|
||||
|
||||
|
||||
-- |A bookmark. `bkName` is principally a description of the bookmark
|
||||
-- but must satisfy the constraints of a filename.
|
||||
data Bookmark = MkBookmark {
|
||||
bkName :: Path Fn
|
||||
, bkPath :: Path Abs
|
||||
} deriving (Show)
|
||||
|
||||
|
||||
-- |Parses bookmarks from a ByteString that has pairs of
|
||||
-- name and path. Name and path are separated by one null character
|
||||
-- and the pairs itself are separated by two null characters from
|
||||
-- each other.
|
||||
bkParser :: Parser [Bookmark]
|
||||
bkParser =
|
||||
fmap catMaybes $ many' (fmap toBm $ bookmark <* word8 _nul <* word8 _nul)
|
||||
where
|
||||
toBm :: (ByteString, ByteString) -> Maybe Bookmark
|
||||
toBm (name, path) = MkBookmark <$> P.parseFn name
|
||||
<*> P.parseAbs path
|
||||
bookmark :: Parser (ByteString, ByteString)
|
||||
bookmark =
|
||||
(\x y -> (BS.pack x, BS.pack y))
|
||||
<$> many1' char
|
||||
<* (word8 _nul)
|
||||
<*> many1' char
|
||||
char = satisfy (`notElem` [_nul])
|
||||
|
||||
|
||||
-- |Writes bookmarks to a given file.
|
||||
writeBookmarks :: [Bookmark] -> IO ()
|
||||
writeBookmarks [] = return ()
|
||||
writeBookmarks bs = do
|
||||
bf <- bookmarksFile
|
||||
bfd <- bookmarksDir
|
||||
mkdirP bfd
|
||||
readFile getFileInfo bfd >>= (\x -> createFile x bookmarksFileName)
|
||||
let str = foldr1 (\x y -> x `BS.append` BS.pack [_nul, _nul]
|
||||
`BS.append`
|
||||
y `BS.append` BS.pack [_nul, _nul])
|
||||
(fmap toByteString bs)
|
||||
file <- readFile getFileInfo bf
|
||||
void $ writeFile file str
|
||||
where
|
||||
toByteString :: Bookmark -> ByteString
|
||||
toByteString b = (P.fromRel $ bkName b)
|
||||
`BS.append` BS.singleton _nul
|
||||
`BS.append` (P.fromAbs $ bkPath b)
|
||||
|
||||
|
||||
-- |Reads bookmarks from a given file.
|
||||
readBookmarks :: IO [Bookmark]
|
||||
readBookmarks = do
|
||||
p <- bookmarksFile
|
||||
file <- readFile getFileInfo p
|
||||
c <- readFileContents file
|
||||
case parseOnly bkParser c of
|
||||
Left _ -> return []
|
||||
Right x -> return x
|
||||
|
||||
|
||||
bookmarksDir :: IO (Path Abs)
|
||||
bookmarksDir = do
|
||||
mhomedir <- getEnv "HOME"
|
||||
case mhomedir of
|
||||
Nothing -> ioError (userError "No valid homedir?!")
|
||||
Just home -> do
|
||||
phome <- P.parseAbs home
|
||||
reldir <- P.parseRel ".config/hsfm"
|
||||
return $ phome P.</> reldir
|
||||
|
||||
|
||||
bookmarksFile :: IO (Path Abs)
|
||||
bookmarksFile = do
|
||||
path <- bookmarksDir
|
||||
return $ path P.</> bookmarksFileName
|
||||
|
||||
|
||||
bookmarksFileName :: Path Fn
|
||||
bookmarksFileName = fromJust $ P.parseFn "bookmarks"
|
||||
Reference in New Issue
Block a user