lang.rkt (7208B)
1 #lang racket/base 2 (require scribble/doclang 3 scribble/core 4 racket/file 5 (except-in scribble/base author) 6 (prefix-in s/b: scribble/base) 7 scribble/decode 8 "../private/defaults.rkt" 9 setup/collects 10 scribble/html-properties 11 scribble/latex-properties 12 scribble/latex-prefix 13 racket/stxparam 14 net/ftp 15 file/gunzip 16 (for-syntax racket/base 17 racket/list 18 racket/stxparam-exptime)) 19 20 (module test racket/base) 21 22 (provide (except-out (all-from-out scribble/doclang) #%module-begin) 23 (all-from-out scribble/base) 24 (rename-out [module-begin #%module-begin]) 25 abstract include-abstract 26 authors author 27 institute institutes 28 email) 29 30 (define-syntax (module-begin stx) 31 ;; No options, currently, but keep in case we want to support some: 32 (syntax-case* stx () (lambda (a b) (eq? (syntax-e a) (syntax-e b))) 33 [(_ id ws . body) 34 ;; Skip intraline whitespace to find options: 35 (and (string? (syntax-e #'ws)) 36 (regexp-match? #rx"^ *$" (syntax-e #'ws))) 37 #'(module-begin id . body)] 38 [(_ id . body) 39 #'(#%module-begin id (post-process) () . body)])) 40 41 (define cls-file 42 (let ([p (scribble-file "lncs/llncs.cls")]) 43 (if (file-exists? (collects-relative->path p)) 44 p 45 (downloaded-file "llncs.cls")))) 46 47 (define ((post-process) doc) 48 (add-defaults doc 49 (string->bytes/utf-8 (string-append "\\documentclass{llncs}\n" 50 unicode-encoding-packages)) 51 (scribble-file "lncs/style.tex") 52 (list cls-file) 53 #f 54 #:replacements (hash "scribble-load-replace.tex" (scribble-file "lncs/lncs-load.tex")))) 55 56 (define lncs-extras 57 (let ([abs (lambda (s) 58 (path->collects-relative 59 (collection-file-path s "scribble" "lncs")))]) 60 (list 61 (make-css-addition (abs "lncs.css")) 62 (make-tex-addition (abs "lncs.tex"))))) 63 64 (unless (or (not (path? cls-file)) 65 (file-exists? cls-file)) 66 (log-error (format "File not found: ~a" cls-file)) 67 (define site "ftp.springernature.com") 68 (define path "cs-proceeding/llncs") 69 (define file "llncs2e.zip") 70 (unless (directory-exists? (find-system-path 'addon-dir)) 71 (make-directory (find-system-path 'addon-dir))) 72 (log-error (format "Downloading via ftp://~a/~a/~a..." site path file)) 73 (define c (ftp-establish-connection site 21 "anonymous" "user@racket-lang.org")) 74 (ftp-cd c path) 75 (make-directory* (find-system-path 'temp-dir)) 76 (ftp-download-file c (find-system-path 'temp-dir) file) 77 (ftp-close-connection c) 78 (define z (build-path (find-system-path 'temp-dir) file)) 79 ;; Poor man's unzip (replace it when we have an `unzip' library): 80 (define i (open-input-file z)) 81 (define (skip n) (file-position i (+ (file-position i) n))) 82 (define (get n) 83 (define s (read-bytes n i)) 84 (unless (and (bytes? s) (= n (bytes-length s))) 85 (error "unexpected end of file")) 86 s) 87 (let loop () 88 (cond 89 [(equal? #"PK\3\4" (get 4)) 90 ;; local file header 91 (skip 2) 92 (define data-desc? (bitwise-bit-set? (bytes-ref (get 1) 0) 3)) 93 (skip 11) 94 (define sz (integer-bytes->integer (get 4) #f #f)) 95 (skip 4) 96 (define name-sz (integer-bytes->integer (get 2) #f #f)) 97 (define extra-sz (integer-bytes->integer (get 2) #f #f)) 98 (define name (bytes->string/utf-8 (get name-sz) #\?)) 99 (skip extra-sz) 100 (if (equal? name "llncs.cls") 101 (call-with-output-file cls-file 102 (lambda (o) 103 (inflate i o))) 104 (begin 105 (skip sz) 106 (when data-desc? 107 skip 12) 108 (loop)))] 109 [else (error "didn't find file in archive")])) 110 (close-input-port i) 111 (delete-file z)) 112 113 ;; ---------------------------------------- 114 ;; Abstracts: 115 116 (define abstract-style (make-style "abstract" lncs-extras)) 117 118 (define (abstract . strs) 119 (make-nested-flow 120 abstract-style 121 (decode-flow strs))) 122 123 (define (extract-abstract p) 124 (unless (part? p) 125 (error 'include-abstract "doc binding is not a part: ~e" p)) 126 (unless (null? (part-parts p)) 127 (error 'include-abstract "abstract part has sub-parts: ~e" (part-parts p))) 128 (when (part-title-content p) 129 (error 'include-abstract "abstract part has title content: ~e" (part-title-content p))) 130 (part-blocks p)) 131 132 (define-syntax-rule (include-abstract mp) 133 (begin 134 (require (only-in mp [doc abstract-doc])) 135 (make-nested-flow abstract-style (extract-abstract abstract-doc)))) 136 137 ;; ---------------------------------------- 138 ;; Author 139 140 (define-syntax (author stx) 141 (raise-syntax-error 'author "can only be used inside 'authors'" stx)) 142 (define-syntax (authors stx) 143 (syntax-case stx (author) 144 [(_ (author . args) ...) 145 #`(paragraph 146 (style 'author '()) 147 (make-element (style "LNCSauthor" lncs-extras) 148 (decode-content 149 (list 150 #,@(apply 151 append 152 (add-between 153 (for/list ([stx (in-list (syntax->list #'(args ...)))]) 154 (syntax-case stx () 155 [(#:inst string rest ...) 156 (append (syntax->list #'(rest ...)) 157 (list #'(element (style "LNCSinst" lncs-extras) (decode-content (list string)))))] 158 [(rest ...) 159 (syntax->list #'(rest ...))])) 160 (list #'(element (style "LNCSand" lncs-extras) '()))))))))] 161 [(_ . rest) 162 (raise-syntax-error 'authors "expected a sequence of authors" stx)])) 163 164 (define-syntax-parameter email-ok #f) 165 166 (define-syntax (institute stx) 167 (raise-syntax-error #f "can only be used inside 'institutes'" stx)) 168 (define-syntax (institutes stx) 169 (syntax-case stx (author) 170 [(_ (inst . args) ...) 171 #`(syntax-parameterize 172 ((email-ok #t)) 173 (paragraph 174 (style 'author '()) 175 (make-element (style "LNCSinstitutes" lncs-extras) 176 (decode-content 177 (list 178 #,@(apply 179 append 180 (add-between 181 (for/list ([stx (in-list (syntax->list #'(args ...)))]) 182 (syntax-case stx () 183 [(rest ...) 184 (syntax->list #'(rest ...))])) 185 (list #'(element (style "LNCSand" lncs-extras) '())))))))))] 186 [(_ . rest) 187 (raise-syntax-error 'institutes "expected a sequence of institutes" stx)])) 188 189 (define-syntax (email stx) 190 (syntax-case stx () 191 [(_ . args) 192 (begin 193 (unless (syntax-parameter-value #'email-ok) 194 (raise-syntax-error 'email "email can appear inside institutes only")) 195 #'(make-element (style "LNCSemail" lncs-extras) 196 (decode-content (list . args))))]))