;;; hnf-mode.el --- major mode for editing hnf.

;; Copyright (C) 1998-2001 by Akihiro Arisawa

;; Author: Akihiro Arisawa <ari@nijino.com>
;; Version: $Id: hnf-mode.el,v 3.33 2001/04/15 15:30:48 ari Exp $
;; Keywords: hnf nikki hns

;; This file 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 file 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 GNU Emacs; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Code:

(defconst hnf-mode-version "2.4")

(eval-when-compile (require 'cl))
(require 'poe)
(require 'pcustom)

(defgroup hnf nil
  "Hyper Nikki File"
  :group 'hypermedia)

(defcustom hnf-diary-dir "~/diary"
  "Name of the hns diary directory."
  :group 'hnf
  :type 'directory)

(defcustom hnf-html-dir "~/public_html/diary"
  "Name of the hns web directory."
  :group 'hnf
  :type 'directory)

(defcustom hnf-hns-program (concat hnf-html-dir "/index.cgi")
  "Program name of the hns."
  :group 'hnf
  :type 'file)

(defcustom hnf-document-root "/usr/local/apache/htdocs"
  "The directory of server's DocumentRoot."
  :group 'hnf
  :type 'directory)

(defcustom hnf-diary-year-directory-flag t
  "Non-nil means hnf file is put at yearly directory.
If this flag is nil, hnf file is put at directly under `hnf-diary-directory'."
  :group 'hnf
  :type 'boolean)

(defcustom hnf-diary-url (concat "http://" (system-name) "/"
				 "~" (user-login-name) "/diary/")
  "The URL of diary."
  :group 'hnf
  :type 'string)

(defcustom hnf-index-name-list '("index.html" "index.shtml" "index.phtml")
  "File name as index."
  :group 'hnf
  :type 'list)

(defcustom hnf-mode-hook nil
  "Hook colled by `hnf-mode'."
  :group 'hnf
  :type 'hook)

(defcustom hnf-mode-load-hook nil
  "Hook called when `hnf-mode' is loaded."
  :group 'hnf
  :type 'hook)

(defcustom hnf-initial-function nil
  "Functions called when visit new file."
  :group 'hnf
  :type 'function)

(defcustom hnf-variable nil
  "Variable name used in hnf."
  :group 'hnf
  :type 'list)

(defcustom hnf-rlink nil
  "RLINK name used in hnf."
  :group 'hnf
  :type 'list)

(defcustom hnf-cat nil
  "Category name used in hnf."
  :group 'hnf
  :type 'list)

(defcustom hnf-group nil
  "Group name used in hnf."
  :group 'hnf
  :type 'list)

(defcustom hnf-class nil
  "Class name used in hnf."
  :group 'hnf
  :type 'list)

(defcustom hnf-mark nil
  "MARK name used in hnf."
  :group 'hnf
  :type 'list)

(defcustom hnf-alias nil
  "ALIAS name used in hnf."
  :group 'hnf
  :type 'list)

(defcustom hnf-font-lock-flag t
  "Non-nil means font-lock is used."
  :group 'hnf
  :type 'boolean)

(defcustom hnf-outline-flag t
  "Non-nil means outline-minor-mode is used."
  :group 'hnf
  :type 'boolean)

(defcustom hnf-complete-command-insert-space-flag t
  "Non-nil means insert space character after complete command."
  :group 'hnf
  :type 'boolean)

(defcustom hnf-complete-command-insert-newline-function 'hnf-newline
  "Functions call after complete command taking no argument."
  :group 'hnf
  :type 'function)

(defcustom hnf-time-format "(%H:%M)"
  "Format for `hnf-insert-time'.  See also `format-time-string'."
  :group 'hnf
  :type 'string)

(defcustom hnf-time-regexp "([0-9][0-9]:[0-9][0-9])"
  "Regexp for string inserted by `hnf-insert-time'."
  :group 'hnf
  :type 'regexp)

(defcustom hnf-namazu-index-dir (concat hnf-diary-dir "/namazu/index")
  "Name of the directory put index of namazu."
  :group 'hnf
  :type 'directory)

(defcustom hnf-tab-command 'tab-to-tab-stop
  "Functions called in `hnf-tab-complete' when not completed/expanded."
  :group 'hnf
  :type 'function)

(defcustom hnf-new-link-name-format "?%Y%m%h&to=%Y%m%d%N#%Y%m%d%N"
  "The format specification of NEW line link name in `hnf-get-link'.

%Y is the year.
%m is the month.
%d is the day.
%h is the day-hi. (The day divided by 10.)
%a is the day-abc. (1st - 10th is \"a\", 11th - 20th is \"b\", other is \"c\".)
%N is the new count.
%S is the sub count.
%% is \"%\".

For example, hns-1.03pl0 or earlyer format is \"?%Y%m%h#%Y%m%d%N\",
hns-2.10 or later format is \"?%Y%m%a&to=%Y%m%d%N#%Y%m%d%N\",
static format is \"%Y%m.html#%Y%m%d%N\".")

(defcustom hnf-sub-link-name-format "?%Y%m%d%N&to=%Y%m%d%NS%S#%Y%m%d%NS%S"
  "The format specification of SUB line link name in `hnf-get-link'.
See the documentation of the `hnf-new-link-name-format' for more detail.

For example, hns-1.03pl0 or earlyer format is \"?%Y%m%h#%Y%m%d%NS%S\",
hns-2.10 or later format is \"?%Y%m%a&to=%Y%m%d%NS%S#%Y%m%d%NS%S\",
static format is \"%Y%m.html#%Y%m%d%NS%S\".")

(defcustom hnf-hour-not-today 0
  "Till the specified hour, considered as the day before.
Set integer from 0 to 23.

eg. If you specify 6, from 0:00 to 5:59 is considered as the day before,
    and you type M-x hnf then open yesterday hnf. Also, you type
    M-x hnf-insert-time then inserte like \"25:00\"."
  :group 'hnf
  :type 'integer)

(defcustom hnf-browse-url-browser-function browse-url-browser-function
  "Function to display the diary in a WWW browser.
See also `browse-url-browser-function'."
  :group 'hnf
  :type 'function)

(defface hnf-cat-face
  '((((class color) (background light)) (:foreground "Purple" :bold t))
    (((class color) (background dark)) (:foreground "Cyan" :bold t))
    (t (:bold t)))
  "Face for CAT line in hnf."
  :group 'hnf)
(defface hnf-new-face
  '((((class color) (background light)) (:foreground "Purple" :bold t))
    (((class color) (background dark)) (:foreground "Cyan" :bold t))
    (t (:bold t)))
  "Face for NEW line in hnf."
  :group 'hnf)
(defface hnf-sub-face
  '((((class color) (background light)) (:foreground "Purple"))
    (((class color) (background dark)) (:foreground "Cyan"))
    (t ()))
  "Face for SUB line in hnf."
  :group 'hnf)
(defface hnf-link-face
  '((((class color) (background light)) (:foreground "Blue"))
    (((class color) (background dark)) (:foreground "LightSkyBlue"))
    (t ()))
  "Face for link in hnf."
  :group 'hnf)
(defface hnf-image-face
  '((((class color) (background light)) (:foreground "Blue"))
    (((class color) (background dark)) (:foreground "LightSkyBlue"))
    (t ()))
  "Face for image in hnf."
  :group 'hnf)
(defface hnf-comment-face
  '((((class color) (background light)) (:foreground "Red"))
    (((class color) (background dark)) (:foreground "Pink"))
    (t ()))
  "Face for image line in hnf."
  :group 'hnf)
(defface hnf-command-face
  '((((class color) (background light)) (:foreground "firebrick"))
    (((class color) (background dark)) (:foreground "Chocolate1"))
    (t ()))
  "Face for command in hnf."
  :group 'hnf)
(defface hnf-tilde-face
  '((((class color) (background light)) (:foreground "orange"))
    (((class color) (background dark)) (:foreground "orange"))
    (t ()))
  "Face for \"~\" in hnf."
  :group 'hnf)
(defface hnf-variable-face
  '((((class color) (background light)) (:foreground "DarkGoldenrod"))
    (((class color) (background dark)) (:foreground "LightGoldenrod"))
    (t ()))
  "Face for variable in hnf."
  :group 'hnf)

(defvar hnf-mode-map nil)

(defvar hnf-cat-face 'hnf-cat-face)
(defvar hnf-new-face 'hnf-new-face)
(defvar hnf-sub-face 'hnf-sub-face)
(defvar hnf-link-face 'hnf-link-face)
(defvar hnf-image-face 'hnf-image-face)
(defvar hnf-comment-face 'hnf-comment-face)
(defvar hnf-command-face 'hnf-command-face)
(defvar hnf-tilde-face 'hnf-tilde-face)
(defvar hnf-variable-face 'hnf-variable-face)

(defvar hnf-complete-ok t
  "If this is non-nil, \"OK\" is included for completion.")

(defconst hnf-completion-buffer-name "*HNF Completions*")

(defvar hnf-commands-table
  '(("NEW"	. ((type . new)
		   (args . (("title")))))
    ("SUB"	. ((type . sub)
		   (args . (("title")))))
    ("CAT"	. ((args . (("category" . ((complete . hnf-cat)))
			    any))
		   (face . hnf-cat-face)
		   (outline-level . 1)
		   (insert-string-after-newline . "NEW ")))

    ("LNEW"	. ((type . new)
		   (args . (link
			    ("title")))))
    ("RLNEW"	. ((type . new)
		   (args . (rlink
			    ("append")
			    ("title"))))) ; hns-2.10
    ("LSUB"	. ((type . sub)
		   (args . (link
			    ("title")))))
    ("RLSUB"	. ((type . sub)
		   (args . (rlink
			    ("append")
			    ("title"))))) ; hns-2.10

    ("P"	. ((need-close))) ; hns-2.10
    ("GRP"	. ((args . (("group" . ((complete . hnf-group)))
			    any))
		   (outline-level . 1))) ; hns-2.10

    ("LINK"	. ((args . (link
			    ("sentence")))))
    ("URL"	. ((args . (("url" . ((face . hnf-link-face)))
			    ("sentence")))))
    ("RLINK"	. ((args . (rlink
			    ("append")
			    ("sentence")))))

    ("FONT"	. ((args . (("arg1")
			    ("arg2")
			    ("sentence")))))
    ("STRIKE"	. ((args . (("sentence")))))
    ("LSTRIKE"	. ((args . (link
			    ("sentence")))))
    ("STRONG"	. ((args . (("sentence")))))
    ("SPAN"	. ((args . (("class" . ((complete . hnf-class)))
			    ("sentence"))))) ; hns-2.10

    ("IMG"	. ((args . (("place" . ((complete . (("r") ("l") ("n")))))
			    image
			    ("alt")))))
    ("LIMG"	. ((args . (link
			    ("place" . ((complete . (("r") ("l") ("n")))))
			    image
			    ("alt"))))) ; hns-2.10
    ("MARK"	. ((args . (("mark" . ((complete . hnf-mark)))))))

    ("UL"	. ((need-close)
		   (insert-string-after-newline . "LI ")))
    ("OL"	. ((need-close)
		   (insert-string-after-newline . "LI ")))
    ("LI"	. ((args . (("sentence")))))
    ("DL"	. ((need-close)
		   (insert-string-after-newline . "DT "))) ; hns-2.10
    ("DT") ; hns-2.10
    ("DD") ; hns-2.10

    ("PRE"	. ((need-close))) ; hns-2.10
    ("CITE"	. ((need-close))) ; hns-2.10

    ("!"	. ((args . (("sentence")))
		   (face . hnf-comment-face)))
    ("!#"	. ((args . (("sentence")))
		   (face . hnf-comment-face)))
    ("FN"	. ((need-close)))
    ("ALIAS"	. ((args . (("alias" . ((complete . hnf-alias)))))))
    )
  "Table of hnf commands.")

(defmacro hnf-command-get-command (command-name)
  (` (assoc (, command-name) hnf-commands-table)))

(defmacro hnf-command-get-type (command)
  (` (cdr (assq 'type (cdr (, command))))))

(defmacro hnf-command-get-face (command)
  (` (cond ((cdr (assq 'face (cdr (, command)))))
	   ((eq (hnf-command-get-type (, command)) 'new) hnf-new-face)
	   ((eq (hnf-command-get-type (, command)) 'sub) hnf-sub-face))))

(defmacro hnf-command-get-string-after-newline (command)
  (` (cdr (assq 'insert-string-after-newline (cdr (, command))))))

(defmacro hnf-command-get-outline-level (command)
  (` (cond ((cdr (assq 'outline-level (cdr (, command)))))
	   ((eq (hnf-command-get-type (, command)) 'new) 1)
	   ((eq (hnf-command-get-type (, command)) 'sub) 2))))

(defmacro hnf-command-get-args (command)
  (` (cdr (assq 'args (cdr (, command))))))

(defmacro hnf-command-get-arg-detail (command count)
  (` (let ((args (hnf-command-get-args (, command))))
       (if (or (eq (nth (, count) args) 'any)
	       (eq (nth 1 args) 'any))
	   (nth 0 args)
	 (nth (, count) args)))))

(defmacro hnf-command-need-close-p (command)
  (` (assq 'need-close (cdr (, command)))))

(defvar hnf-font-lock-keywords
  (let ((commands hnf-commands-table)
	command type face ret1 ret2 ret3)
    (while (setq command (car commands))
      (if (setq face (hnf-command-get-face command))
	  (add-to-list 'ret1 (cons (concat "^" (car command) ".*") face))
	(let ((args (hnf-command-get-args command))
	      (cnt 0)
	      arg)
	  (while (setq arg (car args))
	    (if (setq face (cond ((eq arg 'link) 'hnf-link-face)
				 ((eq arg 'image) 'hnf-image-face)
				 ((consp arg)
				  (cdr (assq 'face (cdr arg))))))
		(add-to-list
		 'ret2
		 (list (concat "^" (car command) " +"
			       (apply (function concat)
				      (make-list cnt "[^ ]+ +"))
			       "\\([^ ]+\\)")
		       1 face)))
	    (setq cnt (1+ cnt)
		  args (cdr args)))))
      (add-to-list 'ret3
		   (if (hnf-command-need-close-p command)
		       (concat (car command) "\\|/" (car command))
		     (car command)))
      (setq commands (cdr commands)))
    (append ret1
	    ret2
	    (list
	     (cons (concat "^\\("
			   (mapconcat (function identity) ret3 "\\|")
			   "\\)\\>")
		   hnf-command-face))
	    (list
	     '(eval . (list
		       (concat "^\\("
			       (mapconcat (function car) hnf-variable "\\|")
			       "\\)\\>")
		       '(0 (if (hnf-header-p) hnf-variable-face)))))
	    (list (cons "~$" hnf-tilde-face))))
  "Expressions to highlight in hnf mode.
This value is generated by `hnf-commands-table'.")

(defvar hnf-outline-regexp
  (let ((commands hnf-commands-table)
	command outline-commands)
    (while (setq command (car commands))
      (if (hnf-command-get-outline-level command)
	  (add-to-list 'outline-commands (car command)))
      (setq commands (cdr commands)))
    (mapconcat (function identity) outline-commands "\\|"))
  "Regular expression to match the beginning of heading.")

(defvar hnf-imenu-generic-expression
  (let ((commands hnf-commands-table)
	command ret)
    (while (setq command (car commands))
      (if (eq (hnf-command-get-type command) 'new)
	  (let ((args (hnf-command-get-args command))
		(cnt -1))
	    (while args
	      (setq args (cdr args)
		    cnt (1+ cnt)))
	    (add-to-list 'ret
			 (list
			  nil
			  (concat "^" (car command) " "
				  (apply (function concat)
					 (make-list cnt "[^ ]+ "))
				  "\\(.*\\)")
			  1))))
      (setq commands (cdr commands)))
    ret)
  "Imenu generic expression for `hnf-mode'.  See `imenu-generic-expression'.")

(if hnf-mode-map nil
  (setq hnf-mode-map (make-sparse-keymap))
  (define-key hnf-mode-map "\t" 'hnf-tab-complete)
  (define-key hnf-mode-map "\C-c\C-m" 'hnf-newline)
  (define-key hnf-mode-map "\C-c?" 'hnf-command-help)
  (define-key hnf-mode-map "\C-c=" 'hnf-get-link)
  (define-key hnf-mode-map "\C-c\C-f" 'hnf-link-find-file)
  (define-key hnf-mode-map "\C-c\C-t" 'hnf-insert-time)
  (define-key hnf-mode-map "\C-c\C-s" 'hnf-write-file-insert-time)
  (define-key hnf-mode-map "\C-c\C-b" 'hnf-browse-recent-diary)
  (define-key hnf-mode-map "\C-c\C-p" 'hnf-preview-diary)
  (define-key hnf-mode-map "\C-c\C-n" 'hnf-namazu)
  )

;;;###autoload
(defun hnf-mode ()
  "Major mode for editing hnf.
\\{hnf-mode-map}"
  (interactive)
  (use-local-map hnf-mode-map)
  (setq mode-name "HNF")
  (setq major-mode 'hnf-mode)
  ;; font-lock
  (when hnf-font-lock-flag
    (require 'font-lock)
    (make-local-variable 'font-lock-defaults)
    (setq font-lock-defaults '(hnf-font-lock-keywords t))
    (font-lock-mode t))
  ;; outline
  (when hnf-outline-flag
    (make-local-variable 'outline-regexp)
    (setq outline-regexp hnf-outline-regexp)
    (make-local-variable 'outline-level)
    (setq outline-level (function hnf-outline-level))
    (outline-minor-mode 1))
  ;; imenu
  (make-local-variable 'imenu-generic-expression)
  (setq imenu-generic-expression hnf-imenu-generic-expression)
  ;; hook
  (and (functionp hnf-initial-function)
       (= (buffer-size) 0)
       (buffer-file-name)
       (not (file-exists-p (buffer-file-name)))
       (funcall hnf-initial-function))
  (run-hooks 'hnf-mode-hook))

;;;###autoload
(defun hnf (&optional arg)
  "Open hnf of today.
If numerical argument is specified, open hnf of that days ago."
  (interactive "P")
  (let* ((days-ago (if (listp arg) nil arg))
	 (now (hnf-current-time days-ago))
	 (dir (concat hnf-diary-dir "/"
		      (and hnf-diary-year-directory-flag
			   (hnf-format-time-string "%Y/" now))))
	 (name (concat dir (unless (and arg (listp arg))
			     (hnf-format-time-string "d%Y%m%d.hnf" now)))))
    (if (and arg (listp arg)) (setq name (read-file-name "Find file: " name)))
    (or (file-directory-p (file-name-directory name))
	(make-directory  dir))
    (find-file name)
    (hnf-mode)))

(defun hnf-tab-complete ()
  "Complete and expantion in hnf."
  (interactive)
  (let ((spaces (hnf-count-spaces))
	(command-word (hnf-command-word))
	detail complete-list)
    (cond ((hnf-header-p) ; header part
	   (or (and (eq spaces 0)
		    (or (and hnf-variable
			     (not (eq (hnf-complete hnf-variable) 'no-match)))
			(and hnf-complete-ok
			     (not (eq (hnf-complete '(("OK"))) 'no-match)))))
	       (funcall hnf-tab-command)))
	  ((eq (setq detail (and (> spaces 0)
				 (hnf-command-get-arg-detail
				  (hnf-command-get-command command-word)
				  (1- spaces))))
	       'rlink)
	   (hnf-complete hnf-rlink))
	  ((or (eq detail 'link) (eq detail 'image))
	   (hnf-complete-link))
	  ((setq complete-list (cdr (assq 'complete (cdr detail))))
	   (hnf-complete
	    (if (symbolp complete-list)
		(symbol-value complete-list)
	      complete-list)))
	  ((and (string= "/" command-word) (= spaces 0))
	   (hnf-close-command))
	  ((and (= spaces 0)
		(not (eq (hnf-complete-command) 'no-match))))
	  (t
	   (funcall hnf-tab-command)))))

;;; various command
(defun hnf-newline ()
  "Insert newline and various string fit for the situation."
  (interactive)
  (let* ((command-word (hnf-command-word))
	 (command (hnf-command-get-command command-word))
	 (case-fold-search nil)
	 str)
    (if (hnf-command-need-close-p command)
	(save-excursion (insert (concat "\n/" command-word "\n"))))
    (newline)
    (if (setq str (hnf-command-get-string-after-newline command))
	(insert str))))

(defun hnf-command-help (&optional command-word)
  "Display help of command."
  (interactive "P")
  (unless command-word (setq command-word (hnf-command-word)))
  (let ((command (hnf-command-get-command command-word))
	mes)
    (when command
      (setq mes command-word)
      (let ((args (hnf-command-get-args command))
	    arg)
	(while (setq arg (car args))
	  (setq mes (concat mes " " (if (symbolp arg)
					(if (eq arg 'any)
					    "[...]"
					  (symbol-name arg))
				      (car arg)))
		args (cdr args)))
	(message mes)))))

(defun hnf-link-find-file ()
  "Open file specifed by LINK or LSUB.
Suppore only relative path."
  (interactive)
  (if (eq (hnf-command-get-arg-detail
	   (hnf-command-get-command (hnf-command-word))
	   0)
	  'link)
      (let (p fname)
	(save-excursion
	  (beginning-of-line)
	  (skip-chars-forward "^ \t\n")
	  (skip-chars-forward " ")
	  (setq p (point))
	  (skip-chars-forward "^ \t\n#")
	  (setq fname (buffer-substring-no-properties p (point))))
	(if (string-match "^\\(http\\|ftp\\)://" fname)
	    (funcall hnf-browse-url-browser-function fname)
	  (setq fname (expand-file-name fname
					(if (char-equal (string-to-char fname)
							?/)
					    hnf-document-root
					  hnf-html-dir)))
	  (when (file-directory-p fname)
	    (when (not (string-match "/$" fname))
	      (setq fname (concat fname "/")))
	    (let ((index-list hnf-index-name-list))
	      (while (and index-list
			  (not (file-exists-p
				(concat fname (car index-list)))))
		(setq index-list (cdr index-list)))
	      (if index-list
		  (setq fname (concat fname (car index-list)))
		(setq fname
		      (read-file-name "Find file: " fname)))))
	  (find-file fname)))))

(defun hnf-get-link (&optional arg)
  "Obtain name of NEW or SUB."
  (interactive "P")
  (let ((date-list (hnf-buffer-hnf-p)))
    (if (null date-list)
	(error "This is not hnf")
      (let ((day-num (string-to-number (nth 2 date-list)))
	    (command-word (hnf-command-word))
	    command-type
	    new-cnt sub-cnt link-name)
	(save-excursion
	  (when (eq (setq command-type
			  (hnf-command-get-type
			   (hnf-command-get-command command-word)))
		    'sub)
	    (setq sub-cnt 1)
	    (while (and (= (forward-line -1) 0)
			(not (eq
			      (setq command-type
				    (hnf-command-get-type
				     (hnf-command-get-command
				      (setq command-word (hnf-command-word)))))
			      'new)))
	      (if (eq command-type 'sub)
		  (setq sub-cnt (1+ sub-cnt)))))
	  (when (eq command-type 'new)
	    (setq new-cnt 1)
	    (while (= (forward-line -1) 0)
	      (if (eq (hnf-command-get-type
		       (hnf-command-get-command (hnf-command-word)))
		      'new)
		  (setq new-cnt (1+ new-cnt))))))
	(when new-cnt
	  (let* ((fmt (if sub-cnt hnf-sub-link-name-format
			hnf-new-link-name-format))
		 (fmt-spec (list
			    (cons ?Y (nth 0 date-list))
			    (cons ?m (nth 1 date-list))
			    (cons ?d (nth 2 date-list))
			    (cons ?h (number-to-string (/ day-num 10)))
			    (cons ?a (cond ((< day-num 11) "a")
					   ((< day-num 21) "b")
					   (t "c")))
			    (cons ?N (number-to-string new-cnt))
			    (cons ?S (if sub-cnt (number-to-string sub-cnt)))))
		 (fmt-len (length fmt))
		 (ind 0)
		 (result "")
		 cur-char)
	    (while (< ind fmt-len)
	      (setq cur-char (aref fmt ind))
	      (setq result
		    (concat result
			    (if (eq cur-char ?%)
				(progn
				  (setq ind (1+ ind)
					cur-char (aref fmt ind))
				  (or (cdr (assq cur-char fmt-spec))
				      (char-to-string cur-char)))
			      (char-to-string cur-char))))
	      (setq ind (1+ ind)))
	    (message "%s" result)
	    (if arg (kill-new result))))))))

(defun hnf-insert-time (&optional arg)
  "Insert time stamp."
  (interactive "P")
  (if (and arg
	   (re-search-forward hnf-time-regexp nil t))
      (replace-match
       (save-match-data
	 (hnf-format-time-string hnf-time-format (hnf-current-time))))
    (insert (hnf-format-time-string hnf-time-format (hnf-current-time)))))

(defun hnf-write-file-insert-time ()
  "Execute `hnf-insert-time', and save file."
  (interactive)
  (save-excursion
    (goto-char (point-max))
    (hnf-insert-time))
  (save-buffer))

(defun hnf-check ()
  "Check curernt hnf file."
  (interactive)
  (let ((case-fold-search nil)
	word)
    ;; find all capitalized word in top of line
    (save-excursion
      (goto-char (point-min))
      (search-forward "\n\n" nil t)
      (while (re-search-forward "^/?\\([A-Z]+\\)\\([ \t]\\|$\\)" nil t)
	;; is it valid command?
	(unless (assoc (setq word (match-string 1)) hnf-commands-table)
	  (if (y-or-n-p (format "Undefined keyword '%s'.  Insert space? "
				word))
	      (save-excursion
		(goto-char (match-beginning 0))
		(insert " "))
	    ;; leave it
	    (error "Edit it!")))))
    (if (interactive-p)
	(message "Good!"))))

;;; for namazu.el
(defun hnf-namazu (key)
  (interactive
   (progn
     (require 'namazu)
     (list (read-from-minibuffer "Enter Keyword: " nil
				 (if (boundp 'namazu-minibuffer-field-map)
				     namazu-minibuffer-field-map)
				 nil 'namazu-history))))
  (namazu 0 hnf-namazu-index-dir key))

(defun hnf-namazu-find-file ()
  "Open hnf at point in \*namazu\*."
  (interactive)
  (save-excursion
    (if (re-search-forward
	 "#\\([1-9][0-9][0-9][0-9]\\)\\([0-1][0-9][0-3][0-9]\\)0" nil t)
	(find-file (concat hnf-diary-dir "/"
			   (and hnf-diary-year-directory-flag
				(concat (match-string 1) "/"))
			   "d" (match-string 1) (match-string 2) ".hnf")))))

;;; for calendar.el
(eval-when-compile (require 'calendar))

(defun hnf-filename-from-date (date)
  (concat hnf-diary-dir "/"
	  (and hnf-diary-year-directory-flag
	       (format "%d/" (extract-calendar-year date)))
	  (format "d%04d%02d%02d.hnf"
		  (extract-calendar-year date)
		  (extract-calendar-month date)
		  (extract-calendar-day date))))

;;;###autoload
(defun hnf-insert-diary-entry ()
  "Open hnf for the date indicated by point."
  (interactive)
  (find-file-other-window
   (hnf-filename-from-date (calendar-cursor-to-date t))))

;;;###autoload
(defun hnf-mark-diary-entries ()
  "Mark days in the calendar window that have hnf."
  (interactive)
  (let (y m first-date last-date tmp)
    (save-excursion
      (set-buffer calendar-buffer)
      (setq m displayed-month)
      (setq y displayed-year))
    (increment-calendar-month m y -1)
    (setq first-date
          (calendar-absolute-from-gregorian (list m 1 y)))
    (increment-calendar-month m y 2)
    (setq last-date
          (calendar-absolute-from-gregorian
           (list m (calendar-last-day-of-month m y) y)))
    (calendar-for-loop date from first-date to last-date do
		       (if (file-exists-p
			    (hnf-filename-from-date
			     (setq tmp
				   (calendar-gregorian-from-absolute date))))
			   (mark-visible-calendar-date tmp)))))

;;; for browse-url
(defun hnf-browse-recent-diary ()
  "Ask a WWW browser to load recent diary."
  (interactive)
  (let ((browse-url-browser-function hnf-browse-url-browser-function))
    (browse-url hnf-diary-url)))

(defun hnf-browse-diary ()
  "Ask a WWW browser to load current editting diary."
  (interactive)
  (let ((date-list (hnf-buffer-hnf-p))
	(browse-url-browser-function hnf-browse-url-browser-function))
    (if (null date-list)
	(error "This is not hnf")
      (browse-url (concat hnf-diary-url "?"
			  (mapconcat (function identity) date-list ""))))))

(defvar hnf-temp-file-list '())

(defun hnf-preview-diary ()
  "Ask a WWW browser to load current editting diary."
  (interactive)
  (let ((date-list (hnf-buffer-hnf-p))
	(browse-url-browser-function hnf-browse-url-browser-function))
    (if (null date-list)
        (error "This is not hnf")
      (let ((temp-file (concat temporary-file-directory
			       "hnf" (apply (function concat) date-list)
			       ".html"))
            (default-directory (file-name-directory hnf-hns-program)))
        (with-temp-file temp-file
          (call-process hnf-hns-program nil t t
			(apply (function concat) date-list)))
        (browse-url-of-file temp-file)
	(add-to-list 'hnf-temp-file-list temp-file)))))

(defun hnf-delete-temp-file-list ()
  "Remove file of `hnf-temp-file-list'."
  (while hnf-temp-file-list
    (if (file-exists-p (car hnf-temp-file-list))
	(delete-file (car hnf-temp-file-list)))
    (setq hnf-temp-file-list (cdr hnf-temp-file-list))))
(add-hook 'kill-emacs-hook 'hnf-delete-temp-file-list)

;;; miscellaneous functions
(defun hnf-buffer-hnf-p (&optional buffer)
  "Judge whether buffer is hnf.
If buffer is ommitted, judge for `current-buffer'.
If buffer is hnf, return list of (year mon day)."
  (let ((fname (buffer-file-name buffer)))
    (if (and fname
	     (string-match
	      "d\\([0-9][0-9][0-9][0-9]\\)\\([0-1][0-9]\\)\\([0-3][0-9]\\)\\.hnf"
	      (setq fname (file-name-nondirectory fname))))
	(list (match-string 1 fname)
	      (match-string 2 fname)
	      (match-string 3 fname)))))

(defun hnf-header-p ()
  "Judge whether in header."
  (save-excursion
    (not (search-backward "\n\n" nil t))))

(defun hnf-count-spaces ()
  "Count space character from beginning of line to point."
  (save-excursion
    (let ((p (point))
	  (cnt 0))
      (beginning-of-line)
      (while (re-search-forward "[ \t]+" p t)
	(setq cnt (+ cnt 1)))
      cnt)))

(defun hnf-cur-word (&optional erase)
  "Extract word at point."
  (save-excursion
    (let ((p (point))
	  string)
      (skip-chars-backward "^ \t\n")
      (setq string (buffer-substring-no-properties p (point)))
      (if erase (delete-region p (point)))
      string)))

(defun hnf-command-word ()
  "Obtain command word at the line."
  (save-excursion
    (beginning-of-line)
    (let ((p (point)))
      (skip-chars-forward "^ \t\n")
      (buffer-substring-no-properties p (point)))))

(defun hnf-close-command ()
  "Insert close command."
  (let ((commands hnf-commands-table)
	command close-commands regexp stack command)
    (while (setq command (car commands))
      (if (hnf-command-need-close-p command)
	  (add-to-list 'close-commands (car command)))
      (setq commands (cdr commands)))
    (setq regexp
	  (concat "^/?\\("
		  (mapconcat (function identity) close-commands "\\|")
		  "\\)$"))
    (save-excursion
      (while (progn
	       (or (re-search-backward regexp nil t)
		   (error "Command unmatch"))
	       (setq command (match-string 1))
	       (if (eq (char-after) ?/)
		   (push command stack)
		 (if (string= command (car stack))
		     (pop stack))))))
    (if stack (error "%s unmatched" command))
    (if command (insert command))))

(defun hnf-current-time (&optional days-ago)
  "Return `current-time'.
But, if `hnf-hour-not-today' is set, return the time of specified hours ago."
  (let ((time (current-time)))
    (if (not (numberp days-ago)) (setq days-ago 0))
    (hnf-time-float (- (hnf-float-time time)
		       (* days-ago 24 60 60)
		       (* (or hnf-hour-not-today 0) 60 60)))))

(defun hnf-format-time-string (time-format &optional time)
  "Same as `format-time-string'.
But, \"%H\" is translated into feature hour for `hnf-hour-not-today'."
  (let ((case-fold-search nil)
	sub-format hour)
    (while (string-match "%[a-zA-Z]" time-format)
      (setq sub-format (match-string 0 time-format))
      (setq time-format
	    (replace-match
	     (if (string= sub-format "%H")
		 (format "%d"
			 (+ (or hnf-hour-not-today 0)
			    (string-to-number (format-time-string "%H" time))))
	       (format-time-string sub-format time))
	     nil nil time-format)))
    time-format))

(defun hnf-float-time (&optional tm)
  (let ((time (or tm (current-time))))
    (+ (* (float (ash 1 16)) (nth 0 time)) (float (nth 1 time)))))
  
(defun hnf-time-float (num)
  (let* ((most-time (floor num 65536))
	 (least-time (floor (- num (* 65536.0 most-time)))))
    (list most-time least-time 0)))

(defun hnf-outline-level ()
  "Return the depth to which a statement is nested in the outline.
Point must be at the beginning of a header line.
See `hnf-commands-table'."
  (save-excursion
    (if (looking-at outline-regexp)
	(hnf-command-get-outline-level
	 (hnf-command-get-command
	  (buffer-substring (match-beginning 0) (match-end 0)))))))

(eval-after-load "speedbar"
  '(speedbar-add-supported-extension ".hnf"))

;;; upper function for completion
(defun hnf-complete (alist)
  "Complete at point.  ALIST is set of permissible completions."
  (hnf-complete-string (hnf-cur-word t) alist))

(defun hnf-complete-link ()
  "Complete LINK."
  (let* ((cur (hnf-cur-word t))
	 (dname (file-name-directory cur))
	 (fname (file-name-nondirectory cur))
	 (basedir (cond ((char-equal (string-to-char cur) ?/)
			 (concat hnf-document-root dname))
			(dname
			 (expand-file-name dname hnf-html-dir))
			(t
			 hnf-html-dir)))
	 files)
    (when (file-directory-p basedir)
      (setq files (file-name-all-completions fname basedir)))
    (if (null files) 
	(when (require 'w3m nil t)
	  (w3m-arrived-setup)
	  (mapatoms (lambda (x)
		      (when x (push (list (symbol-name x)) files)))
		    w3m-arrived-db)
	  (hnf-complete-string cur files))
      (when dname (insert dname))
      (hnf-complete-string fname (mapcar (function list) files)))))

(defun hnf-complete-command ()
  "Complete command name."
  (let ((sts (hnf-complete hnf-commands-table)))
    (when (eq sts 'match)
      (if (null (hnf-command-get-args
		 (hnf-command-get-command (hnf-command-word))))
	  (if hnf-complete-command-insert-newline-function
	      (funcall hnf-complete-command-insert-newline-function))
	(and hnf-complete-command-insert-space-flag (insert " "))))
    sts))

;;; lower function for completion
(defun hnf-complete-string (string alist)
  (let* ((completion-ignore-case t)
	 (completions (all-completions string alist))
	 (cur (current-buffer))
	 comp)
    (cond
     ((= (length completions) 1) ; only one.
      (if (string= (car completions) string)
	  (progn
	    (insert string)
	    (hnf-delete-completion-window))
	(insert (car completions)))
      'match)
     ((and (setq comp (try-completion string alist))
	   (not (string= comp string))) ; halfway
      (insert comp)
      'complete)
     (t
      (insert string)
      (if (not comp)
	  (progn ; no match
	    (hnf-delete-completion-window)
	    'no-match)
	; display
	(buffer-disable-undo (get-buffer-create hnf-completion-buffer-name))
	(with-output-to-temp-buffer
	    hnf-completion-buffer-name
	  (display-completion-list (sort completions 'string<)))
	'complete-list)))))
  
(defun hnf-delete-completion-window ()
  (and
   (get-buffer hnf-completion-buffer-name)
   (let ((w (get-buffer-window hnf-completion-buffer-name)))
     (and w
	  (delete-window w))
     (kill-buffer hnf-completion-buffer-name))))

(run-hooks 'hnf-mode-load-hook)

(provide 'hnf-mode)
;;; hnf-mode.el ends here
