index0001: (select-module scmxref)
0002: ;;;
0003: ;;;
0004: ;;;
0005:
0006: ;; options
0007: (define anchor-all-lines (make-parameter #f))
0008: (define anchor-file-extension (make-parameter ".html"))
0009: (define place-goto-anchor (make-parameter #f))
0010: (define gauche-man-base (make-parameter "http://practical-scheme.net/gauche/man/?l=en&p="))
0011:
0012: ;;;
0013: ;;; read-and-anchor
0014: ;;;
0015: (define (disp x)
0016: (cond ((not (char? x))
0017: (with-input-from-string (x->string x)
0018: (lambda ()
0019: (port-for-each disp read-char))))
0020: ((char=? #\< x)
0021: (display "<"))
0022: ((char=? #\> x)
0023: (display ">"))
0024: ((char=? #\& x)
0025: (display "&"))
0026: (else
0027: (display x))))
0028:
0029: (define symbol-initial #[A-Za-z!$%&*/:<=>?\^~+\-])
0030: (define symbol-char-set #[\w!$%&*/:<=>?\^~+\-@.])
0031:
0032: (define (read-string-w/o-escape ch lis)
0033: (cond ((eof-object? ch) (error "EOF inside string"))
0034: ((char=? #\" ch) (apply string (reverse lis)))
0035: ((char=? #\\ ch)
0036: (let ((x (read-char)))
0037: (read-string-w/o-escape (read-char)
0038: (cons x (cons ch lis)))))
0039: (else
0040: (read-string-w/o-escape (read-char)
0041: (cons ch lis)))))
0042:
0043: (define (read-symbol ch lis)
0044:
0045: (define (list->symbol lis)
0046: (string->symbol (apply string (reverse lis))))
0047:
0048: (cond ((eof-object? ch) (list->symbol lis))
0049: ((char-set-contains? symbol-char-set ch)
0050: (read-char)
0051: (read-symbol (peek-char) (cons ch lis)))
0052: (else
0053: (list->symbol lis))))
0054:
0055: (define (do-newline)
0056: (newline)
0057: (if (anchor-all-lines)
0058: (anchor-line))
0059: 'newline)
0060:
0061: (define (do-sharp lvl)
0062:
0063: (define (do-debug)
0064: (disp (read-char)) ; #\?
0065: (disp (read-char)) ; must be '='
0066: 'debug-print)
0067:
0068: (define (do-vector)
0069: ;; read as a list!
0070: (read-and-anchor lvl) ; #\( is passed
0071: 'venctor)
0072:
0073: (define (do-regexp)
0074: (disp (read-char)) ; #\/
0075: (let lp ((ch (read-char)))
0076: (cond ((eof-object? ch) (error "EOF inside regexp"))
0077: ((char=? #\/ ch) (disp ch) 'regexp)
0078: ((char=? #\\ ch)
0079: (disp ch)
0080: (disp (read-char))
0081: (lp (read-char)))
0082: (else
0083: (disp ch)
0084: (lp (read-char))))))
0085:
0086: (define (do-char-set)
0087: (disp (read-char)) ; #\[
0088: (let lp ((ch (read-char)))
0089: (cond ((eof-object? ch) (error "EOF inside char-set"))
0090: ((char=? #\] ch) (disp ch) 'char-set)
0091: ((char=? #\\ ch)
0092: (disp ch)
0093: (disp (read-char))
0094: (lp (read-char)))
0095: (else
0096: (disp ch)
0097: (lp (read-char))))))
0098:
0099: (define (do-multiline-comment)
0100: (disp (read-char)) ; #\|
0101: (let lp ((ch (read-char))
0102: (n 0))
0103: (cond ((eof-object? ch) (error "EOF inside comment"))
0104: ((char=? #\| ch)
0105: (disp ch)
0106: (let ((ch (read-char)))
0107: (cond ((char=? #\# ch)
0108: (disp ch)
0109: (if (= n 0)
0110: 'multiline-comment
0111: (lp (read-char) (- n 1))))
0112: (else
0113: (disp ch)
0114: (lp (read-char) n)))))
0115: ((char=? #\# ch)
0116: (disp ch)
0117: (let ((ch (read-char)))
0118: (cond ((eof-object? ch) (error "EOF inside comment"))
0119: ((char=? #\| ch)
0120: (disp ch)
0121: (lp (read-char) (+ n 1)))
0122: (else
0123: (disp ch)
0124: (lp (read-char) n)))))
0125: (else
0126: (disp ch)
0127: (lp (read-char) n)))))
0128:
0129: (define (do-string-interpolation)
0130: (when (not (in-string-interp))
0131: (in-string-interp (cons (port-name (current-input-port))
0132: (port-current-line (current-input-port)))))
0133: (read-char) ; #\"
0134: (let ((str (read-string-w/o-escape (read-char) '())))
0135: (disp #\") ; (disp #\-) (print "BEGIN") (display str) (print "\nEND")
0136: (with-input-from-string str
0137: (lambda ()
0138: (let lp ((ch (read-char)))
0139: (cond ((eof-object? ch) #t)
0140: ((char=? #\~ ch)
0141: (disp ch)
0142: (cond ((char=? (peek-char) #\~)
0143: (disp (read-char))
0144: (lp (read-char)))
0145: (else
0146: (read-and-anchor lvl)
0147: (lp (read-char)))))
0148: ((char=? #\newline ch)
0149: ;; FIXME! This gives wrong line number in case
0150: ;; there are newlines in (read-and-anchor).
0151: ;; We need to count number of lines in (read-and-anchor).
0152: (inc! (cdr (in-string-interp)))
0153: (do-newline)
0154: (lp (read-char)))
0155: (else
0156: (disp ch)
0157: (lp (read-char)))))))
0158: (disp #\")
0159: (in-string-interp #f)
0160: 'int-string))
0161:
0162: (define (do-char)
0163: ;; this works as long as ewline of #\newline
0164: ;; has no manual entry, for example.
0165: (disp (read-char)) ; #\\
0166: (disp (read-char))
0167: 'character)
0168:
0169: (disp #\#)
0170: (let ((ch (peek-char)))
0171: (cond ((eof-object? ch) (error "Unexpected EOF"))
0172: ((char=? #\? ch) (do-debug))
0173: ((char=? #\( ch) (do-vector))
0174: ((char=? #\/ ch) (do-regexp))
0175: ((char=? #\[ ch) (do-char-set))
0176: ((char=? #\| ch) (do-multiline-comment))
0177: ((char=? #\" ch) (do-string-interpolation))
0178: ((char=? #\\ ch) (do-char))
0179: (else
0180: (read-char)
0181: (disp ch)
0182: 'ignored))))
0183:
0184: (define (do-bar)
0185: ;; we do not anchor this type of symbol.
0186: (disp #\|)
0187: (let lp ((ch (read-char)))
0188: (cond ((eof-object? ch) (error "EOF inside |"))
0189: ((char=? #\| ch) (disp ch) 'symbol)
0190: ((char=? #\\ ch)
0191: (disp ch)
0192: (disp (read-char))
0193: (lp (read-char)))
0194: (else
0195: (disp ch)
0196: (lp (read-char))))))
0197:
0198: (define (do-string)
0199: (let ((str (read-string-w/o-escape (read-char) '())))
0200: (disp #\") (disp str) (disp #\")
0201: 'string))
0202:
0203: (define (do-quote lvl)
0204: (disp #\')
0205: (read-w/o-anchor lvl))
0206:
0207: (define (do-quasi-quote lvl)
0208: (disp #\`)
0209: (read-w/o-anchor lvl))
0210:
0211: (define (do-comment)
0212: (disp #\;)
0213: (skip-until-newline)
0214: 'comment)
0215:
0216: (define (skip-until-newline)
0217: (let ((ch (read-char)))
0218: (cond ((eof-object? ch) ch)
0219: ((char=? #\newline ch)
0220: (do-newline))
0221: (else
0222: (disp ch)
0223: (skip-until-newline)))))
0224:
0225: (define (anchor entry filename lineno)
0226:
0227: (define (has-source? entry) (string? (file-of entry)))
0228:
0229: (define (self? entry)
0230: (and (place-goto-anchor)
0231: (= lineno (line-of entry))
0232: (string=? filename
0233: (file-of entry))))
0234:
0235: (cond ((self? entry)
0236: (display #"<a class=\"entry\" href=\"~(path-to-top (file-of entry))../goto?file=~(file-of entry)&line=~(line-of entry)\">")
0237: (disp (name-of entry))
0238: (display "</a>"))
0239:
0240: ((has-source? entry)
0241: (entry-ref-push! entry filename lineno)
0242: (format #t "<a class=\"entry\" href=\"~a#~a:~a\">"
0243: (relative-path filename #"~(file-of entry)~(anchor-file-extension)")
0244: (file-of entry)
0245: (line-of entry))
0246: (disp (name-of entry))
0247: (display "</a>"))
0248:
0249: (else
0250: (disp (name-of entry)))))
0251:
0252: (define (anchor-line)
0253: (let ((fl (get-file-and-lineno)))
0254: (format #t "<a name=\"~a:~a\"></a>"
0255: (car fl) (cdr fl))))
0256:
0257: (define (has-document? sym)
0258: (or
0259: ;; we assume all exported binding has manual entry.
0260: (global-variable-bound? (find-module 'scmxref.used-modules)
0261: sym)
0262: ;; or in case sym is name of a module which has manual entry
0263: (memq sym (documented-modules))))
0264:
0265: (define (file->anchored-string file)
0266: (with-output-to-string
0267: (lambda ()
0268: (guard (e (else (get-output-string (current-output-port))))
0269: (read-and-anchor-file file)))))
0270:
0271: (define (read-and-anchor-file file)
0272: (with-input-from-file file
0273: (lambda ()
0274: (guard (e ((is-a? e <error>)
0275: ;; FIXME raise more specific condition in read-and-anchor
0276: ;; or check message slot.
0277: (display #"read-and-anchor: ~(~ e 'message)\n"
0278: (current-error-port))
0279: (copy-port (current-input-port)
0280: (current-output-port))
0281: (raise e))
0282: (else (raise e)))
0283: (until (eof-object? (read-and-anchor 0)))))))
0284:
0285: (define in-string-interp (make-parameter #f))
0286:
0287: (define (get-file-and-lineno)
0288: (cond ((in-string-interp) => (lambda (x) x))
0289: (else (cons (port-name (current-input-port))
0290: (port-current-line (current-input-port))))))
0291:
0292: (define (read-and-anchor lvl)
0293: (let lp ((ch (read-char)))
0294: (cond ((eof-object? ch) ch)
0295:
0296: ((char=? #\nl ch) (do-newline))
0297: ((char=? #\| ch) (do-bar))
0298: ((char=? #\" ch) (do-string))
0299: ((char=? #\; ch) (do-comment))
0300: ((char=? #\' ch) (do-quote lvl))
0301: ((char=? #\` ch) (do-quasi-quote lvl))
0302: ((char=? #\# ch) (do-sharp lvl))
0303:
0304: ;; FIXME not quite correct but it is needed
0305: ;; to process string interpolation
0306: ((char=? #\\ ch)
0307: (disp ch)
0308: (disp (read-char))
0309: (lp (read-char)))
0310:
0311: ((char=? #\) ch)
0312: (when (zero? lvl)
0313: (disp ch)
0314: (error "Extra close parenthesis"))
0315: (disp ch)
0316: 'close-paren)
0317:
0318: ((char=? #\( ch)
0319: (if (and (zero? lvl) (not (anchor-all-lines)))
0320: (anchor-line))
0321: (disp #\()
0322: (let lp ()
0323: (let ((x (read-and-anchor (+ lvl 1))))
0324: (cond ((eof-object? x) (error "unexpected EOF"))
0325: ((eq? x 'close-paren) 'list)
0326: (else (lp))))))
0327:
0328: ((char-set-contains? symbol-initial ch)
0329: (let* ((fl (get-file-and-lineno))
0330: (filename (car fl))
0331: (lineno (cdr fl))
0332: (sym (read-symbol (peek-char) (list ch))))
0333: (cond ((dictionary-get sym)
0334: =>
0335: (lambda (entry)
0336: (anchor entry filename lineno)))
0337: ((has-document? sym)
0338: (display #"<a class=\"man\" href=\"~(gauche-man-base)~|sym|\">")
0339: (disp sym)
0340: (display "</a>"))
0341: (else (disp sym))))
0342: 'symbol)
0343: (else ; #\. #\[ #\]
0344: (disp ch)
0345: (lp (read-char))))))
0346:
0347: (define (read-w/o-anchor lvl) ; in quote
0348:
0349: (define (do-unquote)
0350: (disp #\,)
0351: (if (char=? (peek-char) #\@)
0352: (disp (read-char)))
0353: (read-and-anchor lvl))
0354:
0355: (let lp ((ch (read-char)))
0356: (cond ((eof-object? ch) ch)
0357:
0358: ((char=? #\nl ch) (do-newline))
0359: ((char=? #\| ch) (do-bar))
0360: ((char=? #\" ch) (do-string))
0361: ((char=? #\; ch) (do-comment))
0362: ((char=? #\' ch) (do-quote lvl))
0363: ((char=? #\` ch) (do-quasi-quote lvl))
0364: ((char=? #\# ch) (do-sharp lvl))
0365: ((char=? #\, ch) (do-unquote))
0366:
0367: ;; FIXME not quite correct but it is needed
0368: ;; to process string interpolation
0369: ((char=? #\\ ch)
0370: (disp ch)
0371: (disp (read-char))
0372: (lp (read-char)))
0373:
0374: ((char=? #\) ch)
0375: (when (zero? lvl)
0376: (disp ch)
0377: (error "Extra close parenthesis"))
0378: (disp ch)
0379: 'close-paren)
0380:
0381: ((char=? #\( ch)
0382: (if (and (zero? lvl) (not (anchor-all-lines)))
0383: (anchor-line))
0384: (disp #\()
0385: (let lp ()
0386: (let ((x (read-and-anchor (+ lvl 1))))
0387: (cond ((eof-object? x) (error "unexpected EOF"))
0388: ((eq? x 'close-paren) 'list)
0389: (else (lp))))))
0390:
0391: ((char-set-contains? symbol-initial ch)
0392: (let ((sym (read-symbol (peek-char) (list ch))))
0393: (disp sym)
0394: ch))
0395: (else
0396: (disp ch)
0397: (lp (read-char))))))
0398:
0399: (provide "scmxref/read-and-anchor")
0400:
Index