; 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))))
