#! /bin/sh
# -*- scheme -*-
exec guile-gtk -e main $* -s $0
!#
;;;
;;; gtk-du: a directory cleanup utility
;;;
;;;
;;; Copyright (C) 1998 David Lutterkort <lutter@cs.purdue.edu>
;;; 
;;; 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, 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 software; see the file COPYING.  If not, write to
;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139,
;;; USA.


;;; Purpose: gtk-du displays a list of directories and their sizes in a
;;;          nice GUI. The user can traverse the tree and remove
;;;          unwanted directories. Since the wohole directory structure
;;;          is cached, using gtk-du is faster than using
;;;          du + rm. 

(use-modules (ice-9 common-list) (gtk gtk))
(load-from-path "scsh/init")
(load-from-path "gtk-utils")

(define gtk-du-version "gtk-du v0.5.5")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Macro to define a method-dispatch for objects
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax define-self
  (syntax-rules 
   ()
   ((_ self-name (msg1 method1) ...)
    (define (self-name . msg)
      (if (null? msg) 
	  (throw 'wrong-number-args)
	  (case (car msg)
	    ((msg1) method1)
	    ...
	    (else (throw 'message-not-understood))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Caching and manipulating a directory tree
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Data structure for the directory cache is a tree:
;;; TREE := (NAME SIZE) | (NAME SIZE TREE+)
;;;         for leaves          for interior nodes
(define (make-tree name size subtree)
  (if (null? subtree)
      (list name size)
      (list name size subtree)))

(define tree? pair?)			; ANY -> BOOL cheap and cheesy test

(define (tree-rec? node)		; ANY -> BOOL
  ; That's what one would really like to call on a tree:
  ; it recurses through the whole tree
  (and (pair? node)			
       (string? (car node))
       (pair? (cdr node))
       (number? (cadr node))
       (every? tree-rec? (get-subdirs node))))

(define get-name car)			; TREE -> string
(define set-name! set-car!)
(define get-size cadr)			; TREE -> integer
(define (set-size! tree newsize) (set-car! (cdr tree) newsize))

(define (get-subdirs tree)		; TREE -> (list TREE ...)
  (if (null? (cddr tree)) '() (caddr tree)))
(define (set-subdirs! tree dirs)
  (if (null? dirs)
      (set-cdr! (cdr tree) '())
      (set-cdr! (cdr tree) (list dirs))))
(define (add-subdir! tree subdir)
  (set-subdirs! tree (cons subdir (get-subdirs tree)))
  (set-size! tree (+ (get-size tree) (get-size subdir))))

(define (subdirs? tree) (not (null? (get-subdirs tree))))

(define (get-subdir node sname)		; TREE x string -> TREE
  ;; Find the subdir in NODE with name sname
  (let loop ((dirs (get-subdirs node)))
    (if (null? dirs)
	#f
	(if (string=? (get-name (car dirs)) sname)
	    (car dirs)
	    (loop (cdr dirs))))))

(define (get-subdir-pos node subdir)  
  ;; Find pos such that (eq? (list-ref (get-subdirs node) pos) subdir)
  (let* ((dirs (get-subdirs node))
	 (elt (memq subdir dirs))
	 (l (length dirs)))
    (if elt (- l (length elt)) #f)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Building the tree
;;
(define (directory-tree root update-proc count-all? symlink?)
  ; Construct the tree for the directory ROOT.
  ; If COUNT-ALL? is #f, hardlinks are only counted once

  ; There are two things that need to be done:
  ; (1) Record the size of all the entries in ROOT
  ; (2) Recurse into all subdirectories, build the
  ;     trees for those and add their sizes to the size of ROOT

  ;; Todo:
  ;; (1) Account for hardlinks -- they are counted every time they're seen
  ;;     now. Add a flag to indicate if hardlinks should be counted every time
  ;;     or only the first time DONE
  ;; (2) Symlinks are blithely ignored. Add a flag to indicate whether 
  ;;     to follow them (a) never (b) if owner of the target of the symlink
  ;;     (c) ask for each symlink (d) if on same filesys
  ;;     (e) always (very dangerous) PARTLY DONE

  ; symlink? is either #f (follow never), or a list containing some
  ; of the following symbols:
  ; owner - follow symlink if owner of target (uid)
  ; device - follow symlink if target on same device
  ; ask - ...
  ; In any event, follow the symlink only if the target is not
  ; in the inode-hash-table yet.
  
  ;; Utility functions for identifying hardlinks etc.
  (define inode-hash-table '())
  
  (define (init-hash-table) (set! inode-hash-table (make-vector 70)))

  (define (add-inode dev ino name)
    ;; Check if (dev ino) is alreday in the hash table
    ;; If so, return #f, else add it and return #t
    (if (not (hash-ref inode-hash-table (list dev ino)))
	(begin 
	  (hash-set! inode-hash-table (list dev ino) name)
	  #t)
	#f))

  (define (stat-symlink x s)
    ;; Find out whether we're interested in following the symlink x
    ;; To avoid following cycles, add the dev/ino to the inode hash-table
    ;; if we decide to follow the link. This is a compromise between
    ;; carefully counting everything only once and keeping the hash-table at
    ;; a reasonable size...
    (if symlink? 
	(let ((s2 (stat x)))
	  (if 
	   (and
	    (or
	     (and (member 'owner symlink?) (= (getuid) (stat:uid s2)))
	     (and (member 'device symlink?) (= (stat:dev s) (stat:dev s2))))
	    ; Important: don't consider count-all?. This can lead to 
	    ; endlessly following cycles...
	    (add-inode (stat:dev s2) (stat:ino s2) #t))
	   s2 #f))
	#f))

  (define (stat-file x)
    ; Decide whether the file with name x is to be considered.
    ; If so, return the stat for it, otherwise #f

    ; Only consider files that fulfill all of
    ; (1) the name is not "." or "..",
    ; (2) they are readable 
    ; (3) are not symlinks
    ; (4) not hardlinked to an already counted file
      
    (if (and (not (or (string=? x ".") (string=? x ".."))) (access? x R_OK))
	(let* ((s (lstat x))
	       (t (stat:type s)))
	  (if (and 
	       (or (eq? t 'directory) (eq? t 'regular)) ; only normal files
	       (or count-all? (= (stat:nlink s) 1)
		   (add-inode (stat:ino s) (stat:dev s) x)))
	      s
	      (if (eq? (stat:type s) 'symlink) (stat-symlink x s) #f)))
	#f))
       

  (define (fsize s) (* 512 (stat:blocks s)))
  
  (define (scan-dir-flat)
    ;; Read through current directory and return a list:
    ;; car is size of all files in current directory w/o recursion
    ;; cdr is all names of all the subdirectories
    (let ((dir (opendir ".")))
      (let loop ((file (readdir dir)) (size 0) (subdirs '()))
	(if (eof-object? file)
	    (begin 
	      (closedir dir)
	      (cons size subdirs))
	    (let ((s (stat-file file)))
	      (cond
	       ((not s) (loop (readdir dir) size subdirs))
	       ((eq? (stat:type s) 'directory)
		(loop (readdir dir) (+ size (fsize s)) (cons file subdirs)))
	       (else			; regular file
		(loop (readdir dir) (+ size (fsize s)) subdirs))))))))
		  
      
  (define (dir-tree root update-proc)
    (with-cwd 
     root
     (let* ((flat-dir (scan-dir-flat))
	    (tree (make-tree root (car flat-dir) '())))
       (let loop ((subdirs (cdr flat-dir)))
	 (if (null? subdirs) 
	     tree
	  (begin
	   (if update-proc (update-proc tree))
	   (add-subdir! tree (dir-tree (car subdirs) #f))
	   (loop (cdr subdirs))))))))

  (init-hash-table)
  (dir-tree root update-proc))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Removing a directory and all its subdirectories. This is the
;; same as doing rm -rf root in the shell.  BE CAREFUL !!
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (recursive-remove root)
  (define (subdirectory? f)
    (and (not (string=? f ".")) (not (string=? f ".."))
	 (eq? (stat:type (lstat f)) 'directory)))

  (define (remove-dir-flat)
    (let ((dir (opendir ".")))
      (let loop ((file (readdir dir)) (subdirs '()))
	(cond
	 ((eof-object? file) subdirs)
	 ((or (string=? file ".") (string=? file ".."))
	  (loop (readdir dir) subdirs))
	 ((eq? (stat:type (lstat file)) 'directory)
	  (loop (readdir dir) (cons file subdirs)))
	 (else
	  (delete-file file)
	  (loop (readdir dir) subdirs))))))

  (with-cwd
   root
   (for-each recursive-remove (remove-dir-flat)))
  (rmdir root))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Print a size in human-readable form. Taken directly from GNU's du
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  
(define (format-size-compact n-bytes)
  ;   Convert N-BYTES to a more readable string than %d would.
  ;   Most people visually process strings of 3-4 digits effectively,
  ;   but longer strings of digits are more prone to misinterpretation.
  ;   Hence, converting to an abbreviated form usually improves readability.
  ;   Use a suffix indicating multiples of 1024 (K), 1024*1024 (M), and
  ;   1024*1024*1024 (G).  For example, 8500 would be converted to 8.3K,
  ;   133456345 to 127M, 56990456345 to 53G, and so on.  Numbers smaller
  ;   than 1024 aren't modified.
  (let ((giga (* 1024 1024 1024))
	(mega (* 1024 1024))
	(kilo 1024)
	(form
	 (lambda (amt suffix)
	   (cond
	    ((>= amt 10) (format "~d~a" (inexact->exact amt) suffix))
	    ((= amt 0) "0")
	    (else (format "~,1f~a" amt suffix))))))
    (cond
     ((>= n-bytes giga) (form (/ n-bytes giga) "G"))
     ((>= n-bytes mega) (form (/ n-bytes mega) "M"))
     ((>= n-bytes kilo) (form (/ n-bytes kilo) "K"))
     (else (form n-bytes "")))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; A stack for directory traversal
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (make-dirstack tree)
  ;; TREE is a tree as returned by directory-tree
  ;; The object returned by MAKE-DIRSTACK understands the following
  ;; messages:
  ;; 'empty?       : is dirstack empty ?
  ;; 'push, 'pop   : push/pop a directory
  ;; 'cwd          : return current directory (w/o path)
  ;; 'cwd-path     : get the complete path to the cwd
  ;; 'replace-cwd  : replace the cwd with a new tree
  ;; 'remove-cwd   : remove the cwd from the tree
  (let ((root tree)
	(dirstack (cons tree '())))

    (define (empty?) (eq? (car dirstack) root))
    (define (cwd) (if (empty?) root (car dirstack)))
    (define (cwd-path)
      (path-list->file-name (map get-name (reverse dirstack))))

    (define (push dir)
      (let ((dir (if (string? dir) (get-subdir (cwd) dir) dir)))
	(if dir
	    (begin
	      (set! dirstack (cons dir dirstack))
	      dir)
	    #f)))

    (define (pop)
      (if (empty?)
	  #f
	  (let ((topdir (car dirstack)))
	    (set! dirstack (cdr dirstack))
	    topdir)))

    (define (replace-cwd tree)
      ;; Replace the current working directory with TREE
      ;; Return #t if the whole tree was replaced and #t
      ;; otherwise
      ;; cwd is TREE after the replace
      (define (adjust-size size-diff)
	;; Adjust the sizes of the parent directories
	(let loop ((dirlist dirstack))
	  (if (null? dirlist)
	      (push tree)
	      (begin
		(set-size! (car dirlist) 
			   (+ (get-size (car dirlist)) size-diff))
		(loop (cdr dirlist))))))

      (let ((olddir (pop)))
	(if (not olddir)
	    ;; Replacing the whole tree
	    (begin
	      (set! root tree)
	      (set! dirstack (cons tree '()))
	      #t)
	    ;; Replacing a subtree
	    ;; Find the subtree in question
	    (let loop ((subdirs (get-subdirs (cwd))))
	      (set-name! tree (file-name-nondirectory (get-name tree)))
	      (cond
	        ; olddir is a subdir of cwd
	       ((null? subdirs) (throw 'impossible-error))
	       ((eq? olddir (car subdirs))
		(set-car! subdirs tree)
		(adjust-size (- (get-size tree) (get-size olddir)))
		#f)
	       (else (loop (cdr subdirs))))))))

    (define (remove-cwd)
      ;; Remove the cwd completely from the tree
      ;; Returns same as replace-cwd
      (if (replace-cwd (make-tree 'removed 0 '()))
	  #t
	  (begin
	    (pop)
	    (set-subdirs! 
	     (cwd)
	     (remove-if
	      (lambda (x) (eq? (get-name x) 'removed))
	      (get-subdirs (cwd))))
	    #f)))
      
      
    (define-self self (cwd cwd) (push push) (pop pop)
      (replace-cwd replace-cwd) (stack dirstack) (cwd-path cwd-path)
      (remove-cwd remove-cwd))
    self))
      
;;; For testing only
;(define (tree-build l)
;  (letrec ((rec-build
;	    (lambda (x)
;	      (let ((n (symbol->string (car x)))
;		    (s (cadr x))
;		    (t (cddr x)))
;		(if (null? t)
;		    (make-tree n s t)
;		    (make-tree n s (map rec-build (car t))))))))
;    (rec-build l)))
;(define t (tree-build '(root 1 ((a1 2) (a2 3 ((a21 4) (a22 5)))
;				       (a3 6 ((a31 7 ((a311 8)))))))))
;(define ds (make-dirstack t))
;((ds 'push) "a1")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Data structure for a sequence of generic items
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (make-sequence . entries)
  ;; Create a new sequence containing the ENTRIES
  ;; Messages understood:
  ;; 'append, 'prepend : Append/prepend an item to the sequence
  ;; 'iterate          : Create an iterator for the sequence
  (let ((seq '())
	(iter #f))
    (define (app item) (set! seq (append seq (list item))))
    (define (pre item) (set! seq (cons item seq)))
    (define (iterate)
      (let ((iter (if (not (null? seq)) seq #f)))
	(lambda ()
	  (if (and iter (not (null? iter)))
	      (let ((res (car iter)))
		(set! iter (cdr iter))
		res)
	      (begin (set! iter #f) #f)))))
    (define (get) seq)
    (define-self self (append app) (prepend pre)
      (iterate iterate) (next next) (get get))
    (for-each app entries)
    self))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Make the GUI and all its callbacks
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    
(define (make-gui)
  (let ((window (gtk-window-new 'toplevel))
	(box (gtk-vbox-new #f 0))
	(scrolled-win (gtk-scrolled-window-new))
	(listbox (gtk-list-new))
	(list-seq (make-sequence))
	(dir-label (gtk-label-new "Directory:"))
	(dir-entry (gtk-entry-new))
	(hbox (gtk-hbox-new #f 0))
	(total-box (gtk-hbox-new #f 0))
	(total-lab (gtk-label-new "Total: "))
	(total-size (gtk-label-new "0K"))
	(message-label (gtk-label-new ""))
	;; The button row at the bottom
	;; 'Up' 'Rescan' 'Quit'
	(up-button (gtk-button-new-with-label "Up"))
	(rescan-button (gtk-button-new-with-label "Rescan"))
	(quit-button (gtk-button-new-with-label "Quit"))
	(button-box (gtk-hbox-new #t 0))
	; last-item either contains the selection in the listbox
	; (a gtk-list-item) if there is one or #f
	(last-item #f)
	;;; The directory tree
	(dirstack #f)
	(dirstack-cwd #f))
    
	
    ;;; Managing state variables reflecting user settings
    (define state-count-all #f)		; Record hardlinks only once
    (define state-symlinks #f)		; What to do with symbolic links

    ;; Options for formatting the sizes of entries
    (define state-format-size 'nothing-yet)
    (define (view-format-compact size total)
      (format-size-compact size))
    (define (view-format-relative size total)
      (format "~d%" (inexact->exact (* 100 (/ size total)))))
    (define (view-format-blocks size total)
      (format "~d" (inexact->exact (ceiling (/ size 512)))))

    ;; Sorting subdirectories by different criteria
    (define (sort-by-name-pred x y) (string-ci<? (get-name x) (get-name y)))
    (define (sort-by-size-pred x y) (> (get-size x) (get-size y)))
    (define state-sort-pred sort-by-name-pred)
    (define (view-sort tree)
      (set-subdirs! tree (sort! (get-subdirs tree) state-sort-pred))
      tree)
       
    (define (set-last-item! item)
      ;; Track the last-item selected in the listbox
      ;; if item is #f, there is no selection
      ;; otherwise, item is the number of the subdirectory in the 
      ;; current dir
      (let ((litem last-item))
	(set! last-item item)
	(if (and (not item) litem)
	    (gtk-list-unselect-item listbox litem))))

    (define (message str) 
      (gtk-label-set message-label str)
      (gtk-update))
   
    (define (clear-lines lines)
      (let loop ((labels (lines)))
	  (cond
	   (labels
	    (gtk-list-item-deselect (car labels))
	    (gtk-widget-hide (car labels)) 
	    (loop (lines))))))

    (define (display-tree tree path)
      (let ((total (get-size tree))
	    (lines ((list-seq 'iterate))))

	(define (make-line node)
	  ;; Make one line for the filename-size listbox

	  (define (add-labels name size)
	    ;; Get existing labels from list-seq or append new ones
	    ;; and fill them with the strings name and size
	    ;; Returns #f if a new line was created.
	    (let ((labels (lines)))
	      (if labels
		  (begin
		    (gtk-label-set (cadr labels) name)
		    (gtk-label-set (caddr labels) size)
		    (if (not last-item)
			(gtk-list-item-deselect (car labels)))
		    (gtk-widget-show (car labels)))
		  (let ((namelab (gtk-label-new name))
			(sizelab (gtk-label-new size))
			(box (gtk-hbox-new #f 2))
			(item (gtk-list-item-new)))
		    ;; construct all the gore around the labels
		    (gtk-box-pack-start box namelab #f #f 0)
		    (gtk-box-pack-end box sizelab #t #t 0)
		    (gtk-misc-set-alignment sizelab 1.0 0.0)
		    (gtk-container-add item box)
		    (gtku-widget-show* namelab sizelab box item)
		    (gtk-list-append-item listbox item)
		    ((list-seq 'append) (list item namelab sizelab))))
	      labels))
	  (add-labels
	   (if (subdirs? node)
	       (string-append (get-name node) "...")
	       (get-name node))
	   (state-format-size (get-size node) total)))
	
	;; Insert a line for every file into the listbox.
	(for-each make-line (get-subdirs (view-sort tree)))
	;; Clear out additional lines
	(clear-lines lines)

	(gtk-entry-set-text dir-entry path)
	(gtk-label-set total-size 
		       (format-size-compact total))))

    (define (redisplay erase-message?)
      (if dirstack
	  (display-tree (dirstack-cwd) ((dirstack 'cwd-path))))
      (if erase-message?
	  (message "")))
    
    (define (dir-tree root)
      (define (update tree)
	(display-tree tree root)
	(gtk-update))
      
      (message (format "Scanning ~a..." root))
      (directory-tree root update state-count-all state-symlinks))

    (define (set-dir sname)
      ;; Find the subdirectory in the current directory with name text
      (let* ((node 
	      (if (string? sname) (get-subdir (dirstack-cwd) sname) sname))
	     (node-pos (get-subdir-pos (dirstack-cwd) node)))
	(cond
	 ((not node) (message "No such subdirectory."))
	 ((null? (get-subdirs node))
	  (set-last-item! node-pos)
	  (message "No subdirectories."))
	 (else 
	  ((dirstack 'push) node)
	  (set-last-item! #f)
	  (gtk-entry-set-text dir-entry (get-name node))
	  (redisplay #t)))))
    
    (define (select-item item)
      (let ((pos  (gtk-list-child-position listbox item))
	    (dirs (get-subdirs (dirstack-cwd))))
	(if (< pos (length dirs))
	    (set-dir (list-ref (get-subdirs (dirstack-cwd)) pos)))))
    
    (define (unselect-item item)
      (if last-item
	  (set-last-item! #f)))
    
    (define (activate-entry)
      ;; If there is no directory tree loaded, construct one.
      ;; Otherwise just take the last part of whatever is in the entry field
      ;; and try to change to that subdirectory
      (if dirstack
	  (set-dir (file-name-nondirectory (gtk-entry-get-text dir-entry)))
	  (let ((root (directory-as-file-name (gtk-entry-get-text dir-entry))))
	    (cond
	     ((and (file-exists? root) (file-directory? root))
	      (set! dirstack (make-dirstack (dir-tree root)))
	      (set! dirstack-cwd (dirstack 'cwd))
	      (set-last-item! #f)
	      (gtk-widget-set-sensitive rescan-button #t)
	      (gtk-widget-set-sensitive up-button #t)
	      (redisplay #t))
	     (else 
	      (message "No such directory."))))))

    (define (new-tree)
      (set! dirstack #f)
      (set! dirstack-cwd #f)
      (set-last-item! #f)
      (clear-lines ((list-seq 'iterate)))
      (gtk-widget-set-sensitive rescan-button #f)
      (gtk-widget-set-sensitive up-button #f)
      (message "Enter the name of the new directory.")
      (redisplay #f))

    (define (operate-on-dir func)
      (if last-item 
	  ((dirstack 'push) (list-ref (get-subdirs (dirstack-cwd)) last-item)))
      (func ((dirstack 'cwd-path)))
      (if last-item ((dirstack 'pop)))
      (redisplay #f))
      
    (define (rescan-dir)
      (operate-on-dir
       (lambda (path)
	 ((dirstack 'replace-cwd) (dir-tree path))
	 (message (string-append 
		   "Rescanning " (file-name-nondirectory path) " done.")))))

    (define (remove-dir)
      (operate-on-dir
       (lambda (path)
	 (if (gtku-yes-or-no?
	      (format "Are you sure you want to delete\nall files in\n~s\n?"
		      path)
	      "Remove" "Cancel")
	     (begin
	       (recursive-remove path)
	       ;; If the directory removed is the top directory,
	       ;; funky things will happen
	       ((dirstack 'remove-cwd))
	       (set-last-item! #f)
	       (message (string-append 
			 "Removing " (file-name-nondirectory path) " done.")))
	     (message "Chicken.")))))

    (define (goto-parent)
      (set-last-item! #f)
      (if (not ((dirstack 'pop)))
	  (message "At top.")
	  (redisplay #t)))

    (define (quit-thunk) (gtk-widget-destroy window))
    (define (count-all-thunk)
      (set! state-count-all (not state-count-all))
      (if state-count-all
	  (message "Double counting hardlinks")
	  (message "Counting hardlinks only once")))

    ;; Connect the 'active' ingredients to signals
    (gtk-signal-connect quit-button "clicked" quit-thunk)
    (gtk-signal-connect rescan-button "clicked" rescan-dir)
    (gtk-signal-connect up-button "clicked" goto-parent)
    (gtk-signal-connect listbox "select_child" select-item)
    (gtk-signal-connect listbox "unselect_child" unselect-item)

    (gtk-signal-connect dir-entry "activate" activate-entry)
    (gtk-signal-connect window "delete_event" (lambda (ev) #t))
    (gtk-signal-connect window "destroy" gtk-main-quit)
    
    ;; Put everything together and make it look pretty
    (gtk-window-set-title window gtk-du-version)
    (gtk-scrolled-window-set-policy scrolled-win 'automatic 'always)
    (gtk-container-add scrolled-win listbox)
    (gtk-misc-set-alignment dir-label 0.0 0.5)
    (gtk-widget-set-usize scrolled-win 400 400)
    (gtk-list-set-selection-mode listbox 'single)

    ;; Buttons: pack and connect to signals
    (gtk-box-pack-start button-box up-button #t #t 0)
    (gtk-box-pack-start button-box rescan-button #t #t 0)
    (gtk-box-pack-start button-box quit-button #t #t 0)
    (gtku-widget-show* button-box up-button rescan-button quit-button)

    ;; Assemble the 'Total: 42K' box
    (gtk-box-pack-start total-box total-lab #f #f 0)
    (gtk-box-pack-start   total-box total-size #f #f 0)
    (gtku-widget-show* total-box total-lab total-size)

    ;; Assemble the top 'Directory: /xxx/yyy' line
    (gtk-box-pack-start hbox dir-label #f #f 0)
    (gtk-box-pack-start hbox dir-entry #t #t 0)
    (gtk-entry-set-text dir-entry (cwd))
	    
    ;; Pack the widgets from top to bottom.
    (gtk-container-add window box)
    ;(gtk-container-add box hbox)
    (gtk-box-pack-start 
     box 
     (gtku-make-menu-bar 
      `(("File" ("New Tree" . ,new-tree) ("Quit" . ,quit-thunk))
	("Cleanup"
	 ("Remove" . ,remove-dir))
	("View" 
	 ,(gtku-radio-menu 
	   "Size" state-format-size
	   ("Compact" view-format-compact (redisplay #t) *)
	   ("Blocks"  view-format-blocks (redisplay #t))
	   ("Relative" view-format-relative (redisplay #t)))
	 ,(gtku-radio-menu
	   "Sort by" state-sort-pred
	   ("Name" sort-by-name-pred (redisplay #t) *)
	   ("Size" sort-by-size-pred (redisplay #t))))
	("Options" 
	 (check "Count all" . ,count-all-thunk)
	 ,(gtku-radio-menu 
	   "Symlinks" state-symlinks
	   ("Follow never" #f *)
	   ("Same device" '(device))
	   ("Same owner" '(owner))))))
     #f #f 2)
    (gtk-box-pack-start box hbox #f #f 0)
    (gtk-box-pack-start box scrolled-win #t #t 0)
    (gtk-box-pack-start box total-box #f #f 0)
    (gtk-box-pack-start box message-label #f #f 0)
    (gtk-box-pack-start box button-box #f #f 0)

    (gtku-widget-show* dir-label dir-entry hbox listbox box 
		      message-label scrolled-win window)
    (new-tree)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; The main procedure: the entry point
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (main . args) 
  (make-gui)
  (gtk-main))