1(in-package #:cl-markdown)
2
3(defmacro defsimple-extension (name &body body)
4  "Create an extension (a function named `name`) with no arguments that
5does not depend on the markdown phase and which does not use the result.
6These are handy for simple text substitutions."
7  (with-gensyms (phase arguments result)
8  `(progn
9     (pushnew (list ',name t) *extensions* :key #'car)
10     (defun ,name (,phase ,arguments ,result)
11       (declare (ignore ,phase ,arguments ,result))
12       ,@body)
13     ,@(%import/export-symbol name))))
14
15(defun %validate-defextension-arguments (arguments)
16  (loop for argument in (ensure-list arguments) do
17       (cond ((atom argument)
18	      (when (eq (symbol-package argument) #.(find-package :keyword))
19		  (error "Argument names may not be keywords and ~s is not"
20			 argument)))
21	     (t
22	      (unless (every (lambda (facet)
23			       (member facet '(:required :keyword :whole)))
24			     (rest argument))
25		(error "Invalid argument facets in ~s" (rest argument)))))))
26
27(defun %collect-arguments (arguments kind)
28  (loop for argument in (ensure-list arguments)
29     when (and (consp argument)
30	       (member kind (rest argument))) collect
31     (first argument)))
32
33(defun %collect-positionals (arguments)
34  (loop for argument in (ensure-list arguments)
35       when (or (atom argument)
36		(and (consp argument)
37		     (not (member :keyword (rest argument))))) collect
38     (first (ensure-list argument))))
39
40(defparameter *extensions* nil)
41
42(defmacro defextension ((name &key arguments (insertp nil) (exportp t))
43			&body body)
44  (%validate-defextension-arguments arguments)
45  (bind ((keywords (%collect-arguments arguments :keyword))
46	 (requires (%collect-arguments arguments :required))
47	 (whole  (%collect-arguments arguments :whole))
48	 (positionals (%collect-positionals arguments)))
49    (assert (<= (length whole) 1)
50	    nil "At most one :whole argument is allowed.")
51    (assert (null (intersection whole keywords))
52	    nil "Keyword arguments cannot be wholes")
53    `(progn
54       (setf *extensions* (remove ',name *extensions* :key #'first))
55       (push (list ',name ,insertp) *extensions*)
56       (defun ,name (phase args result)
57	 (declare (ignorable phase args result))
58	 (bind (,@(loop for positional in positionals
59		     unless (member positional whole) collect
60		       `(,positional (pop args)))
61		  ,@(loop for keyword in keywords collect
62			 `(,keyword
63			   (getf args ,(intern (symbol-name keyword) :keyword)
64				 nil)))
65		  ,@(when whole
66			  `((,(first whole)
67			      ;; remove keywords from args
68			      (progn
69				,@(loop for keyword in keywords collect
70				       `(,keyword
71					 (remf args
72					       ,(intern (symbol-name keyword) :keyword))))
73				(if (length-1-list-p args) (first args) args))))))
74	   ,@(loop for require in requires collect
75		  `(assert ,require nil ,(format nil "~s is required" require)))
76	   ,@body
77	   ,@(unless insertp nil)))
78       ,@(when exportp
79	       (%import/export-symbol name)))))
80
81(defun %import/export-symbol (name)
82  `((eval-when (:compile-toplevel :load-toplevel :execute)
83      (import ',name ,(find-package :cl-markdown-user))
84      (export ',name ,(find-package :cl-markdown-user)))))
85
86(defmacro aand+ (&rest args)
87  "Anaphoric nested AND.
88
89Binds the symbol `it' to the value of the preceding `arg.'"
90  (cond ((null args) t)
91        ((null (cdr args)) (car args))
92        (t `(aif ,(car args) (aand ,@(cdr args))))))
93