; pop up the tooltip under the text
; partially complete as much as possible

(if (string-match "XEmacs" emacs-version)
    (defun replace-regexp-in-string (regexp newtext string)
      (replace-in-string string regexp newtext)))

(unless (fboundp 'looking-back)         ; Exists in Emacs 22
  (defun looking-back (regexp &optional limit greedy) ; Copied from Emacs 22
    "Return non-nil if text before point matches regular expression
     REGEXP.  Like `looking-at' except matches before point, and is slower.
     LIMIT if non-nil speeds up the search by specifying a minimum starting
     position, to avoid checking matches that would start before LIMIT.

     If GREEDY is non-nil, extend the match backwards as far as possible,
     stopping when a single additional previous character cannot be part
     of a match for REGEXP."
    (let ((start (point))
          (pos
           (save-excursion
             (and (re-search-backward (concat "\\(?:" regexp "\\)\\=") limit t)
                  (point)))))
      (if (and greedy pos)
          (save-restriction
            (narrow-to-region (point-min) start)
            (while (and (> pos (point-min))
                        (save-excursion
                          (goto-char pos)
                          (backward-char 1)
                          (looking-at (concat "\\(?:"  regexp "\\)\\'"))))
              (setq pos (1- pos)))
            (save-excursion
              (goto-char pos)
              (looking-at (concat "\\(?:"  regexp "\\)\\'")))))
      (not (null pos)))))

(unless (fboundp 'tooltip-show)
  (defun tooltip-show (tip)
    (print tip)))

(unless (fboundp 'line-number-at-pos)   ; Exists in Emacs 22.
  (defun line-number-at-pos (&optional pos)
    "Buffer line number at position POS. Current line number if POS is nil.
     Counting starts at (point-min), so any narrowing restriction applies."
    (1+ (count-lines (point-min) (save-excursion (when pos (goto-char pos))
                                                 (forward-line 0) (point))))))

(defun fold (f x li)
  "Recursively applies (f x i) where i is the ith element in the list li.
   For example, (fold f x '(1 2)) returns (f (f x 1) 2)"
  (let ((li2 li) (ele) (x2 x))
    (while (setq ele (pop li2))
      (setq x2 (funcall f x2 ele)))
    x2))

(defun filter (g li)
  (fold (lambda (acc x) 
          (if (funcall g x) 
              (cons x acc) 
            acc)) 
        nil li))

(defun caml-format-packages (packages)
  (mapconcat 'identity packages ","))

;(caml-format-packages '("pcre" "netstring" "ocamldap"))

(defun caml-format-paths (paths)
  (fold '(lambda (acc p) (cons "-I" (cons p acc))) 
        () 
        paths))

;(caml-format-paths '("/home/eric" "/opt/godi/lib/ocaml/pkg-lib/pcre" "foo"))

; state and configuration variables
(defvar caml-completion-buf "*caml-cmigrep*")
(defvar caml-packages nil)
(defvar caml-includes nil)
(defvar caml-default-dir nil)
(defvar caml-always-show-completions-buf t)
(make-variable-buffer-local 'caml-default-dir)
(set-default 'caml-default-dir nil)

(defconst search-type-value "-v")
(defconst search-type-record-label "-r")
(defconst search-type-module "-m")
(defconst search-type-constructor "-c")
(defconst search-type-variant "-p")

(defun caml-clear-completion-buf ()
  (save-excursion
    (set-buffer caml-completion-buf)
    (delete-region (point-min) (point-max))))

(defun strip-props (s)
  (set-text-properties 0 (length s) nil s)
  s)

(defun open-modules ()
  "parse the file to determine the list of modules open, 
   and return the list unqualified"
  (save-excursion
    (save-match-data
      (goto-char (point-min))
      (let ((modules ""))
        (while (re-search-forward "open +\\([A-Z][a-zA-Z0-9'._]*\\)" nil t)
          (if (equal modules "")
              (setq modules (strip-props (match-string 1)))
              (setq modules (concat modules "," (strip-props (match-string 1))))))
        modules))))

(defun caml-search (search-type value &rest module-exps)
  "search for a value starting with [value] in [module-exp], 
   in the directories specified by [packages] and [includes]
   and with the current working directory of cmigrep set to [dir].
   placing the results in the *caml-cmigrep* buffer"
  (let ((process-connection-type nil) ; Use a pipe for communication
	(default-directory (if caml-default-dir
			       caml-default-dir
			     default-directory)) ; Set CWD of cmigrep to dir
        (args (if value
                  (append (list search-type value) module-exps)
                (cons search-type module-exps)))
        (open (open-modules)))
    (and caml-packages
        (let ((packages (caml-format-packages caml-packages)))
          (push packages args)
          (push "-package" args)))
    (and caml-includes
        (let ((includes (caml-format-paths caml-includes)))
          (setq args (append includes args))))
    (and (not (equal open ""))
         (progn
           (push open args)
           (push "-open" args)))
    (and (get-buffer caml-completion-buf)
        (caml-clear-completion-buf))
    (apply 'call-process 
           (append (list "cmigrep" nil caml-completion-buf nil) args))))

(defun condense-spaces (s)
  "condense long strings of white space into a single space"
  (replace-regexp-in-string "[[:space:]]+" " " s))

(defun strip (s)
  (replace-regexp-in-string 
   "[[:space:]]+$" ""
   (replace-regexp-in-string "^[[:space:]]+" "" s)))

(defun extract-value-name ()
  (save-match-data
    (if (re-search-forward "[a-z]")
        (let ((start (progn (backward-char)
                            (point))))
          (if (re-search-forward ":")
              (progn 
                (backward-char)
                (strip (buffer-substring start (point)))))))))

(defun extract-value-type ()
  (interactive)
  (save-match-data
    (let ((start (point)))
      (if (re-search-forward "=\\|(\\*" (point-at-eol) t)
          (progn 
            (backward-char 2)
            (strip (buffer-substring start (point))))
        (progn
          (goto-char (point-at-eol))
          (strip (buffer-substring start (point))))))))

(defun extract-value-module ()
  (save-match-data
    (let ((start (point)))
      (if (search-forward "(*" (point-at-eol) t)
          (if (re-search-forward "[[:space:]]*\\([A-Za-z0-9_'.]*\\)" (point-at-eol) t)
              (match-string 1)
            (error "invalid module comment"))
        nil))))

(defun caml-parse-value-completion ()
  (save-match-data
    (if (re-search-forward "val\\|external")
        (let* ((value-name (extract-value-name))
               (value-type (extract-value-type))
               (value-module (extract-value-module)))
          (if value-module
              (list value-name 
                    (condense-spaces (concat value-type " from " value-module)))
            (list value-name value-type)))
      (error "invalid value completion"))))

(defun caml-extract-value-completion (line)  
  (set-buffer caml-completion-buf)
  (goto-line line) ; goto the line that our completion is on
  (beginning-of-line) ; goto the beginning
  (caml-parse-value-completion))

(defun caml-extract-module-completion (line)
  (save-match-data
    (set-buffer caml-completion-buf)
    (goto-line line)
    (beginning-of-line)
    (if (looking-at "\\([A-Z][a-zA-Z0-9._']*\\)")
        (match-string 1)
      (error "cannot read completion"))))

(defun caml-parse-record-label ()
  (or (search-forward "mutable" (point-at-eol) t) ; skip the "mutable" keyword
      (goto-char (point-at-bol)))
  (let* ((field-name (extract-value-name))
         (field-type (extract-value-type))
         (field-module (extract-value-module)))
    (if field-module
        (list field-name
              (condense-spaces (concat field-type " from " field-module)))
      (list field-name field-type))))
  
(defun caml-extract-record-label (line)
  (set-buffer caml-completion-buf)
  (goto-line line)
  (beginning-of-line)
  (caml-parse-record-label))

(defun extract-constructor-name ()
  (save-match-data
    (let ((start (point)))
      (if (search-forward " of " (point-at-eol) t)
          (progn 
            (backward-char 4)
            (strip (buffer-substring start (point))))
        (progn
          (goto-char (point-at-bol))
          (if (search-forward "(*" (point-at-eol) t)
              (progn
                (backward-char 2)
                (strip (buffer-substring start (point))))
            (progn
              (goto-char (point-at-eol))
              (strip (buffer-substring start (point))))))))))

(defun caml-extract-constructor-completion (line)
  (set-buffer caml-completion-buf)
  (goto-line line)
  (beginning-of-line)
  (let* ((constructor-name (extract-constructor-name))
         (constructor-type (extract-value-type))
         (constructor-module (extract-value-module))
         (hint constructor-type))
    (and constructor-module
         (setq hint (concat hint " from " constructor-module)))
    (list constructor-name hint)))

;  (caml-extract-value-completion 1)

(defun caml-extract-completions (completion-parser)
  (save-match-data
    (save-excursion
      (set-buffer caml-completion-buf)
      (goto-char (point-min))
      (let ((beg (line-number-at-pos (point-min)))
            (end (line-number-at-pos (point-max)))
            completions)
        (while (> end (line-number-at-pos (point)))
          (let ((completion (funcall completion-parser (line-number-at-pos (point)))))
            (setq completions (cons completion completions))
            (forward-line)))
        completions))))

(defun caml-format-value-match (value)
  (if value
      (concat "^" value ".*")
    ".*"))

(defun caml-format-module-exp (module-match)
  (if module-match
      (substring module-match 0 (- (length module-match) 1))
    (error "no module matched")))

; (caml-format-module-exp "Unix.LargeFile.")

(defun strip-colon (type)
  "given a type expression in the form ': foo -> bar', this
   function will strip the ':', just a small cosmetic thing. It
   actually just strips any colon and following white space"
  (save-match-data
    (if (string-match ":[[:space:]]*" type)
        (replace-match "" nil nil type nil)
      type)))

; (strip-colon-from-type ": foo -> bar")  

(defun caml-show-completions (completions)
  (with-output-to-temp-buffer "*Completions*"
    (display-completion-list completions)
    0))

(defun caml-show-unique-completion (completion)
  (if caml-always-show-completions-buf
      (caml-show-completions (list completion))
    (tooltip-show completion)))

(defun caml-perform-completion (unformatted-value completions)
  (save-match-data
    (if completions
        (if (> (length completions) 1)
            (caml-show-completions completions)
          (let* ((completion (car completions))
                 (value-name (if (listp completion)
                                 (car completion)
                               completion))
                 (value-type (if (listp completion)
                                 (car (cdr completion))
                               nil)))
            (if unformatted-value
                (let* ((beg (length unformatted-value))
                       (end (length value-name))
                       (value-substr (substring value-name beg end)))
                  (insert value-substr)
                  (if value-type 
                      (caml-show-unique-completion (strip-colon value-type)))
                  (length value-substr))
              (progn
                (insert value-name)
                (if value-type
                    (caml-show-unique-completion (strip-colon value-type)))
                (length value-name))))))))

(defun deref-module (x)
  (let* ((local (concat "let +module +" x " *= *\\([A-Z][A-Za-z_'0-9.]*\\) +in"))
         (global (concat "module +" x " *= *\\([A-Z][A-Za-z_'0-9.]*\\)")))
    (cond ((re-search-backward local nil t)
           (deref-module-exp (match-string 1)))
          ((re-search-backward global nil t)
           (deref-module-exp (match-string 1)))
          (t x))))

(defun deref-module-exp (x)
  (mapconcat 'deref-module (split-string x "\\.") "."))

(defun caml-cmigrep-complete-qualified (parser search-type)
  (let* ((module-name (match-string 1))
         (unformatted-value (match-string 2))
         (value (caml-format-value-match unformatted-value))
         (module-exp (save-excursion
                       (save-match-data
                         (deref-module-exp (caml-format-module-exp module-name))))))
    (if (caml-search search-type value module-exp)
        (let ((completions (caml-extract-completions parser)))
          (caml-perform-completion unformatted-value completions))
      (error "cmigrep failed"))))

(defun caml-cmigrep-complete-unqualified (parser search-type)
  (let* ((unformatted-value (match-string 1))
         (value (caml-format-value-match unformatted-value)))
    (if (caml-search search-type value)
        (caml-perform-completion unformatted-value (caml-extract-completions parser))
      (error "cmigrep failed"))))

(defconst qualified-record-field-lookup
  "[^a-zA-Z_'][a-z_][a-zA-Z0-9_']*\\.\\(\\(?:[A-Z][A-Za-z_'0-9]*\\.\\)+\\)\\([a-z_][a-zA-Z0-9_']*\\)?")
(defconst qualified-value 
  "[^a-zA-Z_'.]\\([A-Z][A-Za-z_'0-9.]*\\.\\)\\([a-z_][A-Za-z0-9_']*\\)?")
(defconst qualified-constructor
  "[^a-zA-Z_'.]\\(\\(?:[A-Z][A-Za-z_'0-9]*\\.\\)+\\)\\([A-Z][A-Za-z_'0-9]*\\)")
(defconst unqualified-record-field-lookup 
  "[^a-zA-Z_'][a-z][A-Za-z0-9_']*\\.\\([a-z][A-Za-z0-9_']*\\)?")
(defconst unqualified-value "^[^a-zA-Z_']\\([a-z][A-Za-z0-9_']*\\)")
(defconst qualified-partial-module
  "[^a-zA-Z_']\\(\\(?:[A-Z][A-Za-z_'0-9]*\\.\\)+\\)\\([A-Z][A-Za-z_'0-9]*\\)?")
(defconst unqualified-partial-module "[^a-zA-Z_']\\([A-Z][A-Za-z_'0-9]*\\)")

(defun caml-cmigrep-complete ()
  "complete OCaml based on context"
  (interactive)
  (let ((case-fold-search nil) ; make searches case sensitive. I HATE DYNAMIC SCOPE!
        chars-added)
    (save-excursion
      (save-match-data
        (or caml-default-dir
	    (and (buffer-file-name)
		(setq caml-default-dir (file-name-directory (buffer-file-name)))))
        (setq chars-added
              (cond ((looking-back qualified-record-field-lookup (point-at-bol))
                     (caml-cmigrep-complete-qualified 'caml-extract-record-label 
                                                      search-type-record-label))
                    ((looking-back qualified-value (point-at-bol))
                     (caml-cmigrep-complete-qualified 'caml-extract-value-completion 
                                                      search-type-value))
                    ((looking-back unqualified-record-field-lookup (point-at-bol))
                     (caml-cmigrep-complete-unqualified 'caml-extract-record-label 
                                                        search-type-record-label))
                    ((looking-back unqualified-value (point-at-bol))
                     (caml-cmigrep-complete-unqualified 'caml-extract-value-completion
                                                        search-type-value))
                    ((looking-back qualified-constructor (point-at-bol))
                     (caml-cmigrep-complete-qualified 'caml-extract-constructor-completion
                                                      search-type-constructor))
                    (t (error "requested completion not implemented (yet)"))))))
    (if chars-added
        (forward-char chars-added))))

(defun not-empty-string (s)
  (if (equal s "")
      nil
    s))
                  
(defun caml-complete-module ()
  (let* (unformatted-value
         (module-exp
          (cond ((looking-back qualified-partial-module (point-at-bol))
                 (let ((containing-module (not-empty-string (match-string 1)))
                       (partial-module (match-string 2)))
                   (setq unformatted-value partial-module)
                   (list 
                    (concat 
                     (caml-format-module-exp containing-module)
                     "." partial-module "*"))))
                ((looking-back unqualified-partial-module (point-at-bol))
                 (let* ((partial-module (match-string 1))
                        (partial-module-exp (concat partial-module "*")))
                   (setq unformatted-value partial-module)
                   (list partial-module-exp)))
                (t (list "*")))))
    (if (apply 'caml-search
               (cons search-type-module module-exp))
        (let ((completions (caml-extract-completions 'caml-extract-module-completion)))
          (caml-perform-completion unformatted-value completions))
      (error "cmigrep failed"))))

(defun caml-cmigrep-complete-module ()
  "complete the partial module name before the point"
  (interactive)
  (let ((case-fold-search nil) ; make searches case sensitive. I HATE DYNAMIC SCOPE!
        chars-added)
    (save-excursion
      (save-match-data
        (or caml-default-dir
            (setq caml-default-dir (file-name-directory (buffer-file-name))))
        (setq chars-added (caml-complete-module))))
    (if chars-added
        (forward-char chars-added))))