;;;_ pcmpl-elisp.el --- pcomplete support for elisp

;;;_. Headers
;;;_ , License
;; Copyright (C) 2009  Tom Breton (Tehom)

;; Author: Tom Breton (Tehom) <tehom@localhost.localdomain>
;; Keywords: convenience

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

;;;_ , Commentary:

;; 


;;;_ , Requires

(require 'pcomplete)
(when (not (fboundp 'rtest:deftest)) ;;For the inlined tests
    (defmacro rtest:deftest (&rest dummy))
    (defmacro rtest:if-avail (&rest dummy)))
(when (not (fboundp 'emt:deftest-2))
    (defmacro emt:deftest-2 (&rest dummy))
    (defmacro emt:if-avail (&rest dummy)))

(rtest:if-avail
   (require 'eg)
   (require 'tp)
   (require 'el-mock)
   (require 'mockbuf))

;;;_ , Override `mock-protect'

;;Adapted from el-mock.  Note changed behavior.  `mock-verify' will
;;not be called if another error has been signalled.
;;Obsolete, tp does all this now.
(defun mock-protect (body-fn)
  "The substance of `with-mock' macro.
Prepare for mock/stub, call BODY-FN, and teardown mock/stub.

For developer:
When you adapt Emacs Lisp Mock to a testing framework, wrap test
method around this function."
   (let (mock-verify-list
	   -stubbed-functions
	   -mocked-functions
	   (in-mocking t)
	   (mock-err nil))
      (setplist 'mock-original-func nil)
      (setplist 'mock-not-yet-called nil)
      (unwind-protect
	 (condition-case err
	    (funcall body-fn)
	    (error
	       (setq mock-err t)
	       ;;Re-raise the signal
	       (signal (car err)(cdr err))))
	 (mapcar #'stub/teardown -stubbed-functions)
	 (unwind-protect
	    (unless mock-err 
	       (mock-verify))
	    (mapcar #'mock/teardown -mocked-functions)))))

;;;_  . Tests
(rtest:deftest mock-protect

   (  "Situation: Foo is mocked
During execution, an earlier error keeps foo from ever being called.
Response: Error is not the mock-error, it is the earlier error."
      
      (condition-case err
	 (with-mock
	    (mock (foo))
	    (signal 
	       'emt:example-error 
	       "This error keeps foo from being called")
	    ;;Never reached
	    (foo)
	    nil)
	 ('mock-error nil)
	 ('emt:example-error t)))

   (  "Situation: Foo is mocked.
There is a catch outside `with-mock'.
During execution, a throw keeps foo from ever being called.
Response: Error is the mock-error."
      (condition-case err
	 (catch 'example-tag
	    (with-mock
	       (mock (foo))
	       (progn
		  (throw 'example-tag nil)
		  ;;Never reached
		  (foo)
		  nil)))
	 ('mock-error t)
	 (error nil)))
   )
;;;_   , Emtest style

(emt:deftest-2 mock-protect

   (  "Situation: Foo is mocked
During execution, an earlier error keeps foo from ever being called.
Response: Error is not the mock-error, it is the earlier error."
      
      (should
	 (equal
	    (condition-case err
	       (with-mock
		  (mock (foo))
		  (signal 
		     'emt:example-error 
		     "This error keeps foo from being called")
		  ;;Never reached
		  (foo)
		  nil)
	       ('mock-error nil)
	       ('emt:example-error 12))
	    12)))

   (  "Situation: Foo is mocked.
There is a catch outside `with-mock'.
During execution, a throw keeps foo from ever being called.
Response: Error is the mock-error."
      (should
	 (equal
	    (condition-case err
	       (catch 'example-tag
		  (with-mock
		     (mock (foo))
		     (progn
			(throw 'example-tag nil)
			;;Never reached
			(foo)
			nil)))
	       ('mock-error 12)
	       (error nil))
	    12)))
   )



;;;_. Body
;;;_ , Elisp parsing functions
;;;_  . pcomplete-skip-whitespace-backwards

(defun pcomplete-skip-whitespace-backwards ()
   ""
   ;;Would like to use (skip-syntax-backward "-") but it's broken in
   ;;21.3 
   (skip-chars-backward "\n\t \f"))

;;;_  . pcomplete-parse-elisp-arguments

(defun pcomplete-parse-elisp-arguments-rest ()
   "
Pushes elements into into special variables `args' and `positions'." 
   
   (let
      ((going t))

      (while going
	 (condition-case nil
	    (let (old-point new-point)
	       (pcomplete-skip-whitespace-backwards)
	       (setq old-point (point))
	       (backward-sexp 1)
	       (when (bobp) (signal 'scan-error "No more to scan"))
	       (setq new-point (point))
	       (push new-point positions)
	       (push 
		  (buffer-substring-no-properties 
		     new-point old-point)
		  args))
		  
	    ('scan-error
	       (setq going nil))))))
;;;_   , Tests

(rtest:deftest pcomplete-parse-elisp-arguments-rest
   ;;But this is mostly tested thru `pcomplete-parse-elisp-arguments'

   (  "Situation: Point is at beginning of buffer.
Response: Returns empty list.  Does not loop forever"
      (with-buffer-containing-object
	 (:string "!"
	    :point-replaces "!")
	 
	 (let
	    (args positions)
	    (pcomplete-parse-elisp-arguments-rest)
	    (and
	       (equal args ())))))
   )
;;;_    . Emtest style

(emt:deftest-2 pcomplete-parse-elisp-arguments-rest
   ;;But this is mostly tested thru `pcomplete-parse-elisp-arguments'

   (  "Situation: Point is at beginning of buffer.
Response: Returns empty list.  Does not loop forever"
      (with-buffer-containing-object
	 (:string "!"
	    :point-replaces "!")
	 
	 (let
	    (args positions)
	    (pcomplete-parse-elisp-arguments-rest)
	    (should
	       (equal args ())))))
   )

;;;_  . pcomplete-parse-elisp-arguments

(defun pcomplete-parse-elisp-arguments ()
   ""
   (let
      (  ;;`args' and `positions' will be collected last-first,
	 ;;therefore they will end up in the right order and don't
	 ;;need to be reversed.
	 (args ())
	 (positions ()))

	 (save-excursion
	    (let
	       ((old-point (point)))
	       (pcomplete-skip-whitespace-backwards)
	       ;;If point is in whitespace, consider it a blank arg at
	       ;;the end.
	       (when (< (point) old-point)
		  (push (point) positions)
		  (push "" args)))
	    
	    (pcomplete-parse-elisp-arguments-rest)

	    ;;Always make at least one
	    (when (null positions)
	       (push (point) positions)
	       (push "" args)))
      
      
      (cons args positions)))


;;;_   , Test data

(emt:eg:define xmp:45442297-5ebb-46ac-a7dd-44c5096e1c05
   ((project emt)(library pcmpl-elisp))
   (group ((version old))
      (item ((point-pos 0)) '(! 1   2   3))
      (item ((point-pos 1)) '(  1 ! 2   3))
      (item ((point-pos 2)) '(  1   2 ! 3))
      (item ((point-pos 3)) '(  1   2   3 !))
      (item ((expected-args)) '("1" "2" "3")))

   (group ((version new)(levels single))
      (group ((point-pos 0))
	 (item ((input)) '(! 1   2   3))
	 (item ((expected-args)) '("")))
      (group ((point-pos 0.5)) 
	 (item ((input)) '(1!   2   3))
	 (item ((expected-args)) '("1")))
      (group ((point-pos 1)) 
	 (item ((input)) '(  1 ! 2   3))
	 (item ((expected-args)) '("1" "")))
      (group ((point-pos 2)) 
	 (item ((input)) '(  1   2 ! 3))
	 (item ((expected-args)) '("1" "2" "")))
      (group ((point-pos 3)) 
	 (item ((input)) '(  1   2   3 !))
	 (item ((expected-args)) '("1" "2" "3"))))
   (group ((levels multiple))
      (group ((name 0))
	 (item ((input)) '(1 2 (!a b)))
	 (group ((expected-args))
	    (item ((level outer)) '("1" "2"))
	    (item ((level inner)) '("a" "b")))
	 (item ((max-level)) 1))
      (group ((name 1))
	 (item ((input)) '((!a b)))
	 (group ((expected-args))
	    (item ((level outer)) '(""))
	    (item ((level inner)) '("a" "b")))
	 (item ((max-level)) 1)))
   
   )

;;;_   , Tests

(rtest:deftest pcomplete-parse-elisp-arguments

   (  "Situation: Buffer contains a known form.
Point is after the second sexp.
Response: Reading from each point gives the expected result."
      (emt:eg:narrow
	 ((project emt)(library pcmpl-elisp)(point-pos 0)(version new))
	 (with-buffer-containing-object
	    (:sexp (emt:eg (input))
	       :point-replaces "!")
	 
	    (destructuring-bind
	       (args &rest positions)
	       (pcomplete-parse-elisp-arguments)
	       (and
		  (equal
		     args 
		     (emt:eg:value 
			:ignore-tags ()
			:narrow ((expected-args)))))))))
   
   )
;;;_    . Emtest style
(emt:deftest-2 pcomplete-parse-elisp-arguments

   (  "Situation: Buffer contains a known form.
Point is after the second sexp.
Response: Reading from each point gives the expected result."
      (emt:eg:narrow
	 ((project emt)(library pcmpl-elisp)(point-pos 0)(version new))
	 (with-buffer-containing-object
	    (:sexp (emt:eg (input))
	       :point-replaces "!")
	 
	    (destructuring-bind
	       (args &rest positions)
	       (pcomplete-parse-elisp-arguments)
	       (should
		  (equal
		     args 
		     (emt:eg:value 
			:ignore-tags ()
			:narrow ((expected-args)))))))))
   
   )
;;;_  . pcomplete-try-parse-elisp-uplist

(defun pcomplete-try-parse-elisp-uplist ()
   "
Called with point in a form nested immediately inside the form to
parse."
   (save-excursion
      (let
	 ( ;;`args' and `positions' will be collected last-first,
	    ;;therefore they will end up in the right order and don't
	    ;;need to be reversed.
	    (args ())
	    (positions ()))

	 (up-list -1)
	 (pcomplete-parse-elisp-arguments-rest)
	 (if (null args)
	    (cons '("") (list (point)))
	    (cons args positions)))))


;;;_   , Tests
(rtest:deftest pcomplete-try-parse-elisp-uplist

   ;;Directly called in known context

   ;;As examples, these would have the context
   ;;((project emt)(library pcmpl-elisp)(levels multiple))

   ("Situation: Nested forms, two levels. Point is in an inner form.
Output: A parse of the outer form.  The inner form is not represented
by a point or arg in the outer form."
      (emt:eg:narrow ((project emt)(library pcmpl-elisp)(levels multiple)(name 0))
	 (with-buffer-containing-object
	    (:sexp (emt:eg (input))
	       :point-replaces "!")
	 
	    (destructuring-bind
	       (args &rest positions)
	       (pcomplete-try-parse-elisp-uplist)
	       (and
		  (equal
		     args
		     (emt:eg (expected-args)(level outer))))))))

   
   ("Situation: There is no up position.
Response: Raise a scan-error"  
      (with-buffer-containing-object
	 (:sexp 'bare-!symbol
	    :point-replaces "!")
	 ;;It's a scan-error
	 (emt:gives-error
	    (pcomplete-try-parse-elisp-uplist)
	    scan-error)))

   ("Situation: There is an up position but it has no preceding arguments.
Response: An empty list"  
      (with-buffer-containing-object
	 (:sexp '(1 ! 2)
	    :point-replaces "!")
	 (destructuring-bind
	       (args &rest positions)
	       (pcomplete-try-parse-elisp-uplist)
	       (and
		  (equal
		     args
		     '(""))))))

   ("Situation: Nested forms, two levels. Point is in an inner form.
The outer form is empty except for containing the inner form.
Output: A parse of the outer form.  The inner form is not represented
by a point or arg in the outer form."
      (emt:eg:narrow ((project emt)(library pcmpl-elisp)(levels multiple)(name 1))
	 (with-buffer-containing-object
	    (:sexp (emt:eg (input))
	       :point-replaces "!")
	 
	    (destructuring-bind
	       (args &rest positions)
	       (pcomplete-try-parse-elisp-uplist)
	       (and
		  (equal
		     args
		     (emt:eg (expected-args)(level outer))))))))
   

   ;;Tests of this in situ as used by pcomplete are in test
   ;;`pcomplete'

   )

;;;_    . Emtest style

(emt:deftest-2 pcomplete-try-parse-elisp-uplist

   ;;Directly called in known context

   ;;As examples, these would have the context
   ;;((project emt)(library pcmpl-elisp)(levels multiple))

   ("Situation: Nested forms, two levels. Point is in an inner form.
Output: A parse of the outer form.  The inner form is not represented
by a point or arg in the outer form."
      (emt:eg:narrow ((project emt)(library pcmpl-elisp)(levels multiple)(name 0))
	 (with-buffer-containing-object
	    (:sexp (emt:eg (input))
	       :point-replaces "!")
	 
	    (destructuring-bind
	       (args &rest positions)
	       (pcomplete-try-parse-elisp-uplist)
	       (should
		  (equal
		     args
		     (emt:eg (expected-args)(level outer))))))))

   
   ("Situation: There is no up position.
Response: Raise a scan-error"  
      (with-buffer-containing-object
	 (:sexp 'bare-!symbol
	    :point-replaces "!")
	 ;;It's a scan-error
	 (should
	    (emt:gives-error
	       (pcomplete-try-parse-elisp-uplist)
	       scan-error))))

   ("Situation: There is an up position but it has no preceding arguments.
Response: An empty list"  
      (with-buffer-containing-object
	 (:sexp '(1 ! 2)
	    :point-replaces "!")
	 (destructuring-bind
	       (args &rest positions)
	       (pcomplete-try-parse-elisp-uplist)
	       (should
		  (equal
		     args
		     '(""))))))

   ("Situation: Nested forms, two levels. Point is in an inner form.
The outer form is empty except for containing the inner form.
Output: A parse of the outer form.  The inner form is not represented
by a point or arg in the outer form."
      (emt:eg:narrow ((project emt)(library pcmpl-elisp)(levels multiple)(name 1))
	 (with-buffer-containing-object
	    (:sexp (emt:eg (input))
	       :point-replaces "!")
	 
	    (destructuring-bind
	       (args &rest positions)
	       (pcomplete-try-parse-elisp-uplist)
	       (should
		  (equal
		     args
		     (emt:eg (expected-args)(level outer))))))))
   

   ;;Tests of this in situ as used by pcomplete are in test
   ;;`pcomplete'

   )
;;;_ , Elisp functions that are parameters to pcomplete

;;;_  . pcomplete-elisp-data->command-name
(defun pcomplete-elisp-data->command-name (data)
   ""
   (pcomplete-arg 'first nil data))


;;;_  . pcomplete-elisp-default-completion-function
(defalias 'pcomplete-elisp-default-completion-function 'ignore)

;;;_  . The pcomplete-command-completion-function

;;;_   , pcomplete-elisp-command-names-list (Variable)
(defvar pcomplete-elisp-command-names-list ()
   "List of Elisp function names as strings, for pcomplete.
Interested modules can add to the list" )
;;;_   , pcomplete-elisp-command-names-list (Function, returns the var)
(defun pcomplete-elisp-command-names-list ()
   "Returns `pcomplete-elisp-command-names-list'"
   pcomplete-elisp-command-names-list)

;;;_   , pcomplete-elisp-command-names-hook 
(defvar pcomplete-elisp-command-names-hook 
   (list #'pcomplete-elisp-command-names-list)
   "List of functions that return Elisp functor names for pcomplete.
Interested modules can add to this hook.
Each function here should return a list of functors" )

;;;_   , pcomplete-elisp-get-command-names
(defun pcomplete-elisp-get-command-names ()
   "For completing the initial command argument in pcomplete"
   ;;Flatten the returned list of lists by 1 ply
   (apply #'append 
      (mapcar #'funcall pcomplete-elisp-command-names-hook)))

;;;_ , Elisp setup 

;;;_  . pcomplete-elisp-setup
;;;###autoload
(defun pcomplete-elisp-setup ()
   "Setup the purely Elisp support.
Used both in testing and in setup."
   '(progn
       (set (make-local-variable 'pcomplete-parse-arguments-function)
	  #'pcomplete-parse-elisp-arguments)
       (set (make-local-variable 'pcomplete:level->command-name)
	  #'pcomplete-elisp-data->command-name)
       (set (make-local-variable 'pcomplete-command-completion-function)
	  #'pcomplete-elisp-get-command-names)
       (set (make-local-variable 'pcomplete-default-completion-function)
	  #'pcomplete-elisp-default-completion-function)
       (set (make-local-variable 'pcomplete-parse-uplist)
	  #'pcomplete-try-parse-elisp-uplist)
       (set (make-local-variable 'pcomplete-use-uplist) 
	  t)
       (setq
	  pcomplete-default-nesting-pre/suffix '("("")")))
   

   (setq 
      pcomplete-parse-arguments-function
      #'pcomplete-parse-elisp-arguments

      pcomplete:level->command-name
      #'pcomplete-elisp-data->command-name

      pcomplete-command-completion-function
      #'pcomplete-elisp-get-command-names

      pcomplete-default-completion-function
      #'pcomplete-elisp-default-completion-function

      pcomplete-parse-uplist
      #'pcomplete-try-parse-elisp-uplist

      pcomplete-use-uplist
      t

      pcomplete-default-nesting-pre/suffix
      '("("")")))
   


;;;_  .Insinuate it

;;;###autoload (add-hook 'emacs-lisp-mode-hook #'pcomplete-elisp-setup)
;;;###autoload (define-key emacs-lisp-mode-map [(ctrl tab)] #'pcomplete)

;;;_ , Test helper functions
;;;_  . Shared helper-helpers

;;;_   , pcomplete:th:0  
(defun pcomplete:th:0 (sexp mode-setup known-heads flets body)

   ""

   `
   (with-buffer-containing-object
      (:sexp ,sexp :point-replaces "!")
      ,mode-setup
      (let
	 (
	    ;;Control what function names are known
	    (pcomplete-elisp-command-names-hook
	       (list #'pcomplete-elisp-command-names-list))
	    (pcomplete-elisp-command-names-list ',known-heads)
	    ;;By default, use uplist (Can be turned off by letting it
	    ;;nil around BODY)
	    (pcomplete-use-uplist t)
	    ;;Use cycling.
	    (pcomplete-cycle-completions t)
	    ;;Don't show list interactively even when it's long.
	    (pcomplete-cycle-cutoff-length 1000))
	 (flet
	    (,@flets)
	    ,@body))))

;;;_   , pcomplete:th:check-completions-form

(defun pcomplete:th:check-completions-form (completions stub)
   ""
   ;;Mock is just used to test that it was was.  Mock can't compare sets.

   `(with-mock 
       (mock (reached))
       (emt:testpoint:eval
	  (pcomplete-list)
	  (tp pcomplete:tp:see-completions (stub-got completions-got)
	     (reached)
	     ,(if stub
		 `(assert (equal stub-got ,stub) t))
	     (assert
		(rtest:sets= 
		   (pcomplete:canon-list->string-list completions-got) 
		   ,completions) 
		t)
	     (throw 'pcompleted nil)))
       t))




;;;_   , pcomplete:th:assert-position
(defun* pcomplete:th:assert-position (&key index level current-arg)
   ""
   (when index
      (assert
	 (equal pcomplete-index index) t))
   (when level
      (assert
	 (equal pcomplete:level-index level) t))
   (when current-arg
      (assert
	 (equal (pcomplete-arg) current-arg) t)))


;;;_    . Tests
(put 'pcomplete:th:assert-position 'rtest:test-thru
   'pcomplete)
;;;_   , pcomplete:th:assert-num-levels
(defun pcomplete:th:assert-num-levels (num-levels)
   ""

   (assert
      (equal
	 pcomplete:max-level
	 (-1 num-levels))))

;;;_   , pcomplete:th:assert-parse-level

(defun pcomplete:th:assert-parse-level (max-level expected-args)
   ""
   ;;Similar to `pcomplete:th:assert-num-levels', but intentionally
   ;;about parsing state, not current number of levels.
   (assert
      (equal pcomplete:max-level max-level)
      t)
   (assert
      (equal
	 (mapcar
	    #'pcomplete-string->sexp
	    (pcomplete:level->args
	       (nth pcomplete:max-level pcomplete:level-list)))
	 expected-args)
      t))


;;;_  . pcomplete:th:test - Test helper for testing completing functions.

(defmacro* pcomplete:th:test
   (&key sexp stub completions known-heads)
   ""

   (pcomplete:th:0
      sexp 
      '(progn
	  (emacs-lisp-mode)
	  ;;`emacs-lisp-mode' will imply setup, but we don't want to
	  ;;assume that the autoload exists so we set up manually.
	  (pcomplete-elisp-setup))
      known-heads 
      () 
      ;;Check that actual completions match.
      (list
	 (pcomplete:th:check-completions-form completions stub))))

;;;_  . Test helpers
;;;_   , pcomplete:th:usuals-f
;;Obsoleted by pcomplete:th:usuals-f2

;;;_   , pcomplete:th:usuals-f2

(defun pcomplete:th:usuals-f2 (sexp heads head1-body body)
   "SEXP is a form giving the sexp for the buffer.
HEADS is a form giving the list of heads as strings.
HEAD1-BODY is a list of forms of a completer.  It is implicitly in a
`progn'.
BODY is a list of body forms.
NB, this deals with forms, not data.
"

   (pcomplete:th:0
      sexp 
      '(progn
	  ;;Set up manually, don't depend on what elisp mode has or
	  ;;does. 
	  (setq major-mode 'invalid-mode)
	  (pcomplete-elisp-setup))
      heads
      ;;The completer for "head1" is always available to these
      ;;tests. The completer for "head2" is also set by some callers,
      ;;but not through here.
      `((pcomplete/invalid-mode/head1 () ,@head1-body))
      body))


;;;_   , pcomplete-list:th
(defmacro* pcomplete-list:th 
   (      
      &key 
      sexp 
      stub 
      (cmpl-lol
	 ''(
	     ("head1" "head2")
	     ("xyz" "xxoo")))
      (expect-which 'heads))
   ""
   (let
      ((lol (eval cmpl-lol))
	 (index
	    (case expect-which
	       (heads 0)
	       (bodies 1)
	       (other 2))))
      
      (pcomplete:th:usuals-f2 
	 sexp 
	 (first lol) 
	 `((pcomplete-here ',(second lol))) 
	 (list
	    (pcomplete:th:check-completions-form 
	       `',(nth index lol) 
	       stub)))))



;;;_    . Tests of test-helper
(put 'pcomplete-list:th 'rtest:test-thru
   'pcomplete-list)
;;;_   , Tests of pcomplete-list

(rtest:deftest pcomplete-list

   ;;Use examples to make more of these tests.  Put point at different
   ;;places.
   (  "Situation: Point is at the end of arg zero (the functor).
Command: `pcomplete-list'
Response: Gives the completions of arg zero."

      (pcomplete-list:th
	 :sexp '(head!) :stub "head"))

   (  "Situation: Point is before any text.
There is no head before point.
Command: `pcomplete-list'
Response: Gives the completions of arg zero."

      (pcomplete-list:th
	 :sexp '(!) :expect-which heads))

   (  "Situation: Point is after the functor.
Command: `pcomplete-list'
Response: Gives the completions of arg one."

      (pcomplete-list:th
	 :sexp '(head1 !) :expect-which bodies))

   )
;;;_    . Emtest style

;;$$Doesn't work because there's no "should" in it.
(emt:deftest-2 pcomplete-list

   ;;Use examples to make more of these tests.  Put point at different
   ;;places.
   (  "Situation: Point is at the end of arg zero (the functor).
Command: `pcomplete-list'
Response: Gives the completions of arg zero."

      (pcomplete-list:th
	 :sexp '(head!) :stub "head"))

   (  "Situation: Point is before any text.
There is no head before point.
Command: `pcomplete-list'
Response: Gives the completions of arg zero."

      (pcomplete-list:th
	 :sexp '(!) :expect-which heads))

   (  "Situation: Point is after the functor.
Command: `pcomplete-list'
Response: Gives the completions of arg one."

      (pcomplete-list:th
	 :sexp '(head1 !) :expect-which bodies))

   )

;;;_   , pcomplete:th
;;This is now just a wrapper around `pcomplete:th:usuals-f'
(defmacro* pcomplete:th 
   (      
      (&key 
	 sexp 
	 (cmpl-lol
	    ''(
		 ("head1" "head2")
		 ("xyz" "xxoo"))))
      
      &rest body)
   ""
   '  ;;$$Obsolete
   (pcomplete:th:usuals-f sexp (eval cmpl-lol) body)

   (let
      ((lol (eval cmpl-lol)))
      (pcomplete:th:usuals-f2 
	 sexp 
	 (first lol) 
	 `((pcomplete-here ',(second lol)))
	 body)))


;;;_    . Tests of test helper
(put 'pcomplete:th 'rtest:test-thru
   'pcomplete)
;;;_   , pcomplete:th:check-parse

(defmacro* pcomplete:th:check-parse
   (      
      (&key 
	 sexp 
	 stub
	 (cmpl-lol
	    ''(
		 ("head1" "head2")
		 ("xyz" "xxoo")))
	 max-level
	 expected-args
	 current-level
	 current-index)
      
      &rest body)
   ""
   '  ;;$$Obsolete
   (pcomplete:th:usuals-f sexp (eval cmpl-lol)
      (list
	 `(flet
	     (
		;;We want the completer to be findable but we don't
		;;want to use it yet, since it would make these tests
		;;dependent on `pcomplete-nested' and on the exact
		;;input form.  So we don't let it do much of anything.
		(pcomplete/invalid-mode/head2 ()
		   nil))

	     (emt:testpoint:eval
		(progn ,@body)
		(tp pcomplete:tp:get-completions ()
		   ;;Call the real function and catch any throws
		   ;;from inside it.
		   (catch 'pcompleted
		      (pcomplete-completions))

		   ;;These variables have to be tested inside
		   ;;pcomplete, because they are `let' and are
		   ;;always `nil' outside.  Since we don't have
		   ;;shoulds here yet, we use asserts
		   (pcomplete:th:assert-parse-level 
		      ,max-level 
		      ,expected-args)


		   (pcomplete:th:assert-position
		      :index ,current-index
		      :level ,current-level)

		   ;;Now throw so we don't go further.  That's
		   ;;coupled to internal logic, but less than the
		   ;;interpretation of a return value would be.
		   (throw 'pcompleted nil)))
		
	     ;;If we didn't error in the internal tests, we're OK.
	     t)))

   (let
      ((lol (eval cmpl-lol)))
      (pcomplete:th:usuals-f2 
	 sexp 
	 (first lol) 
	 ;;We want the completer to be findable but we don't want to
	 ;;use it yet, since it would make these tests dependent on
	 ;;`pcomplete-nested' and on the exact input form.  So we
	 ;;don't let it do much of anything.
	 '() 
	 `(
	     (emt:testpoint:eval
		(progn ,@body)
		(tp pcomplete:tp:get-completions ()
		   ;;Call the real function and catch any throws
		   ;;from inside it.
		   (catch 'pcompleted
		      (pcomplete-completions))

		   ;;These variables have to be tested inside
		   ;;pcomplete, because they are `let' and are
		   ;;always `nil' outside.  Since we don't have
		   ;;shoulds here yet, we use asserts
		   (pcomplete:th:assert-parse-level 
		      ,max-level 
		      ,expected-args)


		   (pcomplete:th:assert-position
		      :index ,current-index
		      :level ,current-level)

		   ;;Now throw so we don't go further.  That's
		   ;;coupled to internal logic, but less than the
		   ;;interpretation of a return value would be.
		   (throw 'pcompleted nil)))
		
	     ;;If we didn't error in the internal tests, we're OK.
	     t))))



;;;_    . Tests

(put 'pcomplete:th:check-parse 'rtest:test-thru
   'pcomplete)

;;;_   , pcomplete:th:with-nil-completer
(defmacro* pcomplete:th:with-nil-completer
   (      
      (&key 
	 sexp 
	 (cmpl-lol
	    ''(
		("head1" "head2")
		("xyz" "xxoo")))
	 max-level
	 expected-args)
      &rest body)
   ""
   '  ;;$$Obsolete
   (pcomplete:th:usuals-f sexp (eval cmpl-lol)
      (list
	 `(flet
	     (
		;;We want this to be findable but we don't want to use
		;;it yet, since its functionality is intercepted by a
		;;testpoint. 
		(pcomplete/invalid-mode/head1 ()
		   nil))
	     (emt:testpoint:eval
		(pcomplete)
		(tp pcomplete:tp:call-walker ()

		   ;;Validate that we've parsed to what we thought we
		   ;;did.
		   (pcomplete:th:assert-parse-level 
		      ,max-level 
		      ,expected-args)

		   ,@body

		   ;;Now throw so we don't go further.
		   (throw 'pcompleted nil)))

	     ;;If we didn't error in the testpoint call, we
	     ;;passed. 
	     t)))

   (pcomplete:th:usuals-f2 
      sexp
      '()
      ;;We want the completer to be findable but we don't want to use
      ;;it yet, since its functionality is intercepted by a testpoint.
      '()
      `(
	  (emt:testpoint:eval
	     (pcomplete)
	     (tp pcomplete:tp:call-walker ()

		;;Validate that we've parsed to what we thought we
		;;did.
		(pcomplete:th:assert-parse-level 
		   ,max-level 
		   ,expected-args)

		,@body

		;;Now throw so we don't go further.
		(throw 'pcompleted nil)))

	     ;;If we didn't error in the testpoint call, we
	     ;;passed. 
	     t)))


;;;_    . Tests

(put 'pcomplete:th:with-nil-completer 'rtest:test-thru
   'pcomplete-nested)

;;;_   , pcomplete:th:with-full-completer

(defmacro* pcomplete:th:with-full-completer 
   ((&key sexp) &rest body)
   ""
   '  ;;$$Obsolete
   (pcomplete:th:usuals-f sexp '(()())
      (list
	 `(flet
	     ;;For instance, matches '(head2 (a def))
	     ((pcomplete/invalid-mode/head1 ()
		 (dotimes (i 2)
		    (pcomplete-here
		       '(
			   ;;Sole element of the overall list
			   ("()" 
			      nested   ;;Indicate we're nesting
			      ("("")") ;;The prefix and suffix
			      ;;The nested form - a lambda form
			      (lambda ()
				 (pcomplete-here '("a"))
				 (pcomplete-here '("def")))))))))
	     
	     ,@body)))
   
   (pcomplete:th:usuals-f2 
      sexp
      '()
      '((dotimes (i 2)
	   (pcomplete-here
	      '(
		  ;;Sole element of the overall list
		  ("()" 
		     nested ;;Indicate we're nesting
		     ("("")") ;;The prefix and suffix
		     ;;The nested form - a lambda form
		     (lambda ()
			(pcomplete-here '("a"))
			(pcomplete-here '("def"))))))))
      body))


;;;_    . Tests
(put 'pcomplete:th:with-full-completer 'rtest:test-thru
   'pcomplete-nested)

;;;_   , pcomplete:th:with-abbrev-completer
(defmacro* pcomplete:th:with-abbrev-completer
   ((&key sexp) &rest body)
   "Same as `pcomplete:th:with-full-completer' except using
`pcomplete-nested' to abbreviate the form."
   '  ;;$$Obsolete
   (pcomplete:th:usuals-f sexp '(()())
      (list
	 `(flet
	     ;;For instance, matches '(head2 (a def))
	     ((pcomplete/invalid-mode/head1 ()
		 (dotimes (i 2)
		    (pcomplete-nested
		       (pcomplete-here '("a"))
		       (pcomplete-here '("def"))))))
	     
	     ,@body)))

   (pcomplete:th:usuals-f2 
      sexp
      '()
      '((dotimes (i 2)
	   (pcomplete-nested
	      (pcomplete-here '("a"))
	      (pcomplete-here '("def")))))
      body))
;;;_   , pcomplete:th:with-arged-completer

(defmacro* pcomplete:th:with-arged-completer ((&key sexp) &rest body)
   ""
   
   (pcomplete:th:usuals-f2 
      sexp
      '("head1")
      '((pcomplete-here 
	   ;;Completion list, just a nested element
	   '(
	       ("()" 
		  nested
		  nil
		  ;;The nested form - a lambda form
		  (lambda (ab)
		     (pcomplete-here ab))))
	   ;;Args that are not used in this test.
	   nil nil nil
	   ;;Arglist passed in
	   '(("a" "b"))))
      body))



;;;_   , pcomplete:th:5
'  ;;Obsolete
(defmacro* pcomplete:th:5 ((&key max-level expected-args) &rest body)
   ""
   (error "Don't call pcomplete:th:5 any more")
   `(emt:testpoint:eval
       (pcomplete)
       (tp pcomplete:tp:call-walker ()

	  ;;Validate that we've parsed to what we thought we did.
	  (assert
	     (equal pcomplete:max-level ,max-level) t)
	  (assert
	     (equal
		(pcomplete:level->args
		   (nth pcomplete:max-level 
		      pcomplete:level-list))
		,expected-args)
	     t)

	  ,@body

	  ;;Now throw so we don't go further.
	  (throw 'pcompleted nil))))

;;;_    . Tests
(put 'pcomplete:th:5 'rtest:test-thru
   'pcomplete-nested)

;;;_ , Tests of `pcomplete'
(rtest:deftest pcomplete

   
   ;;Test that it subtitutes.
   
   (  "Situation: Point is at the end of arg zero (the functor).
Command: `pcomplete'
Response: Completes arg zero with the first completion."

      (pcomplete:th
	 (:sexp '(head!))
	 (pcomplete)
	 (mockbuf:buf-contents-matches :sexp '(head1))))

   (  "Situation: Point is after the functor.
Command: `pcomplete'
Response: Completes arg one with its first completion."

      (pcomplete:th
	 (:sexp '(head1 !))
	 (pcomplete)
	 (mockbuf:buf-contents-matches :sexp '(head1 xyz))))
   
   ;;Test that it cycles

   (  "Situation: Point is at the end of arg zero (the functor).
Cycling is on.  Command `pcomplete' was just given.
Command: `pcomplete'
Response: Completes arg zero with the second completion."

      (pcomplete:th
	 (:sexp '(head!))
	 (pcomplete)
	 (let ((last-command 'pcomplete)) (call-interactively #'pcomplete))
	 (mockbuf:buf-contents-matches :sexp '(head2))))

   (  "Situation: Point is after the functor.
Cycling is on.  Command `pcomplete' was just given.
Command: `pcomplete'
Response: Completes arg one with its second completion."

      (pcomplete:th
	 (:sexp '(head1 !))
	 (pcomplete)
	 (let ((last-command 'pcomplete)) (call-interactively #'pcomplete))
	 (mockbuf:buf-contents-matches :sexp '(head1 xxoo))))
   
   ;;It accepts string in list too.

   (  "Situation: Point is after the functor.
Cycling is on.  Command `pcomplete' was just given.
Command: `pcomplete'
Response: Completes arg one with its second completion."

      (pcomplete:th
	 (:sexp '(head1 !)
	    :cmpl-lol
	    '(
		("head1" "head2")
		;;String in list
		(("xyz") ("xxoo"))))
	 (pcomplete)
	 (let ((last-command 'pcomplete)) (call-interactively #'pcomplete))
	 (mockbuf:buf-contents-matches :sexp '(head1 xxoo))))



   ;;`pcomplete' and parse-uplist.

   (  "Situation: The immediate functor is not recognized.
The next containing functor is recognized.
The text is well short of the parse-backwards window.
The flag `pcomplete-use-uplist' is true.
Response: The next outer level is parsed."
      (emt:eg:narrow ((project emt)(library pcmpl-elisp)(levels multiple))
	 (pcomplete:th:check-parse
	    (:sexp '(head1 (a ! )) 
	       :max-level 1
	       :expected-args '(head1)
	       :current-level 1
	       :current-index 1)
	    (pcomplete))))
   
   (  "Situation: There are multiple levels
The immediate functor and the next 2 containing functors are not recognized.
The third containing functor is recognized.
The text is well short of the parse-backwards window.
The flag `pcomplete-use-uplist' is true.
Response: The levels are parsed to the third containing scope."
      (emt:eg:narrow ((project emt)(library pcmpl-elisp)(levels multiple))
	 (pcomplete:th:check-parse
	    (:sexp '(head1 (c (b (a ! )))) 
	       :max-level 3
	       :expected-args '(head1)
	       :current-level 3
	       :current-index 1)
	    (pcomplete))))
   

   
   (  "Situation: There are multiple levels
Only first containing functor is recognized.
The text is well short of the parse-backwards window.
The flag `pcomplete-use-uplist' is true.
Response: The levels are parsed to the first containing scope."
      (emt:eg:narrow ((project emt)(library pcmpl-elisp)(levels multiple))
	 (pcomplete:th:check-parse
	    (:sexp ' (c (b (head1 (a ! )))) 
	       :max-level 1
	       :expected-args '(head1)
	       :current-level 1
	       :current-index 1)
	    (pcomplete))))
   


   ;;If the functor has no completions, look uplist

   (  "Situation: Point is on the non-blank first element - ie, on the
functor. 
The functor cannot be completed.
The next containing functor is recognized.
The text is well short of the parse-backwards window.
The flag `pcomplete-use-uplist' is true.
Response: The next outer level is parsed."
      (emt:eg:narrow ((project emt)(library pcmpl-elisp)(levels multiple))
	 (pcomplete:th:check-parse
	    (:sexp '(head1 (unrecognized! )) 
	       :max-level 1
	       :expected-args '(head1)
	       :current-level 1
	       :current-index 1)
	    (pcomplete))))

   ( "Situation: Point is on a blank first element - ie, in a blank
inner list (as far as we see it).
The flag `pcomplete-use-uplist' is true.
Response: The next outer level is parsed."
      (emt:eg:narrow ((project emt)(library pcmpl-elisp)(levels multiple))
	 (pcomplete:th:check-parse
	    (:sexp '(head1 (!)) 
	       :max-level 1
	       :expected-args '(head1)
	       :current-level 1
	       :current-index 1)
	    (pcomplete))))

   ( "Situation: Point is on a blank first element - ie, in a blank
inner list (as far as we see it).
The next level is a blank list too.
The flag `pcomplete-use-uplist' is true.
Response: The next outer level is parsed."
      (emt:eg:narrow ((project emt)(library pcmpl-elisp)(levels multiple))
	 (pcomplete:th:check-parse
	    (:sexp '(head1 ((!)))
	       :max-level 2
	       :expected-args '(head1)
	       :current-level 2
	       :current-index 1)
	    (pcomplete))))


   (  "Situation: The immediate functor is not recognized.
The text is well short of the parse-backwards window.
The flag `pcomplete-use-uplist' is nil.
Response: Only the inner level is parsed."
      (emt:eg:narrow ((project emt)(library pcmpl-elisp)(levels multiple))
	 (pcomplete:th:check-parse
	    (:sexp '(head1 (a ! )) 
	       :max-level 0
	       :expected-args '(a !)
	       :current-level 0
	       :current-index 1)
	    (let ((pcomplete-use-uplist nil))
	       (pcomplete))
		  ;;If we didn't error in the internal tests, we're
		  ;;OK.
		  t)))

   
   (  "Situation: The immediate functor is recognized.
The next containing functor is recognized.
The text is well short of the parse-backwards window.
The flag `pcomplete-use-uplist' is true.
Response: Only the inner level is parsed.
`pcomplete-try-parse-elisp-uplist' is not called."
      (emt:eg:narrow ((project emt)(library pcmpl-elisp)(levels multiple))
	 (pcomplete:th:check-parse
	    (:sexp '(head1 !) 
	       :max-level 0
	       :expected-args '(head1 !)
	       :current-level 0
	       :current-index 1)
	    (with-mock
	       (not-called pcomplete-try-parse-elisp-uplist)
	       (pcomplete)
	       ;;If we didn't error in the internal tests, we're OK.
	       t))))
   
   (  "Situation: The immediate functor is not recognized.
Trying to parsing the next level gives a scan-error.
The flag `pcomplete-use-uplist' is true.
Response: Only the inner level is parsed."
      (emt:eg:narrow ((project emt)(library pcmpl-elisp)(levels multiple))
	 (pcomplete:th:check-parse
	    (:sexp '(a !) 
	       :max-level 0
	       :expected-args '(a !)
	       :current-level 0
	       :current-index 1)
	    (let (
		    (pcomplete-parse-uplist
		       #'(lambda (&rest dummy)
			    (signal 'scan-error 
			       "This test mocks
`pcomplete-try-parse-elisp-uplist' to always throw this error") 
			    )))
	       (pcomplete))
	    ;;If we didn't error in the internal tests, we're OK.
	    t)))

   (  "Situation: There is no function to parse uplist -
`pcomplete-parse-uplist' is unbound.
Response: Just parse the single level."
      (emt:eg:narrow ((project emt)(library pcmpl-elisp)(levels multiple))
	 (pcomplete:th:check-parse
	    (:sexp '(head1 (a ! )) 
	       :max-level 0
	       :expected-args '(a !)
	       :current-level 0
	       :current-index 1)
	    (let ( (pcomplete-parse-uplist nil))
	       (pcomplete))
		  ;;If we didn't error in the internal tests, we're
		  ;;OK.
		  t))))


;;;_ , Tests of pcomplete-nested
(rtest:deftest pcomplete-nested

   ;;Test that `pcomplete-nested' moves correctly.
   ;;These tests are in procedural style.

   (  "Situation: There is an arg in outer scope, plus the functor.
Test `pcomplete-nested' up to and past the end of outer scope."
      (pcomplete:th:with-nil-completer
	 (:sexp '(head1 g (a ! ))
	    :max-level 1 
	    :expected-args '(head1 g))
	 
	 ;;Situation: Index is at the beginning of outer scope (arg 1)
	 (pcomplete:th:assert-position
	    :level 1
	    :index 1
	    :current-arg "g")

	 ;;Operation: `pcomplete-nested'

	 ;;Behavior: Moves one step, to past the end.  Returns,
	 ;;does not throw.
	 (assert
	    (not
	       (emt:throws 'pcompleted
		  (pcomplete-nested 
		     (error "Not reached")))))

	 ;;Situation: Position is beyond the last arg in outer
	 ;;scope.
	 (pcomplete:th:assert-position
	    :level 1
	    :index 2)
	    
	 ;;Operation: `pcomplete-nested' again.
	 ;;Behavior: It evals its `form-for-descent' argument at
	 ;;the beginning of the next inner level.  It does not
	 ;;throw the result, although the form itself may throw.

	 ;;Poor-man's `emt:reaches' (not yet available)
	 ;;$$It is now.
	 '
	 (with-mock
	    (mock (reached))
	    (assert
	       (not
		  (emt:throws 'pcompleted
		     (pcomplete-nested  
			;;Situation: Now we are at the beginning of
			;;the inner scope.
			(progn
			   ;;Test that we reached this point.
			   (reached)
			   (pcomplete:th:assert-num-levels 2)
			   (pcomplete:th:assert-position
			      :level 0
			      :index 0)))))))))
   


   (  "Situation: There is an arg in outer scope, plus the functor.
Test `pcomplete-nested' up to the end of an inner scope."
      (pcomplete:th:with-nil-completer
	 (:sexp '(head1 g !)
	    :max-level 0 
	    :expected-args '(head1 g !))
	 
	 ;;Situation: Index is in inner scope (arg 1)
	 (pcomplete:th:assert-position
	    :level 0
	    :index 1
	    :current-arg "g")

	 ;;Operation: `pcomplete-nested'
	 ;;Behavior: Moves to the next arg.
	 (pcomplete-nested 
	    (error "Not reached"))

	 ;;Situation: Position is in inner scope, arg 2 (last arg)
	 (pcomplete:th:assert-position
	    :level 0
	    :index 2
	    :current-arg "")
	    
	 ;;Operation: `pcomplete-nested'
	 ;;Behavior: It creates a new nested scope (How to test this?)
	 '
	 (with-mock
	    (mock (reached))
	    (emt:assert-throws 'pcomplete-completions
	       (pcomplete-nested 
		  (progn
		     (reached)
		     ;;There's a new deeper scope.
		     (pcomplete:th:assert-num-levels 3)
		     ;;We are at the beginning of that scope
		     (pcomplete:th:assert-position
			:level 0
			:index 0
			:current-arg ""))))
	    )))
   
   (  "Situation: There is an arg in outer scope, plus the functor.
The existing arg is a list, not an atom.
Test `pcomplete-nested' up to the end of an inner scope."
      (pcomplete:th:with-nil-completer
	 (:sexp '(head1 (i j) !)
	    :max-level 0 
	    :expected-args '(head1 (i j) !))
	 
	 ;;Situation: Index is in inner scope (arg 1)
	 (pcomplete:th:assert-position
	    :level 0
	    :index 1
	    :current-arg "(i j)")

	 ;;Operation: `pcomplete-nested'
	 ;;Behavior: Moves to the next arg.
	 (pcomplete-nested 
	    (error "Not reached"))

	 ;;Situation: Position is in inner scope, arg 2 (last arg)
	 (pcomplete:th:assert-position
	    :level 0
	    :index 2
	    :current-arg "")
	    
	 ;;Operation: `pcomplete-nested'
	 ;;Behavior: It throws the result of evalling its
	 ;;`form-if-empty' argument at the current position, ie
	 ;;last arg in inner scope.
	 '
	 (with-mock
	    (mock (reached))
	    (emt:assert-throws 'pcomplete-completions
	       (pcomplete-nested 
		  (progn
		     (reached)
		     ;;There's a new deeper scope.
		     (pcomplete:th:assert-num-levels 3)
		     ;;We are at the beginning of that scope
		     (pcomplete:th:assert-position
			:level 0
			:index 0
			:current-arg "")))))))
   

   ;;Tests of `pcomplete-nested' in situ.

   ;;Test that the walker function gets called.
   (  "Situation: 
Point is at a blank second element in the outer form of `head2' - the
inner form does not already exist.

Behavior: The expected walker function gets called."
      (pcomplete:th
	 (:sexp '(head2 !))
	 (with-mock
	    (mock (pcomplete/invalid-mode/head2))
	    (pcomplete))
	 t))
   
   ( "Situation: Point is at a blank first element in an inner form,
which is second element in an outer form of `head2'

Behavior: The expected walker function gets called."
      (pcomplete:th
	 (:sexp '(head2 (!)))
	 (with-mock
	    (mock (pcomplete/invalid-mode/head2))
	    (pcomplete))
	 t))

   ( "Situation: Point is at a blank second element in an inner form,
which is second element in an outer form of `head2'

Behavior: The expected walker function gets called."
      (pcomplete:th
	 (:sexp '(head2 (a !)))
	 (with-mock
	    (mock (pcomplete/invalid-mode/head2))
	    (pcomplete))
	 t))


   ;;Test that the walker function alters the buffer appropriately.


   ( "Situation: The walker function contains a nested completion in
first arg position.  The nested function contains no `pcomplete-here'
forms, it just returns nil.

The descent form is explicitly given.

Point is at a blank second element in the outer form of `head1' - the
inner form does not already exist.

The flag `pcomplete-use-uplist' is true.

Response: The inner form is created, empty."
      (pcomplete:th
	 (:sexp '(head1 !)
	    :cmpl-lol
	    '(("head1")
		(  
		   ("()" nested nil ignore))))
	 (pcomplete)
	 (mockbuf:buf-contents-matches 
	    :sexp '(head1 ()))))

   ( "Situation: The walker function contains a nested completion in
first arg position.  The nested function contains two `pcomplete-here'
forms.
The descent form is explicitly given.

Point is at a blank second element in the outer form of `head1' - the
inner form does not already exist.

The flag `pcomplete-use-uplist' is true.

Response: The inner form is created, empty."
      (pcomplete:th:with-full-completer
	 (:sexp '(head1 !))
	 (pcomplete)
	 (mockbuf:buf-contents-matches 
	    :sexp '(head1 (a)))))
      

   ( "Situation: The walker function contains a nested completion in
first arg position.  The nested function contains two `pcomplete-here'
forms.

Point is at a blank first element in an inner form, which is second
element in an outer form of `head1'

The flag `pcomplete-use-uplist' is true.

Response: The first argument of inner form is completed accordingly."
      
      (pcomplete:th:with-full-completer
	 (:sexp '(head1 (!)))
	 (pcomplete)
	 (mockbuf:buf-contents-matches 
	    :sexp '(head1 (a)))))
   

   ( "Situation: The walker function contains a nested completion in
first arg position.  The nested function contains two `pcomplete-here'
forms.

Point is at a blank second element in an inner form, which is second
element in an outer form of `head1'
The flag `pcomplete-use-uplist' is true.
Response: The second argument of inner form is completed accordingly."
      (pcomplete:th:with-full-completer
	 (:sexp '(head1 (a !)))
	 (pcomplete)
	 (mockbuf:buf-contents-matches 
	    :sexp '(head1 (a def)))))
   
   ( "Situation: The walker function contains a nested completion in
first arg position.  The nested completer contains two
`pcomplete-here' forms.  The nested completer is itself run twice.

Point is at a blank second element in an inner form, which is the
third element in an outer form of `head1'

The flag `pcomplete-use-uplist' is true.
Response: The second argument of inner form is completed accordingly."
      (pcomplete:th:with-full-completer
	 (:sexp '(head1 (a def) (a !)))
	 (pcomplete)
	 (mockbuf:buf-contents-matches 
	    :sexp '(head1 (a def) (a def)))))

   ;;Test the `pcomplete-nested' abbreviation

   ;;$$Not clear that this should result in an empty inner form.
   ;;Perhaps with a completer that wants an empty inner form.
   ( "Situation: The walker function contains `pcomplete-nested' in
first arg position.  The nested function contains two `pcomplete-here'
forms.
The descent form is explicitly given.

Point is at a blank second element in the outer form of `head1' - the
inner form does not already exist.

The flag `pcomplete-use-uplist' is true.

Response: The inner form is created."
      (pcomplete:th:with-abbrev-completer
	 (:sexp '(head1 !))
	 (pcomplete)
	 (mockbuf:buf-contents-matches 
	    :sexp '(head1 (a)))))
      

   ( "Situation: The walker function contains `pcomplete-nested' in
first arg position.  The nested function contains two `pcomplete-here'
forms.

Point is at a blank first element in an inner form, which is second
element in an outer form of `head1'

The flag `pcomplete-use-uplist' is true.

Response: The first argument of inner form is completed accordingly."
      
      (pcomplete:th:with-abbrev-completer
	 (:sexp '(head1 (!)))
	 (pcomplete)
	 (mockbuf:buf-contents-matches 
	    :sexp '(head1 (a)))))
   

   ( "Situation: The walker function contains `pcomplete-nested' in
first arg position.  The nested function contains two `pcomplete-here'
forms.

Point is at a blank second element in an inner form, which is second
element in an outer form of `head1'
The flag `pcomplete-use-uplist' is true.
Response: The second argument of inner form is completed accordingly."
      (pcomplete:th:with-abbrev-completer
	 (:sexp '(head1 (a !)))
	 (pcomplete)
	 (mockbuf:buf-contents-matches 
	    :sexp '(head1 (a def)))))
   
   ( "Situation: The walker function contains `pcomplete-nested' in
first arg position.  The nested completer contains two
`pcomplete-here' forms.  The nested completer is itself run twice.

Point is at a blank second element in an inner form, which is the
third element in an outer form of `head1'

The flag `pcomplete-use-uplist' is true.
Response: The second argument of inner form is completed accordingly."
      (pcomplete:th:with-abbrev-completer
	 (:sexp '(head1 (a def) (a !)))
	 (pcomplete)
	 (mockbuf:buf-contents-matches 
	    :sexp '(head1 (a def) (a def)))))


   ;;Nesteds and non-nesteds can be alternatives

   (  "Situation: Alternatives contain both a nested and a non-nested.
Nested has a name that is not the descent form itself.
First arg of nested is something other than the descent form.
Operation: List them.
Response: Both are on the list.  Nested appears as the prefix+suffix.
Proves: Nested are displayed reasonably."
      (pcomplete:th
	 (:sexp '(head1 !) 
	    :cmpl-lol
	    '(
		("head1")
		(  "xyz" 
		   ("xxoo" nested nil ignore))))
	 (eval
	    (pcomplete:th:check-completions-form 
	       ''("xyz" "()") 
	       ""))))
   

   (  "Situation: Alternatives contain both a nested and a non-nested.
Nested has a name that is not the descent form itself.
The first alternative is a non-nested.
First arg of nested is something other than the descent form.
Operation: Cycle.
Response: The non-nested - first alternative - is inserted into the
buffer.
Point is directly after it."
      (pcomplete:th
	 (:sexp '(head1 !)
	    :cmpl-lol
	    '(("head1")
		(  "xyz" 
		   ("xxoo" nested nil ignore))))
	 (pcomplete)

	 (assert
	    (mockbuf:buf-contents-matches :sexp '(head1 xyz)))
	 (assert
	    (equal pcomplete-last-completion-stub ""))
	 (assert
	    (= pcomplete-last-completion-length 3))
	 (assert
	    (rtest:sets= pcomplete-current-completions '("xyz" "()")))
	 (assert
	    (looking-at "\)$"))
	 ;;There is no space just before point
	 (assert
	    (not (equal (char-before) ?\ )))
	 
	 (let ((last-command 'pcomplete)) (call-interactively #'pcomplete))

	 (assert
	    (mockbuf:buf-contents-matches :sexp '(head1 ())))
	 t))
   

   (  "Situation: Alternatives contain both a nested and a non-nested.
Nested has a name that is not the descent form itself.
The first alternative is a nested.
First arg of nested is something other than the descent form.
Operation: Cycle.
Response: The non-nested - first alternative - is inserted into the
buffer.
Point is directly after it."
      (pcomplete:th
	 (:sexp '(head1 !)
	    :cmpl-lol
	    '(("head1")
		(  
		   ("xxoo" nested nil ignore)
		   "xyz")))
	 (pcomplete)

	 (assert
	    (mockbuf:buf-contents-matches :sexp '(head1 ())))
	 (assert
	    (equal pcomplete-last-completion-stub ""))
	 (assert
	    (= pcomplete-last-completion-length 2))
	 (assert
	    (rtest:sets= pcomplete-current-completions '("xyz" "()")))
	 (assert
	    (looking-at "\)$"))
	 ;;There is no space just before point
	 (assert
	    (not (equal (char-before) ?\ )))

	 (let ((last-command 'pcomplete)) (call-interactively #'pcomplete))

	 (assert
	    (mockbuf:buf-contents-matches :sexp '(head1 xyz)))
	 t))

   (  "Situation: Doubly nested completions.
Each level has a sole choice.
Response: Descends both levels.  Completes entirely as sole."
      (pcomplete:th
	 (:sexp '(head1 !)
	    :cmpl-lol
	    '(("head1")
		(  
		   ("xxoo" nested nil 
		      (lambda ()
			 (pcomplete-nested
			    (pcomplete-here '("a"))))))))
	 
	 (pcomplete)
	 (assert
	    (mockbuf:buf-contents-matches :sexp '(head1 ((a)))))
	 ;;Point is in the right place.
	 (assert
	    (looking-at ")))$"))
	 ;;There is a space just before point
	 (assert
	    (equal (char-before) ?\ ))
	 
	 t))
   

   (  "Situation: Doubly nested completions.
Upper level has a sole choice.  Lower level has two choices.
Operation: pcomplete-list
Action: Inserts the nesting.
Lists all the lower choices."
      (pcomplete:th
	 (:sexp '(head1 !)
	    :cmpl-lol
	    '(("head1")
		(  
		   ("xxoo" nested nil 
		      (lambda ()
			 (pcomplete-nested
			    (pcomplete-here '("a""b"))))))))

	 ;;Check list
	 (eval
	    (pcomplete:th:check-completions-form 
	       ''("a" "b") 
	       ""))
	 (assert
	    (mockbuf:buf-contents-matches :sexp '(head1 (()))))

	 t))

   (  "Situation: Doubly nested completions.
Upper level has a sole choice.  Lower level has two choices.
Operation: pcomplete
Action: Completes with the first lower choice, nested.
Operation: pcomplete again.
Action: Completes with the second lower choice, nested."
      (pcomplete:th
	 (:sexp '(head1 !)
	    :cmpl-lol
	    '(("head1")
		(  
		   ("xxoo" nested nil 
		      (lambda ()
			 (pcomplete-nested
			    (pcomplete-here '("a""b"))))))))

	 (pcomplete)
	 (assert
	    (mockbuf:buf-contents-matches :sexp '(head1 ((a)))))
	 (assert
	    (equal pcomplete-last-completion-stub ""))
	 (assert
	    (= pcomplete-last-completion-length 1))
	 (assert
	    (rtest:sets= pcomplete-current-completions '("a" "b")))
	 (assert
	    (looking-at ")))$"))
	 ;;There is no space just before point
	 (assert
	    (not (equal (char-before) ?\ )))

	 (let ((last-command 'pcomplete)) (call-interactively #'pcomplete))

	 (assert
	    (mockbuf:buf-contents-matches :sexp '(head1 ((b)))))
	 t))
   
   ;;Can use arglist

   (  "Situation: pcomplete-here accepts an arglist.
Response: Nested completers are passed that arglist."
      (pcomplete:th:with-arged-completer
	 (:sexp '(head1 !))

	 (eval
	    (pcomplete:th:check-completions-form 
	       ''("a" "b") 
	       "")))))


(put 'pcomplete-nested-f 'rtest:test-thru
   'pcomplete-nested)
;;;_ , Finding further candidates

;;;_  . pcomplete-build-furthers-obj
'
(pcomplete-build-further-obj "*Command*" #'(lambda (x) "a" "b" "c"))
(defun pcomplete-build-furthers-obj (str func data)
   ""
  
   (list str 'further func nil))

;;;_   , Tests

(rtest:deftest pcomplete-build-furthers-obj

   (  "Param: The sole candidate is a lambda (So it gets selected)
Response: Candidates are the list that it returns."
      
      (pcomplete-list:th
	 :sexp '(head1 !)
	 :cmpl-lol
	 (list
	    '("head1" "head2")
	    (list
	       (pcomplete-build-furthers-obj 
		  "*Command*" 
		  #'(lambda (x) (list "a" "b" "c")) 
		  nil))
	    (list "a" "b" "c"))
	 :expect-which other)))


;;;_ , Support utilities
;;;_  . pcomplete-here-sexps

(defmacro pcomplete-here-sexps (sexp-list)
   "Like `pcomplete-here', but takes a list of sexps, which it maps to
strings" 
   
   `(pcomplete-here 
       (mapcar #'prin1-to-string ,sexp-list)))
;;;_   , Tests

(rtest:deftest pcomplete-here-sexps

   (  "Param: An empty string.
Shows: Works OK."
      (eval
	 (pcomplete:th:usuals-f2 
	    ''(head1 !)
	    '("head1")
	    '((pcomplete-here-sexps '("")))
	    (list
	       (pcomplete:th:check-completions-form 
		  ''("\"\"") 
		  nil)))))
   
   
   (  "Param: A string with escaped !.
Shows: Works OK."
      (eval
	 (pcomplete:th:usuals-f2 
	    ''(head1 !)
	    '("head1")
	    '((pcomplete-here-sexps '("!")))
	    (list
	       (pcomplete:th:check-completions-form 
		  ''("\"!\"") 
		  nil)))))
   
   )



;;;_  . pcomplete-string->sexp
(defun pcomplete-string->sexp (string)
   ""
   (condition-case err
      (read string)
      ('end-of-file '!)))

;;;_   , Tests
;;Tested thru `pcomplete-arg-as-sexp'

;;;_  . pcomplete-arg-as-sexp
(defsubst pcomplete-arg-as-sexp (&optional index offset level-ind)
   "Like `pcomplete-arg' but returns a sexp"
   (pcomplete-string->sexp  
      (pcomplete-arg index offset level-ind)))

;;;_   , Tests

(rtest:deftest pcomplete-arg-as-sexp

   ;;Mostly tested thru `pcomplete/emacs-lisp-mode/emt:eg'

   (  "Situation: arg would be a blank string 
Response: Return `!'."
      (pcomplete:th:with-nil-completer
	 (:sexp '(head1 !)
	    :max-level 0 
	    :expected-args '(head1 !))
	 (pcomplete:th:assert-position
	       :level 0
	       :index 1
	       :current-arg "")
	 (assert
	    (equal (pcomplete-arg-as-sexp) '! ) 
	    t)))
   
   )
;;;_    . EMtest style
(emt:deftest-2 pcomplete-arg-as-sexp
   (  "Situation: arg would be a blank string 
Response: Return `!'."
      (pcomplete:th:with-nil-completer
	 (:sexp '(head1 !)
	    :max-level 0 
	    :expected-args '(head1 !))
	 (pcomplete:th:assert-position
	    :level 0
	    :index 1
	    :current-arg "")
	 (should
	    (equal (pcomplete-arg-as-sexp) '! ))))
   
   )

;;;_. Footers
;;;_ , Provides

(provide 'pcmpl-elisp)

;;;_ * Local emacs vars.
;;;_  + Local variables:
;;;_  + mode: allout
;;;_  + End:

;;;_ , End
;;; pcmpl-elisp.el ends here