From 6f1c6b7d92f9654f84dba446edd0df377ee262eb Mon Sep 17 00:00:00 2001 From: James Ian Johnson Date: Wed, 7 Mar 2012 12:31:55 -0500 Subject: [PATCH] Added the ability to disambiguate between citations using autobib. --- collects/scriblib/autobib.rkt | 333 +++++++++++--------- collects/scriblib/scribblings/autobib.scrbl | 11 +- 2 files changed, 200 insertions(+), 144 deletions(-) diff --git a/collects/scriblib/autobib.rkt b/collects/scriblib/autobib.rkt index 7f0d99e335..aacf29a32d 100644 --- a/collects/scriblib/autobib.rkt +++ b/collects/scriblib/autobib.rkt @@ -5,12 +5,14 @@ scribble/decode scribble/html-properties scribble/latex-properties + (for-syntax syntax/parse + racket/base) scheme/string setup/main-collects) (provide define-cite make-bib in-bib (rename-out [auto-bib? bib?]) - proceedings-location journal-location book-location + proceedings-location journal-location book-location techrpt-location dissertation-location author-name org-author-name authors other-authors editor) @@ -22,45 +24,60 @@ (make-css-addition (abs "autobib.css")) (make-tex-addition (abs "autobib.tex"))))) -(define bib-table-style (make-style "AutoBibliography" autobib-style-extras)) +(define bib-table-style (make-style "AutoBibliography" autobib-style-extras)) (define bibentry-style (make-style "Autobibentry" autobib-style-extras)) - + (define-struct auto-bib (author date entry-element key specific)) (define-struct bib-group (ht)) (define-struct (author-element element) (names cite)) (define-struct (other-author-element author-element) ()) - -(define (add-cite group bib-entry which with-specific?) + +;; render the use of a citation. +(define (add-cite group bib-entry which with-specific? with-disambiguation?) (let ([key (auto-bib-key bib-entry)]) (hash-set! (bib-group-ht group) key bib-entry) (make-delayed-element (lambda (renderer part ri) - (let ([s (resolve-get part ri `(,which ,key))]) - (list (make-link-element #f - (list (or s "???") - (if with-specific? - (auto-bib-specific bib-entry) - "")) - `(autobib ,(auto-bib-key bib-entry)))))) + ;; (list which key) should be mapped to the bibliography element. + (define s (resolve-get part ri `(,which ,key))) + (define disambiguation + (cond [(and with-disambiguation? + (resolve-get part ri `(autobib-disambiguation ,key))) + => + (λ (dis) + (case dis + [(unambiguous) '()] + [else + (list + (make-link-element #f (list dis) + `(autobib ,(auto-bib-key bib-entry))))]))] + [else '()])) + (cons (make-link-element #f + (list (or s "???") + (if with-specific? + (auto-bib-specific bib-entry) + "")) + `(autobib ,(auto-bib-key bib-entry))) + disambiguation)) (lambda () "(???)") (lambda () "(???)")))) (define (add-inline-cite group bib-entries) - (for ([i bib-entries]) + (for ([i bib-entries]) (hash-set! (bib-group-ht group) (auto-bib-key i) i)) - (when (and (pair? (cdr bib-entries)) + (when (and (pair? (cdr bib-entries)) (not (apply equal? (map (compose author-element-names auto-bib-author) bib-entries)))) - (error 'citet "citet must be used with identical authors, given ~a" + (error 'citet "citet must be used with identical authors, given ~a" (map (compose author-element-names auto-bib-author) bib-entries))) - (make-element + (make-element #f - (list (add-cite group (car bib-entries) 'autobib-author #f) + (list (add-cite group (car bib-entries) 'autobib-author #f #f) 'nbsp "(" (let loop ([keys bib-entries]) (if (null? (cdr keys)) - (add-cite group (car keys) 'autobib-date #t) + (add-cite group (car keys) 'autobib-date #t #t) (make-element #f (list (loop (list (car keys))) @@ -76,18 +93,18 @@ (cons k (remove k ks)))))) (make-element #f - (append + (append (list 'nbsp "(") (add-between (for/list ([k (if sort? (sort keys string-cinumber (auto-bib-date b))) +;; 0 -> a, 1 -> b, etc. +(define (default-disambiguation n) + (when (>= n 26) + (error 'default-disambiguation "Citations too ambiguous for default disambiguation scheme.")) + (make-element #f (list (format " ~a" (integer->char (+ 97 n)))))) -(define (gen-bib tag group sec-title) - (let* ([author/datepara bib [disambiguation #f]) + (define collect-target + (list (make-target-element #f - (list (make-target-element + (list (auto-bib-entry-element bib)) + `(autobib ,(auto-bib-key bib))))) + ;; Communicate to scribble's resolve step. + (define (collect ci) + ;; store the author + (collect-put! ci + `(autobib-author ,(auto-bib-key bib)) ;; (list which key) + (make-element #f - (list (auto-bib-entry-element k)) - `(autobib ,(auto-bib-key k)))) - (lambda (ci) - (collect-put! ci - `(autobib-author ,(auto-bib-key k)) - (make-element - #f - (list - (author-element-cite (auto-bib-author k))))) - (collect-put! ci - `(autobib-date ,(auto-bib-key k)) - (make-element - #f - (list - (auto-bib-date k)))))))))) - bibs))) - null))) + (list (author-element-cite (auto-bib-author bib))))) + ;; store the date + (collect-put! ci + `(autobib-date ,(auto-bib-key bib)) ;; (list which key) + (make-element #f (list (auto-bib-date bib)))) + ;; store how to disambiguate it from other like citations. + (collect-put! ci + `(autobib-disambiguation ,(auto-bib-key bib)) + (or disambiguation 'unambiguous))) + (list + (make-paragraph plain + (list (make-collect-element #f collect-target collect))))) + ;; create the bibliography with disambiguations added. + (define-values (last num-ambiguous rev-disambiguated*) + (for/fold ([last #f] [num-ambiguous 0] [rev-disambiguated '()]) ([bib (in-list bibs)]) + (define ambiguous?? (and last (ambiguous? last bib))) + (define num-ambiguous* + (cond [ambiguous?? (add1 num-ambiguous)] + [else 0])) + ;; the current entry is ambiguous with the last. Modify the last + ;; to have the first disambiguation. + (define rev-disambiguated* + (cond [(and ambiguous?? (= 0 num-ambiguous)) + (cons (bib->para last (disambiguator num-ambiguous)) + (cdr rev-disambiguated))] + [else rev-disambiguated])) + (define para* + (bib->para bib (and ambiguous?? (disambiguator num-ambiguous*)))) + (values bib num-ambiguous* (cons para* rev-disambiguated*)))) + (reverse rev-disambiguated*))) + (make-part #f + `((part ,tag)) + (list sec-title) + (make-style #f '(unnumbered)) + null + (list (make-table bib-table-style disambiguated)) + null)) -(define-syntax-rule (define-cite ~cite citet generate-bibliography) - (begin - (define group (make-bib-group (make-hasheq))) - (define (~cite #:sort? [sort? #t] bib-entry . bib-entries) - (add-cites group (cons bib-entry bib-entries) sort?)) - (define (citet bib-entry . bib-entries) - (add-inline-cite group (cons bib-entry bib-entries))) - (define (generate-bibliography #:tag [tag "doc-bibliography"] #:sec-title [sec-title "Bibliography"]) - (gen-bib tag group sec-title)))) +(define-syntax (define-cite stx) + (syntax-parse stx + [(_ cite* citet generate-bibliography + (~optional (~seq #:disambiguate fn) + #:defaults ([fn #'#f]))) + (syntax/loc stx + (begin + (define group (make-bib-group (make-hasheq))) + (define (cite* #:sort? [sort? #t] bib-entry . bib-entries) + (add-cites group (cons bib-entry bib-entries) sort?)) + (define (citet bib-entry . bib-entries) + (add-inline-cite group (cons bib-entry bib-entries))) + (define (generate-bibliography #:tag [tag "doc-bibliography"] #:sec-title [sec-title "Bibliography"]) + (gen-bib tag group sec-title fn))))])) (define (ends-in-punc? e) (regexp-match? #rx"[.!?,]$" (content->string e))) -(define (make-bib #:title title +(define (make-bib #:title title #:author [author #f] #:is-book? [is-book? #f] #:location [location #f] @@ -169,28 +217,28 @@ [(not author) #f] [(author-element? author) author] [else (parse-author author)])] - [elem (make-element - bibentry-style - (append - (if author - `(,author - ,@(if (ends-in-punc? author) - '(" ") - '(". "))) - null) - ;; (if is-book? null '(ldquo)) - (if is-book? - (list (italic title)) - (decode-content (list title))) - (if (ends-in-punc? title) - null - '(".")) - ;; (if is-book? null '(rdquo)) - (if location - `(" " ,@(decode-content (list location)) ,(if date "," ".")) - null) - (if date `(" " ,@(decode-content (list (to-string date))) ".") null) - (if url `(" " ,(link url (make-element 'url (list url)))) null)))]) + [content + (append + (if author + `(,author + ,@(if (ends-in-punc? author) + '(" ") + '(". "))) + null) + ;; (if is-book? null '(ldquo)) + (if is-book? + (list (italic title)) + (decode-content (list title))) + (if (ends-in-punc? title) + null + '(".")) + ;; (if is-book? null '(rdquo)) + (if location + `(" " ,@(decode-content (list location)) ,(if date "," ".")) + null) + (if date `(" " ,@(decode-content (list (to-string date))) ".") null) + (if url `(" " ,(link url (make-element 'url (list url)))) null))] + [elem (make-element bibentry-style content)]) (make-auto-bib (or author (org-author-name title)) (to-string date) @@ -204,23 +252,22 @@ (auto-bib-date bib) (auto-bib-entry-element bib) (auto-bib-key bib) + ;; "where" is the only specific part of auto-bib elements currently. (string-append (auto-bib-specific bib) where))) (define (parse-author a) - (if (author-element? a) - a - (let* ([s (content->string a)] - [m (regexp-match #px"^(.*) (([\\-]|\\p{L})+)$" s)]) - (make-author-element - #f - (list a) - (if m - (string-append (caddr m) " " (cadr m)) - s) - (if m - (caddr m) - s))))) - + (cond [(author-element? a) a] + [else + (define s (content->string a)) ;; plain text rendering + (define m (regexp-match #px"^(.*) (([\\-]|\\p{L})+)$" s)) + (define names + (cond [m (string-append (caddr m) " " (cadr m))] + [else s])) + (define cite + (cond [m (caddr m)] + [else s])) + (make-author-element #f (list a) names cite)])) + (define (proceedings-location location #:pages [pages #f] @@ -308,35 +355,39 @@ "al." "al.")) -(define (authors name . names) - (let ([names (map parse-author (cons name names))]) - (make-author-element +(define (authors name . names*) + (define names (map parse-author (cons name names*))) + (define slash-names (string-join (map author-element-names names) " / ")) + (define cite + (case (length names) + [(1) (author-element-cite (car names))] + [(2) (if (other-author-element? (cadr names)) + (format "~a et al." (author-element-cite (car names))) + (format "~a and ~a" + (author-element-cite (car names)) + (author-element-cite (cadr names))))] + [else (format "~a et al." (author-element-cite (car names)))])) + (make-author-element #f (let loop ([names names] [prefix 0]) - (if (null? (cdr names)) - (case prefix - [(0) (list (car names))] - [(1) (if (other-author-element? (car names)) - (list " et al.") - (list " and " (car names)))] - [else (if (other-author-element? (car names)) - (list ", et al.") - (list ", and " (car names)))]) - (case prefix - [(0) (list* (car names) - (loop (cdr names) (add1 prefix)))] - [else (list* ", " - (car names) - (loop (cdr names) (add1 prefix)))]))) - (string-join (map author-element-names names) " / ") - (case (length names) - [(1) (author-element-cite (car names))] - [(2) (if (other-author-element? (cadr names)) - (format "~a et al." (author-element-cite (car names))) - (format "~a and ~a" - (author-element-cite (car names)) - (author-element-cite (cadr names))))] - [else (format "~a et al." (author-element-cite (car names)))])))) + (cond [(null? (cdr names)) + (case prefix + [(0) names] + [(1) (if (other-author-element? (car names)) + (list " et al.") + (list " and " (car names)))] + [else (if (other-author-element? (car names)) + (list ", et al.") + (list ", and " (car names)))])] + [else + (case prefix + [(0) (list* (car names) + (loop (cdr names) (add1 prefix)))] + [else (list* ", " + (car names) + (loop (cdr names) (add1 prefix)))])])) + slash-names + cite)) (define (editor name) (let ([name (parse-author name)]) diff --git a/collects/scriblib/scribblings/autobib.scrbl b/collects/scriblib/scribblings/autobib.scrbl index bb741b384a..986bdac74c 100644 --- a/collects/scriblib/scribblings/autobib.scrbl +++ b/collects/scriblib/scribblings/autobib.scrbl @@ -9,11 +9,16 @@ @defmodule[scriblib/autobib] -@defform[(define-cite ~cite-id citet-id generate-bibliography-id)]{ +@defform[(define-cite ~cite-id citet-id generate-bibliography-id [#:disambiguate disambiguator])]{ Binds @racket[~cite-id], @racket[citet-id], and -@racket[generate-bibliography-id], which share state to accumulate and -render citations. +@racket[generate-bibliography-id], which share state to accumulate and render +citations. If two citations' references would render the same but are +different, the optionally provided disambiguation function is used to add an +extra element after the date. The default disambiguator will add "a", "b", etc +until "z". Anything more ambiguous will throw an error. It has the contract + +@racketblock[(-> exact-nonnegative-integer? element?)] The function bound to @racket[~cite-id] produces a citation referring to one or more bibliography entries with a preceding non-breaking