From 1c445dd093cb6a02289f25324039ce1cba358145 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 17 May 2012 23:37:43 +0200 Subject: 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. --- src/guile/skribilo/lib.scm | 137 +++++++++++++++++++++---------- src/guile/skribilo/location.scm | 31 +++---- src/guile/skribilo/package/base.scm | 50 +++++------ src/guile/skribilo/package/eq.scm | 4 +- src/guile/skribilo/package/slide.scm | 22 ++--- src/guile/skribilo/package/web-book2.scm | 52 ++++++------ tests/Makefile.am | 3 +- tests/location.test | 101 +++++++++++++++++++++++ 8 files changed, 275 insertions(+), 125 deletions(-) create mode 100644 tests/location.test 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 +;;; Copyright 2005, 2007, 2009, 2012 Ludovic Courtès ;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI ;;; ;;; @@ -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 +;;; Copyright 2005, 2007, 2009, 2010, 2012 Ludovic Courtès ;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI ;;; ;;; @@ -26,7 +26,8 @@ :autoload (srfi srfi-13) (string-prefix?) :export ( 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 :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 + :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 @@ -134,6 +134,31 @@ ,@(the-options opts :ident :class))) (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 ... */ ;*---------------------------------------------------------------------*/ @@ -963,31 +988,6 @@ (define-processor-markup html-processor) (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 ... */ ;* ------------------------------------------------------------- */ 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 +;;; Copyright 2005, 2006, 2007, 2008, 2009, 2012 Ludovic Courtès ;;; ;;; ;;; 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 +;;; Copyright 2006, 2007, 2008, 2009, 2012 Ludovic Courtès ;;; Copyright 2003, 2004 Manuel Serrano ;;; ;;; @@ -51,6 +51,16 @@ (define %slide-the-slides '()) (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 ... */ ;*---------------------------------------------------------------------*/ @@ -151,16 +161,6 @@ (loc &invocation-location) (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 ... */ ;*---------------------------------------------------------------------*/ 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 +;;; Copyright 2008, 2012 Ludovic Courtès ;;; ;;; ;;; 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
\n$1\n
" %small-toc-class) - toc)) + (b:! (format #f "\n
\n$1\n
" %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 +;;; +;;; 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 . + +(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: -- cgit v1.2.3