Change `define-markup' to generate a macro, to capture location syntactically.

* src/guile/skribilo/lib.scm (dsssl->guile-formals): New procedure,
  formerly `fix-rest-arg' procedure in `define-markup'.
  (define-markup)[guile-2]: Turn into a macro-generating macro, such
  that markups capture their invocation location syntactically.

* src/guile/skribilo/location.scm (source-properties->location): New
  procedure.
  (invocation-location): Use it.

* src/guile/skribilo/package/base.scm (handle): Move above first use,
  since it's now a macro on Guile 2.0.
* src/guile/skribilo/package/slide.scm (slide-vspace): Likewise.

* src/guile/skribilo/package/eq.scm: Use (skribilo package base) instead
  of autoloading it.

* tests/Makefile.am (TESTS): Add `location.test'.
* tests/location.test: New file.

8 files changed, 275 insertions, 125 deletions

diff --git a/src/guile/skribilo/lib.scm b/src/guile/skribilo/lib.scm
index feb5c8a..96bf483 100644
--- a/src/guile/skribilo/lib.scm
+++ b/src/guile/skribilo/lib.scm
@@ -1,6 +1,6 @@
 ;;; lib.scm -- Utilities.                 -*- coding: iso-8859-1 -*-
 ;;;
-;;; Copyright 2005, 2007, 2009  Ludovic Courtès <ludo@gnu.org>
+;;; Copyright 2005, 2007, 2009, 2012  Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright 2003, 2004  Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
 ;;;
 ;;;
@@ -65,50 +65,97 @@
 ;;;
 ;;; DEFINE-MARKUP
 ;;;
-(define-macro (define-markup bindings . body)
-  ;; This is just an `(ice-9 optargs)' kind of `lambda*', with DSSSL
-  ;; keyword-style conversion enabled.  However, using `(ice-9 optargs)', the
-  ;; `:rest' argument can only appear last, which is not what Skribe/DSSSL
-  ;; expect, hence `fix-rest-arg'.  In addition, all keyword arguments are
-  ;; allowed (hence `:allow-other-keys'); they are then checked by `verify'.
-  (define (fix-rest-arg args)
-    (let loop ((args          args)
-	       (result        '())
-	       (rest-arg      '())
-               (has-keywords? #f))
-      (cond ((null? args)
-             (let ((result (if has-keywords?
-                               (cons :allow-other-keys result)
-                               result)))
-               (append! (reverse! result) rest-arg)))
-
-	    ((list? args)
-	     (let ((is-rest-arg? (eq? (car args) :rest))
-                   (is-keyword?  (eq? (car args) :key)))
-               (if is-rest-arg?
-                   (loop (cddr args)
-                         result
-                         (list (car args) (cadr args))
-                         (or has-keywords? is-keyword?))
-                   (loop (cdr args)
-                         (cons (car args) result)
-                         rest-arg
-                         (or has-keywords? is-keyword?)))))
-
-	    ((pair? args)
-	     (loop '()
-		   (cons (car args) result)
-		   (list #:rest (cdr args))
-                   has-keywords?)))))
-
-  (let ((name (car bindings))
-	(opts (cdr bindings)))
-    `(define*-public ,(cons name (fix-rest-arg opts))
-       ;; Memorize the invocation location.  Note: the invocation depth
-       ;; passed to `invocation-location' was determined experimentally and
-       ;; may change as Guile changes (XXX).
-       (let ((&invocation-location (invocation-location 3)))
-         ,@body))))
+
+(define (dsssl->guile-formals args)
+  ;; When using `(ice-9 optargs)', the `:rest' argument can only appear last,
+  ;; which is not what Skribe/DSSSL expect'.  In addition, all keyword
+  ;; arguments are allowed (hence `:allow-other-keys'); they are then checked
+  ;; by `verify'.  This procedure shuffles ARGS accordingly.
+
+  (let loop ((args          args)
+             (result        '())
+             (rest-arg      '())
+             (has-keywords? #f))
+    (cond ((null? args)
+           (let ((result (if has-keywords?
+                             (cons :allow-other-keys result)
+                             result)))
+             (append (reverse result) rest-arg)))
+
+          ((list? args)
+           (let ((is-rest-arg? (eq? (car args) :rest))
+                 (is-keyword?  (eq? (car args) :key)))
+             (if is-rest-arg?
+                 (loop (cddr args)
+                       result
+                       (list (car args) (cadr args))
+                       (or has-keywords? is-keyword?))
+                 (loop (cdr args)
+                       (cons (car args) result)
+                       rest-arg
+                       (or has-keywords? is-keyword?)))))
+
+          ((pair? args)
+           (loop '()
+                 (cons (car args) result)
+                 (list :rest (cdr args))
+                 has-keywords?)))))
+
+;; `define-markup' is similar to Guile's `lambda*', with DSSSL
+;; keyword style, and a couple other differences handled by
+;; `dsssl->guile-formals'.
+
+(cond-expand
+ (guile-2
+  ;; On Guile 2.0, `define-markup' generates a macro for the markup, such
+  ;; that the macro captures its invocation source location using
+  ;; `current-source-location'.
+
+  (define-syntax define-markup
+    (lambda (s)
+      (syntax-case s ()
+        ;; Note: Use a dotted pair for formals, to allow for dotted forms
+        ;; like: `(define-markup (foo x . rest) ...)'.
+        ((_ (name . formals) body ...)
+         (let ((formals  (map (lambda (s)
+                                (datum->syntax #'formals s))
+                              (dsssl->guile-formals (syntax->datum #'formals))))
+               (internal (symbol-append '% (syntax->datum #'name)
+                                        '-internal)))
+           (with-syntax ((internal/loc (datum->syntax #'name internal)))
+             #`(begin
+                 (define* (internal/loc loc #,@formals)
+                   (syntax-parameterize ((&invocation-location
+                                          (identifier-syntax loc)))
+                     body ...))
+                 (define-syntax name
+                   (lambda (s)
+                     (syntax-case s ()
+                       ((_ . args)
+                        #'(let ((loc (source-properties->location
+                                      (current-source-location))))
+                            (internal/loc loc . args)))
+                       (_
+                        #'(lambda args
+                            (let ((loc (source-properties->location
+                                        (current-source-location))))
+                              (apply internal/loc loc args)))))))
+                 internal/loc                     ; mark it as used
+                 (export name)))))))))
+
+ (else                                            ; Guile 1.8
+  ;; On Guile 1.8, a markup is a procedure.  Its invocation source location
+  ;; is captured by walking the stack, which is fragile.
+
+  (define-macro (define-markup bindings . body)
+    (let ((name (car bindings))
+          (opts (cdr bindings)))
+      `(define*-public ,(cons name (dsssl->guile-formals opts))
+         ;; Memorize the invocation location.  Note: the invocation depth
+         ;; passed to `invocation-location' was determined experimentally and
+         ;; may change as Guile changes (XXX).
+         (let ((&invocation-location (invocation-location 3)))
+           ,@body))))))
 
 
 ;;;
diff --git a/src/guile/skribilo/location.scm b/src/guile/skribilo/location.scm
index 888ea94..048082a 100644
--- a/src/guile/skribilo/location.scm
+++ b/src/guile/skribilo/location.scm
@@ -1,7 +1,7 @@
 ;;; location.scm -- Skribilo source location.
 ;;; -*- coding: iso-8859-1 -*-
 ;;;
-;;; Copyright 2005, 2007, 2009, 2010  Ludovic Courtès <ludo@gnu.org>
+;;; Copyright 2005, 2007, 2009, 2010, 2012  Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright 2003, 2004  Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
 ;;;
 ;;;
@@ -26,7 +26,8 @@
   :autoload   (srfi srfi-13)  (string-prefix?)
   :export (<location> location? ast-location
 	   location-file location-line location-column
-           invocation-location))
+           invocation-location
+           source-properties->location))
 
 ;;; Author:  Ludovic Courtès
 ;;;
@@ -95,17 +96,19 @@
         (stack (make-stack #t)))
     (and stack
          (< depth (stack-length stack))
-         (let* ((frame  (stack-ref stack depth))
-                (source (frame-source frame)))
-           (and source
-                (let ((file (source-property source 'filename))
-                      (line (source-property source 'line))
-                      (col  (source-property source 'column)))
-                  (and file
-                       (make <location> :file file
-                             :line (and line (+ line 1))
-                             :column col))))))))
-
-;;; arch-tag: d68fa45d-a200-465e-a3c2-eb2861907f83
+         (let ((frame (stack-ref stack depth)))
+           (source-properties->location (frame-source frame))))))
+
+(define (source-properties->location loc)
+  "Return a location object based on the info in LOC, an alist as returned
+by Guile's `source-properties', `frame-source', `current-source-location',
+etc."
+  (let ((file (assq-ref loc 'filename))
+        (line (assq-ref loc 'line))
+        (col  (assq-ref loc 'column)))
+    (and file (make <location>
+                :file file
+                :line (and line (+ line 1))
+                :column (and col (+ col 1))))))
 
 ;;; location.scm ends here.
diff --git a/src/guile/skribilo/package/base.scm b/src/guile/skribilo/package/base.scm
index 52ce6c9..60eccb1 100644
--- a/src/guile/skribilo/package/base.scm
+++ b/src/guile/skribilo/package/base.scm
@@ -135,6 +135,31 @@
 	  (body #f))))
 
 ;*---------------------------------------------------------------------*/
+;*    handle ...                                                       */
+;*---------------------------------------------------------------------*/
+(define-markup (handle :rest opts
+		       :key (ident #f) (class "handle") value section)
+   (let ((body (the-body opts)))
+      (cond
+	 (section
+	  (error 'handle "Illegal handle `section' option" section)
+	  (new unresolved
+             (loc  &invocation-location)
+	     (proc (lambda (n e env)
+		      (let ((s (resolve-ident section 'section n env)))
+			 (new handle
+                            (loc   &invocation-location)
+			    (ast s)))))))
+	 ((and (pair? body)
+	       (null? (cdr body))
+	       (markup? (car body)))
+	  (new handle
+             (loc &invocation-location)
+	     (ast (car body))))
+	 (else
+	  (skribe-error 'handle "Illegal handle" opts)))))
+
+;*---------------------------------------------------------------------*/
 ;*    toc ...                                                          */
 ;*---------------------------------------------------------------------*/
 (define-markup (toc :rest
@@ -964,31 +989,6 @@
 (define-processor-markup tex-processor)
 
 ;*---------------------------------------------------------------------*/
-;*    handle ...                                                       */
-;*---------------------------------------------------------------------*/
-(define-markup (handle :rest opts
-		       :key (ident #f) (class "handle") value section)
-   (let ((body (the-body opts)))
-      (cond
-	 (section
-	  (error 'handle "Illegal handle `section' option" section)
-	  (new unresolved
-             (loc  &invocation-location)
-	     (proc (lambda (n e env)
-		      (let ((s (resolve-ident section 'section n env)))
-			 (new handle
-                            (loc   &invocation-location)
-			    (ast s)))))))
-	 ((and (pair? body)
-	       (null? (cdr body))
-	       (markup? (car body)))
-	  (new handle
-             (loc &invocation-location)
-	     (ast (car body))))
-	 (else
-	  (skribe-error 'handle "Illegal handle" opts)))))
-
-;*---------------------------------------------------------------------*/
 ;*    mailto ...                                                       */
 ;*    -------------------------------------------------------------    */
 ;*    doc:                                                             */
diff --git a/src/guile/skribilo/package/eq.scm b/src/guile/skribilo/package/eq.scm
index ee0d40d..781b394 100644
--- a/src/guile/skribilo/package/eq.scm
+++ b/src/guile/skribilo/package/eq.scm
@@ -1,7 +1,7 @@
 ;;; eq.scm  --  An equation formatting package.
 ;;; -*- coding: iso-8859-1 -*-
 ;;;
-;;; Copyright 2005, 2006, 2007, 2008, 2009  Ludovic Courtès <ludo@gnu.org>
+;;; Copyright 2005, 2006, 2007, 2008, 2009, 2012  Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;;
 ;;; This file is part of Skribilo.
@@ -28,7 +28,7 @@
   :use-module (skribilo condition)
   :use-module (skribilo utils syntax)
   :use-module (skribilo utils keywords) ;; `the-options', etc.
-  :autoload   (skribilo package base) (it symbol sub sup)
+  :use-module (skribilo package base)
   :autoload   (skribilo engine lout)  (lout-illustration)
   :autoload   (skribilo resolve)      (resolve-counter)
 
diff --git a/src/guile/skribilo/package/slide.scm b/src/guile/skribilo/package/slide.scm
index 60e11b0..9ba0692 100644
--- a/src/guile/skribilo/package/slide.scm
+++ b/src/guile/skribilo/package/slide.scm
@@ -1,7 +1,7 @@
 ;;; slide.scm  --  Overhead transparencies.
 ;;; -*- coding: iso-8859-1 -*-
 ;;;
-;;; Copyright 2006, 2007, 2008, 2009  Ludovic Courtès <ludo@gnu.org>
+;;; Copyright 2006, 2007, 2008, 2009, 2012  Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright 2003, 2004  Manuel Serrano
 ;;;
 ;;;
@@ -52,6 +52,16 @@
 (define %slide-the-counter 0)
 
 ;*---------------------------------------------------------------------*/
+;*    slide-vspace ...                                                 */
+;*---------------------------------------------------------------------*/
+(define-markup (slide-vspace :rest opt :key (unit 'cm))
+   (new markup
+      (markup 'slide-vspace)
+      (loc &invocation-location)
+      (options `((:unit ,unit) ,@(the-options opt :unit)))
+      (body (the-body opt))))
+
+;*---------------------------------------------------------------------*/
 ;*    slide ...                                                        */
 ;*---------------------------------------------------------------------*/
 (define-markup (slide :rest opt
@@ -152,16 +162,6 @@
       (markup 'slide-pause)))
 
 ;*---------------------------------------------------------------------*/
-;*    slide-vspace ...                                                 */
-;*---------------------------------------------------------------------*/
-(define-markup (slide-vspace :rest opt :key (unit 'cm))
-   (new markup
-      (markup 'slide-vspace)
-      (loc &invocation-location)
-      (options `((:unit ,unit) ,@(the-options opt :unit)))
-      (body (the-body opt))))
-
-;*---------------------------------------------------------------------*/
 ;*    slide-embed ...                                                  */
 ;*---------------------------------------------------------------------*/
 (define-markup (slide-embed :rest opt
diff --git a/src/guile/skribilo/package/web-book2.scm b/src/guile/skribilo/package/web-book2.scm
index d44933b..0ce01c5 100644
--- a/src/guile/skribilo/package/web-book2.scm
+++ b/src/guile/skribilo/package/web-book2.scm
@@ -1,7 +1,7 @@
 ;;; web-book2.scm  --  Another web book style.
 ;;; -*- coding: iso-8859-1 -*-
 ;;;
-;;; Copyright 2008  Ludovic Courtès <ludo@gnu.org>
+;;; Copyright 2008, 2012  Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;;
 ;;; This file is part of Skribilo.
@@ -22,7 +22,7 @@
 (define-module (skribilo package web-book2)
   :use-module (skribilo ast)
   :use-module (skribilo engine)
-  :use-module (skribilo package base)
+  :use-module ((skribilo package base) :renamer (symbol-prefix-proc 'b:))
 
   :use-module (skribilo utils syntax)
   :use-module (skribilo utils keywords)
@@ -63,27 +63,27 @@
   (define enclose
     (if (engine-format? "html" e)
         (lambda (toc)
-          (! (format #f "\n<div class=\"~a\">\n$1\n</div>" %small-toc-class)
-             toc))
+          (b:! (format #f "\n<div class=\"~a\">\n$1\n</div>" %small-toc-class)
+               toc))
         (lambda (toc)
-          (p :class %small-toc-class toc))))
+          (b:p :class %small-toc-class toc))))
 
   (define (make-uplink)
     (let ((parent (ast-parent n)))
       (and parent
-           (ref :handle (handle parent)
-                :text (list (symbol "uparrow") " "
-                            (markup-option parent :title))))))
+           (b:ref :handle (b:handle parent)
+                  :text (list (b:symbol "uparrow") " "
+                              (markup-option parent :title))))))
 
   (let ((kids (filter section? (markup-body n))))
     (enclose
        (list
         (and (not (null? kids))
              (list "Contents"
-                   (itemize
+                   (b:itemize
                     (map (lambda (section)
-                           (item (ref :handle (handle section)
-                                      :text (markup-option section :title))))
+                           (b:item (b:ref :handle (b:handle section)
+                                          :text (markup-option section :title))))
                          kids))))
         (make-uplink)))))
 
@@ -101,35 +101,33 @@
 ;;; Overrides.
 ;;;
 
-(define %base-package
-  (resolve-interface '(skribilo package base)))
-
 (define (make-overriding-markup markup)
   ;; Override the `chapter' markup from the `base' package to allow the
   ;; production of a small TOC at the beginning of each chapter.
-  (let ((real-markup (module-ref %base-package markup)))
-    (lambda args
-      ;;(format (current-error-port) "in new `~a'~%" markup)
-      (if (engine-format? "html")
-          (apply real-markup
-                 (append (concatenate (the-options args))
-                         (cons (resolve (lambda (n e env)
+  (lambda args
+    ;;(format (current-error-port) "in new `~a'~%" markup)
+    (if (engine-format? "html")
+        (apply markup
+               (append (concatenate (the-options args))
+                       (cons (b:resolve (lambda (n e env)
                                           (let ((p (ast-parent n)))
                                             (and (in-file-of-its-own? p e)
                                                  (make-small-toc p e)))))
-                               (the-body args))))
-          (apply real-markup args)))))
+                             (the-body args))))
+        (apply markup args))))
+
+;; FIXME: With this technique, source location info is lost.
 
 (define chapter
-  (make-overriding-markup 'chapter))
+  (make-overriding-markup b:chapter))
 
 (define section
-  (make-overriding-markup 'section))
+  (make-overriding-markup b:section))
 
 (define subsection
-  (make-overriding-markup 'subsection))
+  (make-overriding-markup b:subsection))
 
 (define subsubsection
-  (make-overriding-markup 'subsubsection))
+  (make-overriding-markup b:subsubsection))
 
 ;;; web-book2.scm ends here
diff --git a/tests/Makefile.am b/tests/Makefile.am
index 84cb0c9..1a1444a 100644
--- a/tests/Makefile.am
+++ b/tests/Makefile.am
@@ -7,7 +7,8 @@ TESTS =						\
   ast.test					\
   resolve.test					\
   readers/rss-2.test				\
-  engines/info.test
+  engines/info.test				\
+  location.test
 
 EXTRA_DIST = $(TESTS)
 
diff --git a/tests/location.test b/tests/location.test
new file mode 100644
index 0000000..c973f63
--- /dev/null
+++ b/tests/location.test
@@ -0,0 +1,101 @@
+;;; Check the AST source location info.                  -*- Scheme -*-
+;;;
+;;; Copyright (C) 2012  Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of Skribilo.
+;;;
+;;; Skribilo is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU Lesser General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; Skribilo 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 Lesser
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public License
+;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (tests location)
+  :use-module (skribilo ast)
+  :use-module (skribilo reader)
+  :use-module (skribilo evaluator)
+  :use-module (skribilo package base)
+  :use-module (skribilo location)
+  :use-module (srfi srfi-1)
+  :use-module (srfi srfi-64)
+  :use-module (ice-9 match))
+
+(cond-expand (guile-2 (begin))
+             (else    (use-modules (ice-9 syncase))))
+
+(define-syntax call-with-code
+  (syntax-rules ()
+    ((_ strings ... thunk)
+     (let ((s (string-join '(strings ...) "\n")))
+       (call-with-input-string s
+         (lambda (p)
+           (set-port-filename! p "the-file.skb")
+           (set-port-line! p 0)
+           (set-port-column! p 0)
+           (thunk p)))))))
+
+(define (location->list loc)
+  (and (location? loc)
+       (list (location-file loc)
+             (location-line loc)
+             (location-column loc))))
+
+(define (locations ast)
+  ;; Return a location tree for AST and its children.
+  (let loop ((ast ast))
+    (cond ((node? ast)
+           (and=> (location->list (ast-loc ast))
+                  (lambda (loc)
+                    (append loc (map loop (node-children ast))))))
+          ((ast? ast)
+           (location->list (ast-loc ast)))
+          (else
+           '()))))
+
+(define-syntax test-location
+  (syntax-rules ()
+    ((_ name expected doc)
+     (test-equal name
+       'expected
+       (call-with-code doc
+         (lambda (p)
+           (pk (locations (evaluate-ast-from-port p)))))))))
+
+(*document-reader* (make-reader 'skribe))
+
+
+(test-begin "location")
+
+(test-location "document"
+  ("the-file.skb" 1 1)
+  "(document)")
+
+(test-location "document + sections"
+  ("the-file.skb" 2 5
+     ("the-file.skb" 3 7)
+     ("the-file.skb" 4 7
+        ("the-file.skb" 5 9
+           ("the-file.skb" 6 11))))
+  "                                               ; 1
+    (document                                     ; 2
+      (chapter :title \"foo\")                    ; 3
+      (chapter :title \"bar\"                     ; 4
+        (section :title \"baz\"                   ; 5
+          (p [Paragraph.]))))")                   ; 6
+
+(test-end "location")
+
+
+(exit (= (test-runner-fail-count (test-runner-current)) 0))
+
+;; Local Variables:
+;; eval: (put 'call-with-code 'scheme-indent-function 1)
+;; eval: (put 'test-location 'scheme-indent-function 1)
+;; End: