;;; Guile bindings for Mutt
;;; Copyright (C) 2003  Ludovic Courtès

;;; 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., 675 Mass Ave, Cambridge, MA 02139, USA.  */

;;; mutt.scm

;;; This file contains all the basic feature bindings.  Each feature
;;; defined here may be customized by just `overloading' it.  Some of
;;; them are already different from their built-in equivalent.

(use-modules (ice-9 documentation)
	     (ice-9 optargs))

; The directory where Guile files should go, typically
; /usr/share/mutt/guile .
(define %mutt-guile-directory
  (string-append %mutt-data-directory "/guile"))

; Set a load path (for modules) that is suitable for the user.
(set! %load-path (append %load-path
			 (list (string-append (getenv "HOME") "/.mutt"))
			 (list %mutt-guile-directory)))

(define (reload-defaults)
  "Reload configuration defaults from the system wide mutt.scm file."
  (reset-hook! idle-hook)
  (load (string-append %mutt-sysconfig-directory "/mutt.scm")))


;;; Handy smob accessors (procedures with setter)

(define (symbol-append . syms)
  (string->symbol (apply string-append (map symbol->string syms))))

(define-macro (define-with-setter name)
  `(define ,name (make-procedure-with-setter ,(symbol-append name '-ref)
                                            ,(symbol-append name '-set!))))

; Global settings
(define-with-setter user-headers)
(define-with-setter mailing-lists)
(define-with-setter subscribed-lists)
(define-with-setter aliases)

; Object accessors
(define-with-setter address-personal)
(define-with-setter address-mailbox)
(define-with-setter address-group?)
(define-with-setter message-score)
(define-with-setter message-envelope)
(define-with-setter message-body)
(define-with-setter message-date-sent)
(define-with-setter message-date-received)
(define-with-setter envelope-from)
(define-with-setter envelope-to)
(define-with-setter envelope-subject)
(define-with-setter envelope-user-headers)
(define-with-setter envelope-message-id)
(define-with-setter envelope-references)
(define-with-setter body-next)
(define-with-setter body-parts)
(define-with-setter body-filename)
(define-with-setter body-parameters)
(define-with-setter body-content-type)


;;; Helper functions and macros

(define (address->list address)
  "Convert address object @var{address} into a list of address objects."
  (if (address? address)
      (if address
	  (append (list address)
		  (address->list (address->next address)))
	  '())
      #f))

(define (body-select-bodies proc body)
  "Select bodies for which procedure @var{proc} returns true."
  (if body
      (let ((parts (body-parts body))
	    (next  (body-next  body)))
	(append (if (proc body) (list body) '())
		(if parts (body-select-bodies proc parts) '())
		(if next  (body-select-bodies proc next)  '())))
      '()))

(define (message-select-bodies proc message)
  "Select bodies from @var{message} for which procedure @var{proc} returns true."
  (body-select-bodies proc (message-body message)))

; Safe execution of Scheme code catching any uncaught exception and displaying
; a nice error message instead of calling abort ().
(define-macro (safe-exec exp)
  `(begin
     (ui-debug (format #f "safe-exec: ~S" ',exp))
     (catch
      #t
      (lambda ()
	(let ((ret ,exp))
	  (ui-debug (format #f "safe-exec returned: ~S" ret))
	  ret))
      (lambda (key . args)
	(set-error-message! (error-format key args))
	#f))))

(define (error-format key args)
  "Describe an error, using the format from @var{args}, if available."
  (if (< (length args) 4)
      (format #f "Scheme exception: ~S" key)
      (string-append
       (if (string? (car args))
	   (string-append "In " (car args))
	   "Scheme exception")
       ": "
       (apply format `(#f ,(cadr args) ,@(caddr args))))))

; Debugging facility.
; These variables are exported as Mutt options, see below.
(define debug? #f)
(define debug-time 2)
(define debug-port #f)

(define (ui-debug str)
  "Output message @var{str}, a debugging message."
  (if debug?
      (begin
	(if debug-port
	    (display (string-append str "\n") debug-port)
	    (ui-message str))
	(sleep debug-time))))


; The list of user-defined Mutt commands.  A simple execute-command
; implementation could just try to execute any Scheme function when
; the name of a command is entered.  However, it is cleaner to let
; the user choose which Scheme functions can be executed as Mutt
; commands, hence the `define-command' macro below.
(define mutt-scheme-commands  (make-hash-table 13))
(define mutt-scheme-functions (make-hash-table 13))
(define mutt-scheme-options   (make-hash-table 13))
(define mutt-scheme-modules   (make-hash-table 13))

; XXX: Guile doesn't provide any type predicate for hash tables.
(define (hash? x) #t)

(define (register-scheme-module! name doc)
  "Register module named @var{name}, a symbol list, with documentation
string @var{doc}."
  (hash-set! mutt-scheme-modules
	     (format #f "~a" name)
	     doc)
  (ui-message (format #f "~a loaded." name)))

(define (scheme-module-documentation name)
  "Return the documentation string for module named @var{name}."
  (if (not (string? name))
      (set! name (format #f "~a" name)))
  (hash-ref mutt-scheme-modules name))

(define (register-scheme-item! hash name data)
  "Register Scheme element @var{name}, associated to @var{data}, so that
it can be accessed by Mutt code (internal use)."
  (if (and (string? name) (hash? hash))
      (hash-set! hash name data)
      #f))

(define (register-command! name proc)
  "Adds command named @var{name}, corresponding to procedure @var{proc} "
  "to the list of available user-defined Mutt commands."
  (if (procedure? proc)
      (register-scheme-item! mutt-scheme-commands name proc)
      #f))

(define (register-function! name proc)
  "Adds function named @var{name}, corresponding to procedure @var{proc} "
  "to the list of available user-defined Mutt functions."
  (if (procedure? proc)
      (register-scheme-item! mutt-scheme-commands name proc)
      #f))

(define-macro (register-option! name getter setter doc)
  "Add variable @var{name} to the list of available Mutt options.
The option will be read by calling @var{getter} (if not false) and changed
by calling @var{setter} (if not false). @var{doc} is a string documenting
the option."

  ; Here we need to keep track of which module we are in
  ; procedures so that they can access bindings that are local to
  ; their module.
  `(if (string? ,doc)
       (register-scheme-item! mutt-scheme-options ,name
			      (list (current-module) ,getter ,setter ,doc))
       #f))

; The following aliases make it easier (more readable) to access
; particular elements of an option description such as the ones stored
; in the `mutt-scheme-commands' hash table.
(define option-module        car)
(define option-getter        cadr)
(define option-setter        caddr)
(define option-documentation cadddr)

(define (unregister-scheme-item! hash name)
  "Remove Scheme item @var{name} from @var{hash} (internal use)."
  (if (and (hash? hash) (string? name))
      (hash-remove! hash name)
      #f))

(define (unregister-command! name)
  "Remove command named @var{name} from the list of user-defined commands."
  (if (command? name)
      (unregister-scheme-item! mutt-scheme-commands name)
      #f))

(define (unregister-function! name)
  "Remove function named @var{name} from the list of user-defined functions."
  (if (function? name)
      (unregister-scheme-item! mutt-scheme-functions name)
      #f))

(define (unregister-option! name)
  "Remove option named @var{name} from the list of user-defined options."
  (if (option? name)
      (unregister-scheme-item! mutt-scheme-options name)
      #f))

(define (scheme-command-lookup name)
  "Return false if @var{name} is not a Scheme command name, a procedure
(the command) otherwise."
  (hash-ref mutt-scheme-commands name))

(define (scheme-function-lookup name)
  "Return false if @var{name} is not a Scheme function name, a
procedure (the function) otherwise."
  (hash-ref mutt-scheme-functions name))

(define (scheme-option-lookup name)
  "Return false if @var{name} is not a Scheme option name, a list
describing the option otherwise: @code{(module getter setter doc)}."
  (hash-ref mutt-scheme-options name))

(define-macro (define-command signature . body)
  "Macro that should be used to define a new Mutt command."
  (let* ((symbol     (car signature))
	 (name       (symbol->string symbol))
	 (definition (append `(define ,signature) body)))
    `(begin
       ,definition
       (register-command! ,name (primitive-eval ,symbol)))))

(define-macro (define-aspect signature . body)
  "Define a new aspect of a given Scheme function."
  (let* ((symbol  (car signature))
	 (args    (cdr signature))
	 (lambda-expr (append `(lambda ,args) body)))
    `(let ((next-aspect ,symbol))
       (set! ,symbol
	     ,lambda-expr))))

; Try to execute COMMAND using the built-in mechanism.
; If this fails, look for a Scheme function declared using
; `register-command!' or `define-command' with such a name.
(define (execute-command command argstring)
  "Execute command @var{command} with argument string @var{args}."
  (if (string-null? command)
      #f
      (begin
	(ui-debug (format #f "command: [~a] (~a)" command argstring))
	(if (builtin-execute-command command argstring)
	    #t
	    (let ((scm-cmd (hash-ref mutt-scheme-commands command)))
	      (if scm-cmd
		  (safe-exec (apply scm-cmd (list argstring)))
		  #f)))))) ; Leave the error message as is.


; A few example commands, functions and options...

(define user-afraid? #f)

(define (boolean-option-getter symbol)
  "Get the value (a string) of @var{symbol}, a boolean variable."
  (ui-debug (format #f "boolean-option-getter: ~a" symbol))
  (false-if-exception
   (let ((value (primitive-eval symbol)))
     (if (boolean? value)
	 (if value "yes" "no")
	 (format #f "~a" value)))))

(define (boolean-option-setter symbol valuestr hint)
  "Change the value of @var{symbol}, a boolean variable, to that represented
by @var{valuestr}, a string."
  (ui-debug (format #f "boolean-option-setter: ~a <- ~a" symbol
		    valuestr))
  (cond ((= hint M_SET_UNSET) (set! valuestr "no"))
	((and (= hint 0) (string=? "" valuestr)) (set! valuestr "yes")))
  (false-if-exception
   (let ((value (primitive-eval symbol)))
     (if (boolean? value)
	 (if (cond ((string-ci=? valuestr "yes") (set! value #t))
		   ((string-ci=? valuestr "no")  (set! value #f))
		   (#t  #f))
	     (primitive-eval `(set! ,symbol ,value))
	     #f)
	 #f))))

(define-macro (register-boolean-option! name doc)
  "Register @var{name} a Scheme boolean option."
  `(register-option! ,name boolean-option-getter boolean-option-setter ,doc))

(define (number-option-setter symbol valuestr hint)
  (false-if-exception
   (let ((value (primitive-eval symbol)))
     (if (number? value)
	 (if (if (string->number valuestr)
		 (set! value (string->number valuestr))
		 #f)
	     (primitive-eval `(set! ,symbol ,value))
	     #f)
	 #f))))

(define-macro (register-integer-option! name doc)
  "Register @var{name}, a Scheme integer option."
  `(register-option! ,name #f number-option-setter ,doc))

(define (port-option-setter symbol valuestr hint)
  "Open file @var{valuestr}."
  (false-if-exception
   (let ((value (open-file valuestr "w+")))
     (if value
	 (begin
	   (ui-debug (format #f "File opened, symbol=~a" symbol))
	   (primitive-eval `(set! ,symbol ,value)) ;; FIXME: broken!?!
	   (ui-debug (format #f "~a = ~a"
			     symbol (primitive-eval symbol))))
	 (begin
	   (ui-debug "Opening failed!")
	   (and (set-error-message! "Could not open file")
		#f))))))

(register-boolean-option!
 "user-afraid?"
 "If \"no\", ask the user before executing Scheme code.")

(register-boolean-option!
 "debug?"
 "Set this variable to \"yes\" to debug Scheme code")

(register-integer-option!
 "debug-time"
 "Set this to the time debugging messages get displayed")

(register-option! "debug-port" #f port-option-setter
		  "Scheme port where debugging output should be sent.")


(define-command (scheme scm-code)
  "Evaluate the given Scheme code."
  (let ((args (split-argument-string scm-code)))
    (if (= 1 (length args))
	(if (or (not user-afraid?)
		(ui-yes-or-no? "Evaluate Scheme code?"))
	    (catch #t
		   (lambda ()
		     (ui-message (format #f "Result: ~a"
					 (eval-string (car args)))))
		   (lambda (key . args)
		     (ui-message (error-format key args))))
	    #t)
	(ui-message "Usage: scheme '<scheme code>'"))))


(define-command (help object)
  "Shows documentation for Scheme object @var{object}."
  (if (string-null? object)
      (ui-message "Type `:help <object>' to get help on a Scheme object.")
      (let ((symbol (string->symbol object)))
	(if symbol
	    (let* ((scm-cmd  (scheme-command-lookup object))
		   (scm-func (scheme-function-lookup object))
		   (scm-opt  (scheme-option-lookup object))
		   (scm-proc (false-if-exception
			      (eval symbol (current-module))))
		   (doc      (cond (scm-cmd
				    (object-documentation scm-cmd))
				   (scm-func
				    (object-dodumentation scm-func))
				   (scm-opt
				    (option-documentation scm-opt))
				   (scm-proc
				    (object-documentation scm-proc))
				   (#t #f)))
		  (typestr   (cond (scm-cmd  "C")
				   (scm-func "F")
				   (scm-opt  "O")
				   (scm-proc "S")
				   (#t       "?"))))
	      (if doc
		  (ui-message (format #f "[~a] ~a" typestr doc))
		  (ui-message "No documentation available for this symbol")))
	    (ui-message (format #f "~a: Unknown Scheme object" object))))))

; XXX: Unfortunately, this variable is reset when `reload-defaults' is
; called, too bad.
(define mutt-start-time (current-time))

; I'm sure people will like this one... ;-)
(define-command (uptime unused-argstring)
  "Displays how long Mutt has been running."
  (ui-message
   (let* ((now (current-time))
	  (ago (- now mutt-start-time))
	  (seconds (modulo ago 60))
	  (minutes (modulo (quotient ago 60) 60))
	  (hours   (modulo (quotient ago 3600) 24))
	  (days    (quotient ago (* 3600 24))))
     (string-append
      (if (> days 0)
	  (format #f "Up for ~a, ~a, ~a!"
		  (if (= days 1) "one day" (format #f "~a days" days))
		  (format #f "~a ~a" hours
			  (if (= hours 1) "hour" "hours"))
		  (format #f "~a ~a" minutes
			  (if (= minutes 1) "minute" "minutes")))
	  (format #f "Up for ~a, ~a, ~a"
		  (format #f "~a ~a" hours
			  (if (= hours 1) "hour" "hours"))
		  (format #f "~a ~a" minutes
			  (if (= minutes 1) "minute" "minutes"))
		  (format #f "~a ~a" seconds
			  (if (= seconds 1) "second" "seconds"))))))))

; Try to execute FUNCTION using the built-in mechanism.
; If this fails, look for a Scheme function with such a name.
; This is similar to `execute-command'.
(define (execute-function function)
  "Execute function @var{function} with argument string @var{args}."
  (if (string-null? function)
      #f
      (begin
	(ui-debug (format #f "function: [~a]" function))
	(if (builtin-execute-function function)
	    #t
	    (let ((scm-func (hash-ref mutt-scheme-functions function)))
	      (if scm-func
		  (safe-exec (scm-func))
		  #f)))))) ; Leave the error message as is.

(define (defined-in-module? symbol module)
  "Returns true if @var{symbol} is bound in @var{module}."
  (let ((verify (list 'defined? (list 'quote symbol))))
    (eval verify module)))

(define (eval-in-module symbol module)
  (let ((evaluation (list symbol module)))
    (apply eval evaluation)))

(define (set!-in-module symbol value module)
  (let ((setting (list 'set! symbol value)))
    (eval setting module)))


; A set-option that makes no difference between Scheme and built-in
; variables.
(define (set-option variable value . hint)
"Set to @var{value} the value of @var{variable} which can either
be a built-in variable or a Scheme variable."
  (if (null? hint)
      (set! hint 0)
      (set! hint (car hint)))
  (ui-debug (string-append "set: " variable " <- " value))
  (if (builtin-set-option variable value hint)
      #t
      (let ((scm-opt (hash-ref mutt-scheme-options variable)))
	(if scm-opt
	    (let* ((module (option-module scm-opt))
		   (opt-setter (option-setter scm-opt))
		   (symbol (string->symbol variable))
		   (quoted-symbol (list 'quote symbol)))
	      (ui-debug (format #f "set-option: Symbol is ~a" symbol))
	      (if opt-setter
		  (eval `(,opt-setter ,quoted-symbol ,value ,hint)
			module)
		  (if (defined-in-module? symbol module)
		      (set!-in-module symbol value module)
		      (and (set-error-message!
			    (format #f "~a: Unbound variable"
				    variable))
			   #f))))
	    (and (set-error-message!
		  (format #f "~a: No such built-in/Scheme option" variable))
		 #f)))))
      
;(define set-option builtin-set-option)

; Transparent querying of built-in/Scheme variables.
(define (query-option variable)
  "Return the value (a string) of the @var{variable} built-in or
Scheme option."
  (let ((value (builtin-query-option variable)))
    (if value
	value
	(let ((scm-opt (hash-ref mutt-scheme-options variable)))
	  (if scm-opt
	      (let* ((module (car scm-opt))
		     (opt-getter (option-getter scm-opt))
		     (symbol (string->symbol variable))
		     (quoted-symbol (list 'quote symbol)))
		(ui-debug (format #f "query-option: Symbol is ~a" symbol))
		(if opt-getter
		    (eval `(,opt-getter ,quoted-symbol) module)
		    (if (defined-in-module? symbol module)
			(format #f "~a" (eval-in-module symbol module))
			(and (set-error-message!
			      (format #f "~a: Unbound variable"
				      variable))
			     #f))))
	      (and (set-error-message!
		    (format #f "~a: No such built-in/Scheme option" variable))
		   #f))))))


(define parse-rc-line builtin-parse-rc-line)
(define define-alias builtin-define-alias)
(define save-alias builtin-save-alias)
(define generate-message-id builtin-generate-message-id)
(define display-message builtin-display-message)

(define mailbox-limit-pattern
  (make-procedure-with-setter
   mailbox-limit-pattern-ref mailbox-limit-pattern-set!))

(define make-forward-subject! builtin-make-forward-subject!)
(define score-message builtin-score-message)
(define compile-pattern builtin-compile-pattern)
(define execute-pattern builtin-execute-pattern)
(define save-message builtin-save-message)
(define is-mailing-list? builtin-is-mailing-list?)
(define is-subscribed-list? builtin-is-subscribed-list?)
(define address-is-user? builtin-address-is-user?)
(define default-from-address builtin-default-from-address)
(define menu-jump builtin-menu-jump)
(define add-scoring-rule! builtin-add-scoring-rule!)
(define make-reply-header! builtin-make-reply-header!)
(define pipe-message builtin-pipe-message)
(define send-message builtin-send-message)
(define add-mailbox! builtin-add-mailbox!)
(define remove-mailbox! builtin-remove-mailbox!)
(define query-exit builtin-query-exit)
(define append-signature builtin-append-signature)
(define append-forward-intro builtin-append-forward-intro)
(define append-forward-trailer builtin-append-forward-trailer)
(define append-message-attribution builtin-append-message-attribution)
(define generate-reply-body builtin-generate-reply-body)
(define generate-forward-body builtin-generate-forward-body)
(define include-reply-body builtin-include-reply-body)
(define include-forward-body builtin-include-forward-body)
(define expand-path builtin-expand-path)

(define (read-muttrc-sequence hash-char port)
  "Read a @code{#[...]#} sequence and pass every line to @code{parse-rc-line}.
Terminate only when a @code{]#} sequence or eof is read."
  ;; Note: This is not very efficient but that should be enough.
  (let ((over? #f))
    (define (get-line port)
      (let ((chr (read-char port)))
	(cond ((char=? chr #\newline) "")  ; end of line
	      ((eof-object? chr)
	       (and (set! over? #t) ""))   ; end of stuff
	      ((char=? chr #\])            ; end of #[...]# sequence
	       (let ((next-chr (read-char port)))
		 (if (char=? next-chr #\#)
		     (and (set! over? #t) "")
		     (and (unread-char next-chr)
			  (string-append (string chr)
					 (get-line port))))))
	      (#t (string-append (string chr)
				 (get-line port))))))    ; regular char
    (while (not over?)
	   (let ((line (get-line port)))
	     (ui-debug (format #f "muttrc line: ~a" line))
	     (parse-rc-line line)))
    #t))

;; The following line makes it possible to embed muttrc instructions
;; into Scheme code by simply enclosing it in a #[ ]# sequence.  The
;; contents of such a sequence may span on several lines.
(read-hash-extend #\[ read-muttrc-sequence)

;; Mutt's top-level module
(define mutt-top-level-module (current-module))

;; The following macro was somewhat inspired by
;; http://mail.nongnu.org/archive/html/guile-user/2003-04/msg00014.html .
(defmacro* mutt-module (name
			#:key (documentation "")
			#:allow-other-keys
			#:rest options)
  "Define a Mutt module.  @var{options} is a list of options similar to
that of @code{define-module}."
  (define (remove-documentation-keyword lst)
    (define (do-remove-documentation-keyword new-lst lst)
      (if (null? lst)
	  new-lst
	  (if (eq? #:documentation (car lst))
	      (if (null? (cdr lst))
		  new-lst
		  (append new-lst
			  (do-remove-documentation-keyword new-lst
							   (cddr lst))))
	      (append new-lst
		      (list (car lst))
		      (do-remove-documentation-keyword new-lst
						       (cdr lst))))))
    (do-remove-documentation-keyword '() lst))
  
  (let ((definition (append (list 'define-module name)
			    (remove-documentation-keyword options)))
	(registration (list 'register-scheme-module!
			    (list 'quote name)
			    documentation)))
    (ui-debug (format #f "~a" definition))
    `(begin
       ,registration
       ,definition
       (module-use! (current-module) ,mutt-top-level-module))))
