Initial commit

.gitignore

@@ -0,0 +1,3 @@
+dist/
+.cabal-sandbox/
+cabal.sandbox.config

LICENSE

@@ -0,0 +1,339 @@
+             GNU GENERAL PUBLIC LICENSE
+                Version 2, June 1991
+
+ Copyright (C) 1989, 1991 Free Software Foundation, Inc.,
+ 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+                     Preamble
+
+  The licenses for most software are designed to take away your
+freedom to share and change it.  By contrast, the GNU General Public
+License is intended to guarantee your freedom to share and change free
+software--to make sure the software is free for all its users.  This
+General Public License applies to most of the Free Software
+Foundation's software and to any other program whose authors commit to
+using it.  (Some other Free Software Foundation software is covered by
+the GNU Lesser General Public License instead.)  You can apply it to
+your programs, too.
+
+  When we speak of free software, we are referring to freedom, not
+price.  Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+this service if you wish), that you receive source code or can get it
+if you want it, that you can change the software or use pieces of it
+in new free programs; and that you know you can do these things.
+
+  To protect your rights, we need to make restrictions that forbid
+anyone to deny you these rights or to ask you to surrender the rights.
+These restrictions translate to certain responsibilities for you if you
+distribute copies of the software, or if you modify it.
+
+  For example, if you distribute copies of such a program, whether
+gratis or for a fee, you must give the recipients all the rights that
+you have.  You must make sure that they, too, receive or can get the
+source code.  And you must show them these terms so they know their
+rights.
+
+  We protect your rights with two steps: (1) copyright the software, and
+(2) offer you this license which gives you legal permission to copy,
+distribute and/or modify the software.
+
+  Also, for each author's protection and ours, we want to make certain
+that everyone understands that there is no warranty for this free
+software.  If the software is modified by someone else and passed on, we
+want its recipients to know that what they have is not the original, so
+that any problems introduced by others will not reflect on the original
+authors' reputations.
+
+  Finally, any free program is threatened constantly by software
+patents.  We wish to avoid the danger that redistributors of a free
+program will individually obtain patent licenses, in effect making the
+program proprietary.  To prevent this, we have made it clear that any
+patent must be licensed for everyone's free use or not licensed at all.
+
+  The precise terms and conditions for copying, distribution and
+modification follow.
+
+             GNU GENERAL PUBLIC LICENSE
+   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+  0. This License applies to any program or other work which contains
+a notice placed by the copyright holder saying it may be distributed
+under the terms of this General Public License.  The "Program", below,
+refers to any such program or work, and a "work based on the Program"
+means either the Program or any derivative work under copyright law:
+that is to say, a work containing the Program or a portion of it,
+either verbatim or with modifications and/or translated into another
+language.  (Hereinafter, translation is included without limitation in
+the term "modification".)  Each licensee is addressed as "you".
+
+Activities other than copying, distribution and modification are not
+covered by this License; they are outside its scope.  The act of
+running the Program is not restricted, and the output from the Program
+is covered only if its contents constitute a work based on the
+Program (independent of having been made by running the Program).
+Whether that is true depends on what the Program does.
+
+  1. You may copy and distribute verbatim copies of the Program's
+source code as you receive it, in any medium, provided that you
+conspicuously and appropriately publish on each copy an appropriate
+copyright notice and disclaimer of warranty; keep intact all the
+notices that refer to this License and to the absence of any warranty;
+and give any other recipients of the Program a copy of this License
+along with the Program.
+
+You may charge a fee for the physical act of transferring a copy, and
+you may at your option offer warranty protection in exchange for a fee.
+
+  2. You may modify your copy or copies of the Program or any portion
+of it, thus forming a work based on the Program, and copy and
+distribute such modifications or work under the terms of Section 1
+above, provided that you also meet all of these conditions:
+
+    a) You must cause the modified files to carry prominent notices
+    stating that you changed the files and the date of any change.
+
+    b) You must cause any work that you distribute or publish, that in
+    whole or in part contains or is derived from the Program or any
+    part thereof, to be licensed as a whole at no charge to all third
+    parties under the terms of this License.
+
+    c) If the modified program normally reads commands interactively
+    when run, you must cause it, when started running for such
+    interactive use in the most ordinary way, to print or display an
+    announcement including an appropriate copyright notice and a
+    notice that there is no warranty (or else, saying that you provide
+    a warranty) and that users may redistribute the program under
+    these conditions, and telling the user how to view a copy of this
+    License.  (Exception: if the Program itself is interactive but
+    does not normally print such an announcement, your work based on
+    the Program is not required to print an announcement.)
+
+These requirements apply to the modified work as a whole.  If
+identifiable sections of that work are not derived from the Program,
+and can be reasonably considered independent and separate works in
+themselves, then this License, and its terms, do not apply to those
+sections when you distribute them as separate works.  But when you
+distribute the same sections as part of a whole which is a work based
+on the Program, the distribution of the whole must be on the terms of
+this License, whose permissions for other licensees extend to the
+entire whole, and thus to each and every part regardless of who wrote it.
+
+Thus, it is not the intent of this section to claim rights or contest
+your rights to work written entirely by you; rather, the intent is to
+exercise the right to control the distribution of derivative or
+collective works based on the Program.
+
+In addition, mere aggregation of another work not based on the Program
+with the Program (or with a work based on the Program) on a volume of
+a storage or distribution medium does not bring the other work under
+the scope of this License.
+
+  3. You may copy and distribute the Program (or a work based on it,
+under Section 2) in object code or executable form under the terms of
+Sections 1 and 2 above provided that you also do one of the following:
+
+    a) Accompany it with the complete corresponding machine-readable
+    source code, which must be distributed under the terms of Sections
+    1 and 2 above on a medium customarily used for software interchange; or,
+
+    b) Accompany it with a written offer, valid for at least three
+    years, to give any third party, for a charge no more than your
+    cost of physically performing source distribution, a complete
+    machine-readable copy of the corresponding source code, to be
+    distributed under the terms of Sections 1 and 2 above on a medium
+    customarily used for software interchange; or,
+
+    c) Accompany it with the information you received as to the offer
+    to distribute corresponding source code.  (This alternative is
+    allowed only for noncommercial distribution and only if you
+    received the program in object code or executable form with such
+    an offer, in accord with Subsection b above.)
+
+The source code for a work means the preferred form of the work for
+making modifications to it.  For an executable work, complete source
+code means all the source code for all modules it contains, plus any
+associated interface definition files, plus the scripts used to
+control compilation and installation of the executable.  However, as a
+special exception, the source code distributed need not include
+anything that is normally distributed (in either source or binary
+form) with the major components (compiler, kernel, and so on) of the
+operating system on which the executable runs, unless that component
+itself accompanies the executable.
+
+If distribution of executable or object code is made by offering
+access to copy from a designated place, then offering equivalent
+access to copy the source code from the same place counts as
+distribution of the source code, even though third parties are not
+compelled to copy the source along with the object code.
+
+  4. You may not copy, modify, sublicense, or distribute the Program
+except as expressly provided under this License.  Any attempt
+otherwise to copy, modify, sublicense or distribute the Program is
+void, and will automatically terminate your rights under this License.
+However, parties who have received copies, or rights, from you under
+this License will not have their licenses terminated so long as such
+parties remain in full compliance.
+
+  5. You are not required to accept this License, since you have not
+signed it.  However, nothing else grants you permission to modify or
+distribute the Program or its derivative works.  These actions are
+prohibited by law if you do not accept this License.  Therefore, by
+modifying or distributing the Program (or any work based on the
+Program), you indicate your acceptance of this License to do so, and
+all its terms and conditions for copying, distributing or modifying
+the Program or works based on it.
+
+  6. Each time you redistribute the Program (or any work based on the
+Program), the recipient automatically receives a license from the
+original licensor to copy, distribute or modify the Program subject to
+these terms and conditions.  You may not impose any further
+restrictions on the recipients' exercise of the rights granted herein.
+You are not responsible for enforcing compliance by third parties to
+this License.
+
+  7. If, as a consequence of a court judgment or allegation of patent
+infringement or for any other reason (not limited to patent issues),
+conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License.  If you cannot
+distribute so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you
+may not distribute the Program at all.  For example, if a patent
+license would not permit royalty-free redistribution of the Program by
+all those who receive copies directly or indirectly through you, then
+the only way you could satisfy both it and this License would be to
+refrain entirely from distribution of the Program.
+
+If any portion of this section is held invalid or unenforceable under
+any particular circumstance, the balance of the section is intended to
+apply and the section as a whole is intended to apply in other
+circumstances.
+
+It is not the purpose of this section to induce you to infringe any
+patents or other property right claims or to contest validity of any
+such claims; this section has the sole purpose of protecting the
+integrity of the free software distribution system, which is
+implemented by public license practices.  Many people have made
+generous contributions to the wide range of software distributed
+through that system in reliance on consistent application of that
+system; it is up to the author/donor to decide if he or she is willing
+to distribute software through any other system and a licensee cannot
+impose that choice.
+
+This section is intended to make thoroughly clear what is believed to
+be a consequence of the rest of this License.
+
+  8. If the distribution and/or use of the Program is restricted in
+certain countries either by patents or by copyrighted interfaces, the
+original copyright holder who places the Program under this License
+may add an explicit geographical distribution limitation excluding
+those countries, so that distribution is permitted only in or among
+countries not thus excluded.  In such case, this License incorporates
+the limitation as if written in the body of this License.
+
+  9. The Free Software Foundation may publish revised and/or new versions
+of the General Public License from time to time.  Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+Each version is given a distinguishing version number.  If the Program
+specifies a version number of this License which applies to it and "any
+later version", you have the option of following the terms and conditions
+either of that version or of any later version published by the Free
+Software Foundation.  If the Program does not specify a version number of
+this License, you may choose any version ever published by the Free Software
+Foundation.
+
+  10. If you wish to incorporate parts of the Program into other free
+programs whose distribution conditions are different, write to the author
+to ask for permission.  For software which is copyrighted by the Free
+Software Foundation, write to the Free Software Foundation; we sometimes
+make exceptions for this.  Our decision will be guided by the two goals
+of preserving the free status of all derivatives of our free software and
+of promoting the sharing and reuse of software generally.
+
+                     NO WARRANTY
+
+  11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS
+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE
+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
+REPAIR OR CORRECTION.
+
+  12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGES.
+
+              END OF TERMS AND CONDITIONS
+
+     How to Apply These Terms to Your New Programs
+
+  If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+  To do so, attach the following notices to the program.  It is safest
+to attach them to the start of each source file to most effectively
+convey the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+    <one line to give the program's name and a brief idea of what it does.>
+    Copyright (C) <year>  <name of author>
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    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.
+
+Also add information on how to contact you by electronic and paper mail.
+
+If the program is interactive, make it output a short notice like this
+when it starts in an interactive mode:
+
+    Gnomovision version 69, Copyright (C) year name of author
+    Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+    This is free software, and you are welcome to redistribute it
+    under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the appropriate
+parts of the General Public License.  Of course, the commands you use may
+be called something other than `show w' and `show c'; they could even be
+mouse-clicks or menu items--whatever suits your program.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the program, if
+necessary.  Here is a sample; alter the names:
+
+  Yoyodyne, Inc., hereby disclaims all copyright interest in the program
+  `Gnomovision' (which makes passes at compilers) written by James Hacker.
+
+  <signature of Ty Coon>, 1 April 1989
+  Ty Coon, President of Vice
+
+This General Public License does not permit incorporating your program into
+proprietary programs.  If your program is a subroutine library, you may
+consider it more useful to permit linking proprietary applications with the
+library.  If this is what you want to do, use the GNU Lesser General
+Public License instead of this License.

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

data/Gtk/builder.xml

@@ -0,0 +1,188 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<!-- Generated with glade 3.19.0 -->
+<interface>
+  <requires lib="gtk+" version="3.16"/>
+  <object class="GtkApplicationWindow" id="rootWin">
+    <property name="can_focus">False</property>
+    <child>
+      <object class="GtkBox" id="box1">
+        <property name="visible">True</property>
+        <property name="can_focus">False</property>
+        <property name="orientation">vertical</property>
+        <child>
+          <object class="GtkMenuBar" id="menubar">
+            <property name="visible">True</property>
+            <property name="can_focus">False</property>
+            <child>
+              <object class="GtkMenuItem" id="menubarFile">
+                <property name="visible">True</property>
+                <property name="can_focus">False</property>
+                <property name="label" translatable="yes">_File</property>
+                <property name="use_underline">True</property>
+                <child type="submenu">
+                  <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="GtkSeparatorMenuItem" id="separatormenuitem1">
+                        <property name="visible">True</property>
+                        <property name="can_focus">False</property>
+                      </object>
+                    </child>
+                    <child>
+                      <object class="GtkImageMenuItem" id="menubarFileQuit">
+                        <property name="label">gtk-quit</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="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="menubarFileCut">
+                        <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="menubarFileCopy">
+                        <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="menubarFilePaste">
+                        <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="menubarFileDelete">
+                        <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>
+                <property name="can_focus">False</property>
+                <property name="label" translatable="yes">_View</property>
+                <property name="use_underline">True</property>
+              </object>
+            </child>
+            <child>
+              <object class="GtkMenuItem" id="menubarHelp">
+                <property name="visible">True</property>
+                <property name="can_focus">False</property>
+                <property name="label" translatable="yes">_Help</property>
+                <property name="use_underline">True</property>
+                <child type="submenu">
+                  <object class="GtkMenu" id="menu3">
+                    <property name="visible">True</property>
+                    <property name="can_focus">False</property>
+                    <child>
+                      <object class="GtkImageMenuItem" id="menubarHelpAbout">
+                        <property name="label">gtk-about</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>
+          </object>
+          <packing>
+            <property name="expand">False</property>
+            <property name="fill">True</property>
+            <property name="position">0</property>
+          </packing>
+        </child>
+        <child>
+          <object class="GtkBox" id="box2">
+            <property name="visible">True</property>
+            <property name="can_focus">False</property>
+            <child>
+              <placeholder/>
+            </child>
+            <child>
+              <object class="GtkEntry" id="urlBar">
+                <property name="visible">True</property>
+                <property name="can_focus">True</property>
+                <property name="input_purpose">url</property>
+              </object>
+              <packing>
+                <property name="expand">True</property>
+                <property name="fill">True</property>
+                <property name="position">1</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>
+            <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">2</property>
+          </packing>
+        </child>
+      </object>
+    </child>
+  </object>
+</interface>

hsfm.cabal

@@ -0,0 +1,64 @@
+name:                hsfm
+version:             0.0.0.1
+synopsis:            Haskell FileManager
+description:         Lazy FileManager written in haskell
+license:             GPL-2
+license-file:        LICENSE
+author:              Julian Ospald
+maintainer:          hasufell@hasufell.de
+copyright:           Copyright: (c) 2015 Julian Ospald
+category:            Desktop
+build-type:          Simple
+cabal-version:       >=1.10
+
+library
+  exposed-modules:     Data.DirTree
+                       Data.DirTree.Zipper
+                       IO.Utils
+                       IO.File
+                       IO.Error
+
+  build-depends:       base >= 4.7,
+                       data-default,
+                       bifunctors >= 5,
+                       directory >= 1.1.0.0 && < 1.2.3.0,
+                       easy-file >= 0.2.0,
+                       filepath >= 1.3.0.0,
+                       mtl >= 2.2,
+                       old-locale >= 1,
+                       process,
+                       stm,
+                       text,
+                       time >= 1.4.2
+  hs-source-dirs:      src
+  default-language:    Haskell2010
+  Default-Extensions:  RecordWildCards
+  ghc-options:
+    -O2
+
+executable hsfm-gtk
+  main-is:             GUI/Gtk.hs
+  other-modules:       GUI.Gtk.Callbacks
+                       GUI.Gtk.Icons
+                       GUI.Gtk.Gui
+  build-depends:       hsfm,
+                       base >= 4.7,
+                       data-default,
+                       gtk3 >= 0.14.1,
+                       glib >= 0.13,
+                       bifunctors >= 5,
+                       directory >= 1.1.0.0 && < 1.2.3.0,
+                       easy-file >= 0.2.0,
+                       filepath >= 1.3.0.0,
+                       mtl >= 2.2,
+                       old-locale >= 1,
+                       process,
+                       stm,
+                       text,
+                       time >= 1.4.2,
+                       transformers >= 0.4
+  hs-source-dirs:      src
+  default-language:    Haskell2010
+  Default-Extensions:  RecordWildCards
+  ghc-options:
+    -O2

src/Data/DirTree.hs

@@ -0,0 +1,714 @@
+{-# OPTIONS_HADDOCK ignore-exports #-}
+
+module Data.DirTree where
+
+
+import Control.Applicative
+  (
+    (<*>)
+  , (<$>)
+  , (<|>)
+  , pure
+  )
+import Control.Arrow
+  (
+    first
+  )
+import Control.Exception
+  (
+    handle
+  )
+import Control.Exception.Base
+  (
+    IOException
+  )
+import Control.Monad.State.Lazy
+  (
+
+  )
+import Data.Default
+import Data.Ord
+  (
+    comparing
+  )
+import Data.List
+  (
+    delete
+  , sort
+  , sortBy
+  , (\\)
+  )
+import Data.Time
+  (
+    UTCTime
+  , formatTime
+  )
+import Data.Word
+  (
+    Word64
+  )
+import System.Directory
+  (
+    Permissions(..)
+  , createDirectoryIfMissing
+  , doesFileExist
+  , getDirectoryContents
+  , getModificationTime
+  , getPermissions
+  , writable
+  , searchable
+  )
+import System.EasyFile
+  (
+    getCreationTime
+  , getChangeTime
+  , getAccessTime
+  , getFileSize
+  , hasSubDirectories
+  , isSymlink
+  )
+import System.FilePath
+  (
+    combine
+  , equalFilePath
+  , joinPath
+  , splitDirectories
+  , (</>)
+  )
+import System.IO
+  (
+    IOMode
+  , Handle
+  , openFile
+  )
+import System.IO.Error
+  (
+    ioeGetErrorType
+  , isDoesNotExistErrorType
+  )
+import System.IO.Unsafe
+  (
+    unsafeInterleaveIO
+  )
+import System.Locale
+  (
+    defaultTimeLocale
+  , rfc822DateFormat
+  )
+import qualified Data.Bitraversable as BT
+import qualified Data.Bifunctor     as BF
+import qualified Data.Bifoldable    as BFL
+import qualified Data.Traversable   as T
+
+
+
+    ----------------------------
+    --[ BASE TYPES ]--
+    ----------------------------
+
+
+-- |Weak type to distinguish between FilePath and FileName.
+type FileName = String
+
+
+-- |A simple wrapper to hold a base directory name, which can be either an
+-- absolute or relative path. This lets us give the DirTree a context, while
+-- still letting us store only directory and file /names/ (not full paths) in
+-- the DirTree. (uses an infix constructor; don't be scared)
+data AnchoredDirTree a b =
+  (:/) { anchor :: FilePath, dirTree :: DirTree a b }
+  deriving (Eq, Ord, Show)
+
+
+-- |The String in the name field is always a file name, never a full path.
+-- The free type variable is used in the File/Dir constructor and can hold
+-- Handles, Strings representing a file's contents or anything else you can
+-- think of. We catch any IO errors in the Failed constructor. an Exception
+-- can be converted to a String with 'show'.
+data DirTree a b =
+    Failed {
+    name :: FileName
+  , err  :: IOException
+  }
+  | Dir {
+    name     :: FileName
+  , contents :: [DirTree a b]
+  , dir      :: a
+  }
+  | File {
+    name :: FileName
+  , file :: b
+  } deriving Show
+
+
+-- |All possible directory information we could ever need from a directory.
+data DirTreeInfo =
+  DirInfo {
+    permissions  :: Permissions
+  , creationTime :: Maybe UTCTime
+  , changeTime   :: Maybe UTCTime
+  , modTime      :: UTCTime
+  , accessTime   :: UTCTime
+  , sym          :: Bool
+  , hasSubDirs   :: Maybe Bool
+  }
+  | FileInfo {
+    permissions  :: Permissions
+  , creationTime :: Maybe UTCTime
+  , changeTime   :: Maybe UTCTime
+  , modTime      :: UTCTime
+  , accessTime   :: UTCTime
+  , sym          :: Bool
+  , fileSize     :: Word64
+  }
+  deriving (Show, Eq, Ord)
+
+
+
+
+    ----------------------------
+    --[ INSTANCES ]--
+    ----------------------------
+
+
+instance BF.Bifunctor DirTree where
+  bimap = BT.bimapDefault
+
+
+instance BFL.Bifoldable DirTree where
+  bifoldMap = BT.bifoldMapDefault
+
+
+instance BT.Bitraversable DirTree where
+    bitraverse f1 f2 (Dir n cs b) =
+      Dir n
+        <$> T.traverse (BT.bitraverse f1 f2) cs
+        <*> f1 b
+    bitraverse _ f2 (File n a) =
+      File n <$> f2 a
+    bitraverse _ _ (Failed n e) =
+      pure (Failed n e)
+
+
+-- | Two DirTrees are equal if they have the same constructor, the same name
+-- (and in the case of `Dir`s) their sorted `contents` are equal:
+instance (Eq a, Eq b) => Eq (DirTree a b) where
+    (File n a) == (File n' a') = n == n' && a == a'
+    (Dir n cs _) == (Dir n' cs' _) =
+        n == n' && sortBy comparingConstr cs == sortBy comparingConstr cs'
+     -- after comparing above we can hand off to shape equality function:
+    d == d' = equalShape d d'
+
+
+-- | First compare constructors: Failed < Dir < File...
+-- Then compare `name`...
+-- Then compare free variable parameter of `File` constructors
+instance (Ord a, Ord b, Eq a, Eq b) => Ord (DirTree a b) where
+    compare (File n a) (File n' a') =
+        case compare n n' of
+             EQ -> compare a a'
+             el -> el
+    compare (Dir n cs b) (Dir n' cs' b') =
+        case compare n n' of
+             EQ -> case compare b b' of
+               EQ -> comparing sort cs cs'
+               el -> el
+             el -> el
+     -- after comparing above we can hand off to shape ord function:
+    compare d d' = comparingShape d d'
+
+
+-- for convenience:
+instance BF.Bifunctor AnchoredDirTree where
+    bimap fd ff (b:/d) = b :/ BF.bimap fd ff d
+
+
+
+-- given the same fixity as <$>, is that right?
+infixl 4 </$>
+
+
+
+    ----------------------------
+    --[ HIGH LEVEL FUNCTIONS ]--
+    ----------------------------
+
+
+-- | build an AnchoredDirTree, given the path to a directory, opening the files
+-- using readFile.
+-- Uses `readDirectoryWith` internally and has the effect of traversing the
+-- entire directory structure. See `readDirectoryWithL` for lazy production
+-- of a DirTree structure.
+readDirectory :: FilePath -> IO (AnchoredDirTree String String)
+readDirectory = readDirectoryWith readFile return
+
+
+-- | same as readDirectory but allows us to, for example, use
+-- ByteString.readFile to return a tree of ByteStrings.
+readDirectoryWith :: (FilePath -> IO a)
+                  -> (FilePath -> IO b)
+                  -> FilePath
+                  -> IO (AnchoredDirTree a b)
+readDirectoryWith fd ff p = buildWith' buildAtOnce' fd ff p
+
+
+-- | A "lazy" version of `readDirectoryWith` that does IO operations as needed
+-- i.e. as the tree is traversed in pure code.
+-- /NOTE:/ This function uses unsafeInterleaveIO under the hood. I believe
+-- our use here is safe, but this function is experimental in this release:
+readDirectoryWithL :: (FilePath -> IO a)
+                   -> (FilePath -> IO b)
+                   -> FilePath
+                   -> IO (AnchoredDirTree a b)
+readDirectoryWithL fd ff p = buildWith' buildLazilyUnsafe' fd ff p
+
+
+-- | write a DirTree of strings to disk. Clobbers files of the same name.
+-- Doesn't affect files in the directories (if any already exist) with
+-- different names. Returns a new AnchoredDirTree where failures were
+-- lifted into a `Failed` constructor:
+writeDirectory :: AnchoredDirTree String String -> IO (AnchoredDirTree () ())
+writeDirectory = writeDirectoryWith writeFile
+
+
+-- | writes the directory structure to disk and uses the provided function to
+-- write the contents of `Files` to disk. The return value of the function will
+-- become the new `contents` of the returned, where IO errors at each node are
+-- replaced with `Failed` constructors. The returned tree can be compared to
+-- the passed tree to see what operations, if any, failed:
+writeDirectoryWith :: (FilePath -> af -> IO bf)
+                   -> AnchoredDirTree ad af
+                   -> IO (AnchoredDirTree () bf)
+writeDirectoryWith f (b:/t) = (b:/) <$> write' b t
+    where write' b' (File n a) = handleDT n $
+              File n <$> f (b'</>n) a
+          write' b' (Dir n cs _) = handleDT n $
+              do let bas = b'</>n
+                 createDirectoryIfMissing True bas
+                 Dir n <$> mapM (write' bas) cs <*> return ()
+          write' _ (Failed n e) = return $ Failed n e
+
+
+
+
+
+
+    -----------------------------
+    --[ LOWER LEVEL FUNCTIONS ]--
+    -----------------------------
+
+
+-- | a simple application of readDirectoryWith openFile:
+openDirectory :: FilePath -> IOMode -> IO (AnchoredDirTree () Handle)
+openDirectory p m = readDirectoryWith (\_ -> return ()) (flip openFile m) p
+
+
+
+-- | builds a DirTree from the contents of the directory passed to it, saving
+-- the base directory in the Anchored* wrapper. Errors are caught in the tree in
+-- the Failed constructor. The 'file' fields initially are populated with full
+-- paths to the files they are abstracting.
+build :: FilePath -> IO (AnchoredDirTree FilePath FilePath)
+build = buildWith' buildAtOnce' return return   -- we say 'return' here to get
+                                                -- back a  tree  of  FilePaths
+
+
+-- | identical to `build` but does directory reading IO lazily as needed:
+buildL :: FilePath -> IO (AnchoredDirTree FilePath FilePath)
+buildL = buildWith' buildLazilyUnsafe' return return
+
+
+
+
+    -- -- -- helpers: -- -- --
+
+
+type UserIO a = FilePath -> IO a
+type Builder a b = UserIO a -> UserIO b -> FilePath -> IO (DirTree a b)
+
+-- remove non-existent file errors, which are artifacts of the "non-atomic"
+-- nature of traversing a system firectory tree:
+buildWith' :: Builder a b
+           -> UserIO a
+           -> UserIO b
+           -> FilePath
+           -> IO (AnchoredDirTree a b)
+buildWith' bf' fd ff p =
+    do tree <- bf' fd ff p
+       return (baseDir p :/ removeNonexistent tree)
+
+
+
+-- IO function passed to our builder and finally executed here:
+buildAtOnce' :: Builder a b
+buildAtOnce' fd ff p = handleDT n $
+           do isFile <- doesFileExist p
+              if isFile
+                 then  File n <$> ff p
+                 else do cs <- getDirsFiles p
+                         Dir n
+                           <$> T.mapM (buildAtOnce' fd ff . combine p) cs
+                           <*> fd p
+     where n = topDir p
+
+
+-- using unsafeInterleaveIO to get "lazy" traversal:
+buildLazilyUnsafe' :: Builder a b
+buildLazilyUnsafe' fd ff p = handleDT n $
+           do isFile <- doesFileExist p
+              if isFile
+                 then File n <$> ff p
+                 -- HERE IS THE UNSAFE CODE:
+                 else do
+                   -- this is not behind unsafeInterleaveIO on purpose
+                   -- otherwise we might get runtime exceptions
+                   files <- getDirsFiles p
+                   contents <- unsafeInterleaveIO $
+                      mapM (rec . combine p) files
+                   d <- fd p
+                   return $ Dir n contents d
+     where rec = buildLazilyUnsafe' fd ff
+           n = topDir p
+
+
+
+
+    -----------------
+    --[ UTILITIES ]--
+    -----------------
+
+
+
+---- HANDLING FAILURES ----
+
+
+-- | True if any Failed constructors in the tree
+anyFailed :: DirTree a b -> Bool
+anyFailed = not . successful
+
+-- | True if there are no Failed constructors in the tree
+successful :: DirTree a b -> Bool
+successful = null . failures
+
+
+-- | returns true if argument is a `Failed` constructor:
+failed :: DirTree a b -> Bool
+failed (Failed _ _) = True
+failed _            = False
+
+
+-- | returns a list of 'Failed' constructors only:
+failures :: DirTree a b -> [DirTree a b]
+failures = filter failed . flattenDir
+
+
+-- | maps a function to convert Failed DirTrees to Files or Dirs
+failedMap :: (FileName -> IOException -> DirTree a b) -> DirTree a b -> DirTree a b
+failedMap f = transformDir unFail
+    where unFail (Failed n e) = f n e
+          unFail c            = c
+
+
+---- ORDERING AND EQUALITY ----
+
+
+-- | Recursively sort a directory tree according to the Ord instance
+sortDir :: (Ord a, Ord b) => DirTree a b -> DirTree a b
+sortDir = sortDirBy compare
+
+-- | Recursively sort a tree as in `sortDir` but ignore the file contents of a
+-- File constructor
+sortDirShape :: DirTree a b -> DirTree a b
+sortDirShape = sortDirBy comparingShape  where
+
+  -- HELPER:
+sortDirBy :: (DirTree a b -> DirTree a b -> Ordering) -> DirTree a b -> DirTree a b
+sortDirBy cf = transformDir sortD
+    where sortD (Dir n cs a) = Dir n (sortBy cf cs) a
+          sortD c            = c
+
+
+-- | Tests equality of two trees, ignoring their free variable portion. Can be
+-- used to check if any files have been added or deleted, for instance.
+equalShape :: DirTree a b -> DirTree c d -> Bool
+equalShape d d' = comparingShape d d' == EQ
+
+-- TODO: we should use equalFilePath here, but how to sort properly? with System.Directory.canonicalizePath, before compare?
+
+-- | a compare function that ignores the free "file" type variable:
+comparingShape :: DirTree a b -> DirTree c d -> Ordering
+comparingShape (Dir n cs _) (Dir n' cs' _) =
+    case compare n n' of
+         EQ -> comp (sortCs cs) (sortCs cs')
+         el -> el
+    where sortCs = sortBy comparingConstr
+           -- stolen from [] Ord instance:
+          comp []     []     = EQ
+          comp []     (_:_)  = LT
+          comp (_:_)  []     = GT
+          comp (x:xs) (y:ys) = case comparingShape x y of
+                                    EQ    -> comp xs ys
+                                    other -> other
+ -- else simply compare the flat constructors, non-recursively:
+comparingShape t t'  = comparingConstr t t'
+
+
+ -- HELPER: a non-recursive comparison
+comparingConstr :: DirTree a b -> DirTree a1 b1 -> Ordering
+comparingConstr (Failed _ _) (Dir _ _ _)  = LT
+comparingConstr (Failed _ _) (File _ _)   = LT
+comparingConstr (File _ _)   (Failed _ _) = GT
+comparingConstr (File _ _)   (Dir _ _ _)  = GT
+comparingConstr (Dir _ _ _)  (Failed _ _) = GT
+comparingConstr (Dir _ _ _)  (File _ _)   = LT
+ -- else compare on the names of constructors that are the same, without
+ -- looking at the contents of Dir constructors:
+comparingConstr t t'  = compare (name t) (name t')
+
+
+
+
+---- OTHER ----
+
+-- | If the argument is a 'Dir' containing a sub-DirTree matching 'FileName'
+-- then return that subtree, appending the 'name' of the old root 'Dir' to the
+-- 'anchor' of the AnchoredDirTree wrapper. Otherwise return @Nothing@.
+dropTo :: FileName -> AnchoredDirTree a b -> Maybe (AnchoredDirTree a b)
+dropTo n' (p :/ Dir n ds' _) = search ds'
+    where search [] = Nothing
+          search (d:ds) | equalFilePath n' (name d) = Just ((p</>n) :/ d)
+                        | otherwise = search ds
+dropTo _ _ = Nothing
+
+
+find :: FilePath
+     -> AnchoredDirTree a b
+     -> Either String (AnchoredDirTree a b)
+find f d = findAbs f d <|> findRel f d
+
+
+-- |Finds a file or directory inside an @AnchoredDirTree@. This only
+-- looks at the subdirectories of the underlying @DirTree@. If you
+-- want to compare the name of the topmost @DirTree@ as well, use @find'@.
+findRel :: FilePath
+        -> AnchoredDirTree a b
+        -> Either String (AnchoredDirTree a b)
+findRel f d =
+  go (splitDirectories f) d
+  where
+    go (f:fs) (p :/ Dir n ds _) = search ds f >>= go fs
+      where
+        search [] _ = Left "Directory or file not found!"
+        search (d:ds) n | equalFilePath n (name d) = Right ((p</>n) :/ d)
+                        | otherwise                = search ds n
+    go [] d = Right d
+    go _ (p :/ Failed _ err) = Left $ show err
+    go _ _  = Left "Directory or file not found!"
+
+
+-- |Finds a file or directory inside an @AnchoredDirTree@. This also
+-- looks at the topmost @DirTree@ and compares the first path component
+-- with it. If you only want to look at subdirectories, use @find@.
+findAbs :: FilePath
+        -> AnchoredDirTree a b
+        -> Either String (AnchoredDirTree a b)
+findAbs f d =
+  go (splitDirectories f) d
+  where
+    go (f':fs) (_ :/ Dir n _ _)
+      | equalFilePath f' n = find (joinPath fs) d
+      | otherwise          = Left "Directory or file not found!"
+    go _ (p :/ Failed _ err) = Left $ show err
+    go _ _  = Left "Directory or file not found!"
+
+
+-- | applies the predicate to each constructor in the tree, removing it (and
+-- its children, of course) when the predicate returns False. The topmost
+-- constructor will always be preserved:
+filterDir :: (DirTree a b -> Bool) -> DirTree a b -> DirTree a b
+filterDir p = transformDir filterD
+    where filterD (Dir n cs a) = Dir n (filter p cs) a
+          filterD c            = c
+
+
+-- | Flattens a `DirTree` into a (never empty) list of tree constructors. `Dir`
+-- constructors will have [] as their `contents`:
+flattenDir :: DirTree a b -> [ DirTree a b ]
+flattenDir (Dir n cs a) = Dir n [] a : concatMap flattenDir cs
+flattenDir f            = [f]
+
+
+
+
+
+-- | Allows for a function on a bare DirTree to be applied to an AnchoredDirTree
+-- within a Functor. Very similar to and useful in combination with `<$>`:
+(</$>) :: (Functor f) => (DirTree a a1 -> DirTree b b1) -> f (AnchoredDirTree a a1) ->
+                         f (AnchoredDirTree b b1)
+(</$>) f = fmap (\(b :/ t) -> b :/ f t)
+
+
+    ---------------
+    --[ HELPERS ]--
+    ---------------
+
+
+---- CONSTRUCTOR IDENTIFIERS ----
+isFileC :: DirTree a b -> Bool
+isFileC (File _ _) = True
+isFileC _          = False
+
+isDirC :: DirTree a b -> Bool
+isDirC (Dir _ _ _) = True
+isDirC _           = False
+
+
+---- PATH CONVERSIONS ----
+
+
+
+-- | tuple up the complete file path with the 'file' contents, by building up the
+-- path, trie-style, from the root. The filepath will be relative to \"anchored\"
+-- directory.
+--
+-- This allows us to, for example, @mapM_ uncurry writeFile@ over a DirTree of
+-- strings, although 'writeDirectory' does a better job of this.
+zipPaths :: AnchoredDirTree a b -> DirTree (FilePath, a) (FilePath, b)
+zipPaths (b :/ t) = zipP b t
+    where zipP p (File n a)   = File n (p</>n , a)
+          zipP p (Dir n cs a) = Dir n (map (zipP $ p</>n) cs) (p</>n , a)
+          zipP _ (Failed n e) = Failed n e
+
+
+-- extracting pathnames and base names:
+topDir, baseDir :: FilePath -> FilePath
+topDir = last . splitDirectories
+baseDir = joinPath . init . splitDirectories
+
+
+
+---- IO HELPERS: ----
+
+
+-- | writes the directory structure (not files) of a DirTree to the anchored
+-- directory. Returns a structure identical to the supplied tree with errors
+-- replaced by `Failed` constructors:
+writeJustDirs :: AnchoredDirTree a b -> IO (AnchoredDirTree () b)
+writeJustDirs = writeDirectoryWith (const return)
+
+
+----- the let expression is an annoying hack, because dropFileName "." == ""
+----- and getDirectoryContents fails epically on ""
+-- prepares the directory contents list. we sort so that we can be sure of
+-- a consistent fold/traversal order on the same directory:
+getDirsFiles :: String -> IO [FilePath]
+getDirsFiles cs = do let cs' = if null cs then "." else cs
+                     dfs <- getDirectoryContents cs'
+                     return $ dfs \\ [".",".."]
+
+
+readPath :: FilePath
+         -> IO (AnchoredDirTree DirTreeInfo DirTreeInfo)
+readPath = readDirectoryWithL mkDirInfo mkFileInfo
+
+
+mkFileInfo :: FilePath -> IO DirTreeInfo
+mkFileInfo fp =
+  FileInfo
+    <$> getPermissions      fp
+    <*> getCreationTime     fp
+    <*> getChangeTime       fp
+    <*> getModificationTime fp
+    <*> getAccessTime       fp
+    <*> isSymlink           fp
+    <*> getFileSize         fp
+
+
+mkDirInfo :: FilePath -> IO DirTreeInfo
+mkDirInfo fp =
+  DirInfo
+    <$> getPermissions      fp
+    <*> getCreationTime     fp
+    <*> getChangeTime       fp
+    <*> getModificationTime fp
+    <*> getAccessTime       fp
+    <*> isSymlink           fp
+    <*> hasSubDirectories   fp
+
+
+getFreeVar :: DirTree a a -> Maybe a
+getFreeVar (File _ f)  = Just f
+getFreeVar (Dir _ _ d) = Just d
+getFreeVar _           = Nothing
+
+
+---- FAILURE HELPERS: ----
+
+
+-- handles an IO exception by returning a Failed constructor filled with that
+-- exception:
+handleDT :: FileName -> IO (DirTree a b) -> IO (DirTree a b)
+handleDT n = handle (return . Failed n)
+
+
+-- DoesNotExist errors not present at the topmost level could happen if a
+-- named file or directory is deleted after being listed by
+-- getDirectoryContents but before we can get it into memory.
+--    So we filter those errors out because the user should not see errors
+-- raised by the internal implementation of this module:
+--     This leaves the error if it exists in the top (user-supplied) level:
+removeNonexistent :: DirTree a b -> DirTree a b
+removeNonexistent = filterDir isOkConstructor
+     where isOkConstructor c = not (failed c) || isOkError c
+           isOkError = not . isDoesNotExistErrorType . ioeGetErrorType . err
+
+
+-- | At 'Dir' constructor, apply transformation function to all of directory's
+-- contents, then remove the Nothing's and recurse. This always preserves the
+-- topomst constructor.
+transformDir :: (DirTree a b -> DirTree a b) -> DirTree a b -> DirTree a b
+transformDir f t = case f t of
+                     (Dir n cs a) -> Dir n (map (transformDir f) cs) a
+                     t'           -> t'
+
+
+
+---- OTHER: ----
+
+
+anchoredToPath :: AnchoredDirTree a b -> FilePath
+anchoredToPath a = anchor a </> (name . dirTree $ a)
+
+
+ls :: DirTree DirTreeInfo DirTreeInfo
+   -> [(FileName, String)]
+ls dt = fmap (\x -> (name x, packModTime x)) (contents dt)
+
+
+fromFreeVar :: (Default d) => (a -> d) -> DirTree a a -> d
+fromFreeVar f dt = maybeD f $ getFreeVar dt
+
+
+maybeD :: (Default b) => (a -> b) -> Maybe a -> b
+maybeD = maybe def
+
+
+-- |Pack the modification time
+packModTime :: DirTree DirTreeInfo DirTreeInfo
+            -> String
+packModTime = fromFreeVar
+                $ formatTime defaultTimeLocale rfc822DateFormat
+                . modTime
+
+
+packPermissions :: DirTree DirTreeInfo DirTreeInfo
+                -> String
+packPermissions dt = fromFreeVar (pStr . permissions) dt
+  where
+    pStr perm =    str perm readable   "r"
+                ++ str perm writable   "w"
+                ++ str perm (if isDirC dt then searchable else executable)
+                            "x"
+    str perm f ch
+      | f perm    = ch
+      | otherwise = "-"

src/Data/DirTree/Zipper.hs

@@ -0,0 +1,178 @@
+{-# OPTIONS_HADDOCK ignore-exports #-}
+
+module Data.DirTree.Zipper where
+
+
+import Control.Applicative
+  (
+    (<$>)
+  )
+import Control.Arrow
+  (
+    first
+  )
+import Data.DirTree
+import System.Directory
+  (
+    canonicalizePath
+  )
+import System.FilePath
+ (
+    equalFilePath
+  , splitPath
+  , takeDirectory
+  , (</>)
+ )
+import System.IO.Unsafe
+  (
+    unsafeInterleaveIO
+  )
+import qualified Data.List as DL
+
+
+    ----------------------------
+    --[ ZIPPING ]--
+    ----------------------------
+
+
+-- |The zipper type, left is the (current) directory, right
+-- are the breadcrumbs.
+type DTZipper a b = (DirTree a b, [DirTree a b])
+
+
+-- |The base zipper of a tree with empty crumbs element.
+baseZipper :: DirTree a b -> DTZipper a b
+baseZipper dt = (dt, [])
+
+
+-- |Goes down the given subdir or file in a given directory. Returns `Nothing`
+-- if the subdir or file does not exist.
+--
+-- Note that this function can be slow, so it's not supposed to be called
+-- over a list of zippers. Use `goAllDown` instead.
+goDown :: FileName -> DTZipper a b -> Maybe (DTZipper a b)
+goDown ['.'] dtz      = Just dtz
+goDown ['.', '.'] dtz = Just $ goUp dtz
+goDown fn (dtp@(Dir n cs d), xs) =
+  case mcdt of
+    Just cdt -> Just (cdt, Dir n (crumb' fn cs) d : xs)
+    Nothing  -> Nothing
+  where
+    mcdt  = DL.find (\x -> equalFilePath (name x) fn) cs
+goDown _ _            = Nothing
+
+
+-- |Goes down all subdirs of a given directory.
+goAllDown :: DTZipper a b -> [DTZipper a b]
+goAllDown (Dir n cs d, xs) = fmap (\x -> (x, Dir n (crumb x cs) d : xs)) cs
+goAllDown _                = []
+
+
+-- |Goes down the given subpath in a given directory. Returns `Nothing`
+-- if the subpath does not exist.
+goDown' :: FilePath -> DTZipper a b -> Maybe (DTZipper a b)
+goDown' fp dz = go (splitPath fp) dz
+  where
+    go []  dz      = Just dz
+    go (fn:fns) dz = goDown fn dz >>= go fns
+
+
+-- TODO: error handling if the parent of a file is a file too (wat?)
+-- |Goes up one directory. This cannot fail. If you call it on the
+-- root node of the zipper, you get it back untouched.
+goUp :: DTZipper a b -> DTZipper a b
+goUp dz@(_, [])            = dz
+goUp (dt, Dir n cs d : xs) = (Dir n (dt:cs) d, xs)
+
+
+-- |Goes up to the root directory/node of the zipper.
+goRoot :: DTZipper a b -> DTZipper a b
+goRoot dz@(_, []) = dz
+goRoot dz         = goRoot (goUp dz)
+
+
+-- |Gets the full path of the current directory in the zipper context.
+-- This might not be a real absolute filesystem path, because it depends
+-- on the zipper context.
+getFullPath :: DTZipper a b -> FilePath
+getFullPath dz@(dt, _:_) = getFullPath (goUp dz) </> name dt
+getFullPath    (dt, [])  = name dt
+
+
+-- |The zipper that describes the ".." file inside a directory. The name
+-- is set to ".." too.
+upDirZipper :: DTZipper a b -> DTZipper a b
+upDirZipper dz = zipMap (\x -> x { name = "..", contents = [] }) $ goUp dz
+
+
+-- |The zipper that describes the "." file inside a directory. The name
+-- is set to "." too.
+curDirZipper :: DTZipper a b -> DTZipper a b
+curDirZipper dz = zipMap (\x -> x { name = ".", contents = [] }) dz
+
+
+-- |Retrieve the (current) directory component from the zipper.
+unZip :: DTZipper a b -> DirTree a b
+unZip = fst
+
+
+-- |Retrieve the (current) directory component from the zipper and
+-- transform it to an `AnchoredDirTree`.
+unZip' :: DTZipper a b -> AnchoredDirTree a b
+unZip' dz@(dt, _) = (takeDirectory . getFullPath $ dz) :/ dt
+
+
+-- |Map a function over the (current) directory component of the zipper.
+zipMap :: (DirTree a b -> DirTree a b) -> DTZipper a b -> DTZipper a b
+zipMap = first
+
+
+-- |Creates a zipper at the given location with lazy breadcrumbs. That
+-- means it doesn't traverse to the destination directory through the whole
+-- tree.
+--
+-- This can throw an exception on `canonicalizePath`.
+--
+-- It uses `unsafeInterleaveIO` and `readDirectoryWithL` to achieve
+-- lazy traversal.
+zipLazy :: (FilePath -> IO a)  -- ^ builder function for the free dir var
+        -> (FilePath -> IO b)  -- ^ builder function for the free file var
+        -> FilePath            -- ^ file path to drop to
+        -> IO (DTZipper a b)
+zipLazy fd ff fp = do
+  dt <- dirTree <$> readDirectoryWithL fd ff fp
+  go dt fp
+  where
+    go dt fp' = do
+      -- TODO: I hope parentDir doesn't blow up
+      parentDir <- canonicalizePath (fp' ++ "/..")
+      if fp' == parentDir
+         then return $ baseZipper dt
+         else do
+           -- HERE IS THE UNSAFE CODE:
+           crumbs <- unsafeInterleaveIO $ crumbrec parentDir
+           return (dt, crumbs)
+      where
+        crumbrec pD = do
+          pdt@(Dir n cs d) <- dirTree <$> readDirectoryWithL fd ff pD
+          (_, pc) <- go pdt pD
+          return $ Dir n (crumb dt cs) d : pc
+
+
+readPath' :: FilePath -> IO (DTZipper DirTreeInfo DirTreeInfo)
+readPath' = zipLazy mkDirInfo mkFileInfo
+
+
+    ---------------
+    --[ HELPERS ]--
+    ---------------
+
+
+crumb :: DirTree a b -> [DirTree a b] -> [DirTree a b]
+crumb dt cs = crumb' (name dt) cs
+
+
+crumb' :: FileName -> [DirTree a b] -> [DirTree a b]
+crumb' fn cs =
+  foldr (\x y -> if equalFilePath fn (name x) then y else x : y)
+        [] cs

src/GUI/Gtk.hs

@@ -0,0 +1,14 @@
+{-# OPTIONS_HADDOCK ignore-exports #-}
+
+module Main where
+
+import Graphics.UI.Gtk
+import GUI.Gtk.Gui
+
+main :: IO ()
+main = do
+  _ <- initGUI
+
+  startMainWindow
+
+  mainGUI

src/GUI/Gtk/Callbacks.hs

@@ -0,0 +1,3 @@
+{-# OPTIONS_HADDOCK ignore-exports #-}
+
+module GUI.Gtk.Callbacks (startGUI) where

src/GUI/Gtk/Gui.hs

@@ -0,0 +1,424 @@
+{-# OPTIONS_HADDOCK ignore-exports #-}
+
+module GUI.Gtk.Gui (startMainWindow) where
+
+
+import Control.Applicative
+  (
+    (<$>)
+  , (<*>)
+  )
+import Control.Concurrent
+  (
+    forkIO
+  )
+import Control.Concurrent.STM
+  (
+    TVar
+  , newTVarIO
+  , readTVarIO
+  )
+import Control.Exception
+  (
+    try
+  , Exception
+  , SomeException
+  )
+import Control.Monad
+  (
+    when
+  , void
+  )
+import Control.Monad.IO.Class
+  (
+    liftIO
+  )
+import Data.DirTree
+import Data.DirTree.Zipper
+import Data.Foldable
+  (
+    for_
+  )
+import Data.List
+  (
+    sort
+  , isPrefixOf
+  )
+import Data.Maybe
+  (
+    fromJust
+  , catMaybes
+  )
+import Graphics.UI.Gtk
+import Graphics.UI.Gtk.Abstract.Box
+import Graphics.UI.Gtk.Builder
+import Graphics.UI.Gtk.ModelView
+import GUI.Gtk.Icons
+import IO.Error
+import IO.File
+import IO.Utils
+import System.Directory
+  (
+    executable
+  , doesFileExist
+  , doesDirectoryExist
+  )
+import System.Environment
+  (
+    getArgs
+  )
+import System.FilePath.Posix
+  (
+    isAbsolute
+  )
+import System.Glib.UTFString
+  (
+    glibToString
+  )
+import System.IO.Unsafe
+  (
+    unsafePerformIO
+  )
+import System.Process
+  (
+    spawnProcess
+  )
+
+
+-- TODO: simplify where we modify the TVars
+-- TODO: double check garbage collection/gtk ref counting
+-- TODO: file watching, when and what to reread
+
+
+-- |Monolithic object passed to various GUI functions in order
+-- to keep the API stable and not alter the parameters too much.
+-- This only holds GUI widgets that are needed to be read during
+-- runtime.
+data MyGUI = MkMyGUI {
+  -- |main Window
+    rootWin  :: Window
+  , menubarFileQuit :: ImageMenuItem
+  , menubarFileOpen :: ImageMenuItem
+  , menubarFileCut :: ImageMenuItem
+  , menubarFileCopy :: ImageMenuItem
+  , menubarFilePaste :: ImageMenuItem
+  , menubarFileDelete :: ImageMenuItem
+  , menubarHelpAbout :: ImageMenuItem
+  , urlBar :: Entry
+  -- |tree view
+  , treeView :: TreeView
+  -- |first column
+  , cF :: TreeViewColumn
+  -- |second column
+  , cMD :: TreeViewColumn
+  -- |renderer used for the treeView
+  , renderTxt :: CellRendererText
+  , renderPix :: CellRendererPixbuf
+  , settings :: TVar FMSettings
+  , folderPix :: Pixbuf
+  , filePix :: Pixbuf
+  , errorPix :: Pixbuf
+}
+
+
+-- |FM-wide settings.
+data FMSettings = MkFMSettings {
+    showHidden :: Bool
+  , isLazy :: Bool
+}
+
+
+-- |This describes the contents of the treeView and is separated from MyGUI,
+-- because we might want to have multiple views.
+data MyView = MkMyView {
+  -- |raw model with unsorted data
+    rawModel :: TVar (ListStore (DTZipper DirTreeInfo DirTreeInfo))
+  -- |sorted proxy model
+  , sortedModel :: TVar (TypedTreeModelSort
+                          (DTZipper DirTreeInfo DirTreeInfo))
+  -- |filtered proxy model
+  , filteredModel :: TVar (TypedTreeModelFilter
+                            (DTZipper DirTreeInfo DirTreeInfo))
+  , fsState :: TVar (DTZipper DirTreeInfo DirTreeInfo)
+}
+
+
+-- |Set hotkeys.
+setBindings :: MyGUI -> MyView -> IO ()
+setBindings mygui myview = do
+  _ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
+    [Control] <- eventModifier
+    "q"       <- fmap glibToString eventKeyName
+    liftIO mainQuit
+  _ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
+    [Control] <- eventModifier
+    "h"       <- fmap glibToString eventKeyName
+    liftIO $ modifyTVarIO (settings mygui)
+                          (\x -> x { showHidden = not . showHidden $ x})
+             >> updateTreeView mygui myview
+  _ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
+    [Alt] <- eventModifier
+    "Up"  <- fmap glibToString eventKeyName
+    liftIO $ upDir mygui myview
+  _ <- treeView mygui `on` rowActivated $ openRow mygui myview
+  _ <- menubarFileQuit mygui `on` menuItemActivated $ mainQuit
+  _ <- urlBar mygui `on` entryActivated $ urlGoTo mygui myview
+  return ()
+
+
+-- |Go the the url given at the `urlBar` and visualize it in the given
+-- treeView.
+--
+-- This might update the TVar `rawModel`.
+urlGoTo :: MyGUI -> MyView -> IO ()
+urlGoTo mygui myview = do
+  fp <- entryGetText (urlBar mygui)
+  let abs = isAbsolute fp
+  exists <- (||) <$> doesDirectoryExist fp <*> doesFileExist fp
+  -- TODO: more explicit error handling?
+  when (abs && exists) $ do
+    newFsState  <- readPath' fp
+    newRawModel <- fileListStore newFsState myview
+    writeTVarIO (rawModel myview) newRawModel
+    updateTreeView mygui myview
+
+
+-- |Enter a subdirectory and visualize it in the treeView or
+-- open a file.
+--
+-- This might update the TVar `rawModel`.
+openRow :: MyGUI -> MyView -> TreePath -> TreeViewColumn -> IO ()
+openRow mygui myview tp tvc = do
+  rawModel'      <- readTVarIO $ rawModel myview
+  sortedModel'   <- readTVarIO $ sortedModel myview
+  filteredModel' <- readTVarIO $ filteredModel myview
+  miter          <- treeModelGetIter sortedModel' tp
+  for_ miter $ \iter -> do
+    cIter' <- treeModelSortConvertIterToChildIter sortedModel' iter
+    cIter  <- treeModelFilterConvertIterToChildIter filteredModel' cIter'
+    row    <- treeModelGetRow rawModel' cIter
+    case row of
+      (Dir _ _ _, _) -> do
+        newRawModel <- fileListStore row myview
+        rm <- readTVarIO (rawModel myview)
+        writeTVarIO (rawModel myview) newRawModel
+        updateTreeView mygui myview
+      dz@(File _ _, _) ->
+        withErrorDialog $ openFile (getFullPath dz)
+      _ -> return ()
+
+
+-- |Go up one directory and visualize it in the treeView.
+--
+-- This will update the TVar `rawModel`.
+upDir :: MyGUI -> MyView -> IO ()
+upDir mygui myview = do
+  rawModel'    <- readTVarIO $ rawModel myview
+  sortedModel' <- readTVarIO $ sortedModel myview
+  fS           <- readTVarIO $ fsState myview
+  newRawModel  <- fileListStore (goUp fS) myview
+  writeTVarIO (rawModel myview) newRawModel
+  updateTreeView mygui myview
+
+
+-- |Create the `ListStore` of files/directories from the current directory.
+-- This is the function which maps the Data.DirTree data structures
+-- into the GTK+ data structures.
+--
+-- This also updates the TVar `fsState` inside the given view.
+fileListStore :: DTZipper DirTreeInfo DirTreeInfo  -- ^ current dir
+              -> MyView
+              -> IO (ListStore (DTZipper DirTreeInfo DirTreeInfo))
+fileListStore dtz myview = do
+  writeTVarIO (fsState myview) dtz
+  listStoreNew (goAllDown dtz)
+
+
+-- TODO: make this function more slim so only the most necessary parts are
+-- called
+-- |Updates the visible TreeView with the current underlying mutable models,
+-- which are retrieved from `MyGUI`.
+--
+-- This also updates the TVars `filteredModel` and `sortedModel` in the process.
+updateTreeView :: MyGUI
+               -> MyView
+               -> IO ()
+updateTreeView mygui myview = do
+  let treeView' = treeView mygui
+      cF' = cF mygui
+      cMD' = cMD mygui
+      render' = renderTxt mygui
+
+  -- update urlBar, this will break laziness slightly, probably
+  fsState <- readTVarIO $ fsState myview
+  let urlpath = getFullPath fsState
+  entrySetText (urlBar mygui) urlpath
+
+  rawModel' <- readTVarIO $ rawModel myview
+
+  -- filtering
+  filteredModel' <- treeModelFilterNew rawModel' []
+  writeTVarIO (filteredModel myview) filteredModel'
+  treeModelFilterSetVisibleFunc filteredModel' $ \iter -> do
+     hidden <- showHidden <$> readTVarIO (settings mygui)
+     row    <- treeModelGetRow rawModel' iter
+     if hidden
+       then return True
+       else return $ not ("." `isPrefixOf` (name . unZip $ row))
+
+  -- sorting
+  sortedModel' <- treeModelSortNewWithModel filteredModel'
+  writeTVarIO (sortedModel myview) sortedModel'
+  treeSortableSetSortFunc sortedModel' 1 $ \iter1 iter2 -> do
+      cIter1 <- treeModelFilterConvertIterToChildIter filteredModel' iter1
+      cIter2 <- treeModelFilterConvertIterToChildIter filteredModel' iter2
+      row1   <- treeModelGetRow rawModel' cIter1
+      row2   <- treeModelGetRow rawModel' cIter2
+      return $ compare (unZip row1) (unZip row2)
+  treeSortableSetSortColumnId sortedModel' 1 SortAscending
+
+  -- set values
+  treeModelSetColumn rawModel' (makeColumnIdPixbuf 0)
+                               (dirtreePix . unZip)
+  treeModelSetColumn rawModel' (makeColumnIdString 1)
+                               (name . unZip)
+  treeModelSetColumn rawModel' (makeColumnIdString 2)
+                               (packModTime . unZip)
+  treeModelSetColumn rawModel' (makeColumnIdString 3)
+                               (packPermissions . unZip)
+
+  -- update treeview model
+  treeViewSetModel treeView' sortedModel'
+
+  return ()
+  where
+    dirtreePix (Dir {})    = folderPix mygui
+    dirtreePix (File {})   = filePix mygui
+    dirtreePix (Failed {}) = errorPix mygui
+
+
+-- |Pops up an error Dialog with the given String.
+showErrorDialog :: String -> IO ()
+showErrorDialog str = do
+  errorDialog <- messageDialogNew Nothing
+                                  [DialogDestroyWithParent]
+                                  MessageError
+                                  ButtonsClose
+                                  str
+  _ <- dialogRun errorDialog
+  widgetDestroy errorDialog
+
+
+-- |Execute the given IO action. If the action throws exceptions,
+-- visualize them via `showErrorDialog`.
+withErrorDialog :: IO a -> IO ()
+withErrorDialog io = do
+  r <- try io
+  either (\e -> showErrorDialog $ show (e :: SomeException))
+         (\_ -> return ())
+         r
+
+
+-- |Set up the GUI.
+startMainWindow :: IO ()
+startMainWindow = do
+
+  settings <- newTVarIO (MkFMSettings False True)
+
+  -- get the icons
+  iT        <- iconThemeGetDefault
+  folderPix <- getIcon IFolder 24
+  filePix   <- getIcon IFile 24
+  errorPix  <- getIcon IError 24
+
+  fsState <- readPath "/" >>= (newTVarIO . baseZipper . dirTree)
+
+  builder <- builderNew
+  builderAddFromFile builder "data/Gtk/builder.xml"
+
+  -- get the pre-defined gui widgets
+  rootWin           <- builderGetObject builder castToWindow
+                       "rootWin"
+  scroll            <- builderGetObject builder castToScrolledWindow
+                       "mainScroll"
+  menubarFileQuit   <- builderGetObject builder castToImageMenuItem
+                       "menubarFileQuit"
+  menubarFileOpen   <- builderGetObject builder castToImageMenuItem
+                       "menubarFileOpen"
+  menubarFileCut    <- builderGetObject builder castToImageMenuItem
+                       "menubarFileCut"
+  menubarFileCopy   <- builderGetObject builder castToImageMenuItem
+                       "menubarFileCopy"
+  menubarFilePaste  <- builderGetObject builder castToImageMenuItem
+                       "menubarFilePaste"
+  menubarFileDelete <- builderGetObject builder castToImageMenuItem
+                      "menubarFileDelete"
+  menubarHelpAbout  <- builderGetObject builder castToImageMenuItem
+                      "menubarHelpAbout"
+  urlBar <- builderGetObject builder castToEntry "urlBar"
+
+  -- create initial list store model with unsorted data
+  rawModel <- newTVarIO =<< listStoreNew . goAllDown =<< readTVarIO fsState
+
+  filteredModel <- newTVarIO =<< (\x -> treeModelFilterNew x [])
+                           =<< readTVarIO rawModel
+
+  -- create an initial sorting proxy model
+  sortedModel <- newTVarIO =<< treeModelSortNewWithModel
+                           =<< readTVarIO filteredModel
+
+  -- create the final view
+  treeView <- treeViewNew
+
+  -- create final tree model columns
+  renderTxt <- cellRendererTextNew
+  renderPix <- cellRendererPixbufNew
+  let ct = cellText   :: (CellRendererTextClass cr) => Attr cr String
+      cp = cellPixbuf :: (CellRendererPixbufClass self) => Attr self Pixbuf
+
+  -- filename column
+  cF <- treeViewColumnNew
+  treeViewColumnSetTitle        cF "Filename"
+  treeViewColumnSetResizable    cF True
+  treeViewColumnSetClickable    cF True
+  treeViewColumnSetSortColumnId cF 1
+  cellLayoutPackStart cF renderPix False
+  cellLayoutPackStart cF renderTxt True
+  _ <- treeViewAppendColumn treeView cF
+  cellLayoutAddColumnAttribute cF renderPix cp $ makeColumnIdPixbuf 0
+  cellLayoutAddColumnAttribute cF renderTxt ct $ makeColumnIdString 1
+
+  -- date column
+  cMD <- treeViewColumnNew
+  treeViewColumnSetTitle        cMD "Date"
+  treeViewColumnSetResizable    cMD True
+  treeViewColumnSetClickable    cMD True
+  treeViewColumnSetSortColumnId cMD 2
+  cellLayoutPackStart cMD renderTxt True
+  _ <- treeViewAppendColumn treeView cMD
+  cellLayoutAddColumnAttribute cMD renderTxt ct $ makeColumnIdString 2
+
+  -- permissions column
+  cP <- treeViewColumnNew
+  treeViewColumnSetTitle        cP "Permission"
+  treeViewColumnSetResizable    cP True
+  treeViewColumnSetClickable    cP True
+  treeViewColumnSetSortColumnId cP 3
+  cellLayoutPackStart cP renderTxt True
+  _ <- treeViewAppendColumn treeView cP
+  cellLayoutAddColumnAttribute cP renderTxt ct $ makeColumnIdString 3
+
+  -- construct the gui object
+  let mygui  = MkMyGUI {..}
+  let myview = MkMyView {..}
+
+  -- create the tree model with its contents
+  updateTreeView mygui myview
+
+  -- set the bindings
+  setBindings mygui myview
+
+  -- add the treeview to the scroll container
+  containerAdd scroll treeView
+
+  widgetShowAll rootWin

src/GUI/Gtk/Icons.hs

@@ -0,0 +1,31 @@
+{-# OPTIONS_HADDOCK ignore-exports #-}
+
+module GUI.Gtk.Icons where
+
+
+import Graphics.UI.Gtk
+import Graphics.UI.Gtk.Gdk.Pixbuf
+
+
+-- |Icon type we use in our GUI.
+data GtkIcon = IFolder
+             | IFile
+             | IError
+
+
+-- |Gets an icon from the default icon theme and falls back to project-icons
+-- if not found. The requested icon size is not guaranteed.
+getIcon :: GtkIcon    -- ^ icon we want
+        -> Int        -- ^ requested icon size
+        -> IO Pixbuf
+getIcon icon isize = do
+  let iname = iconToStr icon
+  iT <- iconThemeGetDefault
+  mpix <- iconThemeLoadIcon iT iname isize IconLookupUseBuiltin
+  case mpix of
+    Just pix -> return pix
+    Nothing  -> pixbufNewFromFile ("data/Gtk/icons/" ++ iname)
+  where
+    iconToStr IFolder = "gtk-directory"
+    iconToStr IFile   = "gtk-file"
+    iconToStr IError  = "error"

src/IO/Error.hs

@@ -0,0 +1,23 @@
+{-# OPTIONS_HADDOCK ignore-exports #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module IO.Error where
+
+
+import Control.Exception
+import Control.Monad
+  (
+    mzero
+  , MonadPlus
+  )
+import Data.Typeable
+
+
+data FmIOException = FileDoesNotExist String
+                   | PathNotAbsolute String
+                   | FileNotExecutable String
+  deriving (Show, Typeable)
+
+
+instance Exception FmIOException
+

src/IO/File.hs

@@ -0,0 +1,68 @@
+{-# OPTIONS_HADDOCK ignore-exports #-}
+
+module IO.File (
+    openFile
+  , executeFile
+  ) where
+
+
+import Control.Exception
+  (
+    throw
+  )
+import Control.Monad
+  (
+    unless
+  , void
+  )
+import IO.Error
+import System.Directory
+  (
+    doesFileExist
+  , getPermissions
+  , executable
+  )
+import System.FilePath.Posix
+  (
+    isAbsolute
+  )
+import System.Process
+  (
+    spawnProcess
+  , ProcessHandle
+  )
+
+
+-- |Opens a file appropriately by invoking xdg-open.
+--
+-- This will throw an exception if the filepath is not absolute
+-- or the file does not exist.
+openFile :: FilePath          -- ^ absolute path to file
+         -> IO ProcessHandle
+openFile fp = do
+  fileSanityThrow fp
+  spawnProcess "xdg-open" [fp]
+
+
+-- |Executes a program with the given arguments.
+--
+-- This will throw an exception if the filepath is not absolute
+-- or the file does not exist. It will also throw an exception
+-- if the file is not executable.
+executeFile :: FilePath          -- ^ absolute path to program
+            -> [String]          -- ^ arguments
+            -> IO ProcessHandle
+executeFile fp args = do
+  fileSanityThrow fp
+  p <- getPermissions fp
+  unless (executable p) (throw $ FileNotExecutable fp)
+  spawnProcess fp args
+
+
+-- Throws an exception if the filepath is not absolute
+-- or the file does not exist.
+fileSanityThrow :: FilePath -> IO ()
+fileSanityThrow fp = do
+  unless (isAbsolute fp) (throw $ PathNotAbsolute fp)
+  exists <- doesFileExist fp
+  unless exists (throw $ FileDoesNotExist fp)

src/IO/Utils.hs

@@ -0,0 +1,23 @@
+{-# OPTIONS_HADDOCK ignore-exports #-}
+
+module IO.Utils where
+
+
+import Control.Concurrent.STM
+  (
+    atomically
+  )
+import Control.Concurrent.STM.TVar
+  (
+    writeTVar
+  , modifyTVar
+  , TVar
+  )
+
+
+writeTVarIO :: TVar a -> a -> IO ()
+writeTVarIO tvar val = atomically $ writeTVar tvar val
+
+
+modifyTVarIO :: TVar a -> (a -> a) -> IO ()
+modifyTVarIO tvar f = atomically $ modifyTVar tvar f