140 lines
5.5 KiB
Scheme
140 lines
5.5 KiB
Scheme
(module read-lines mzscheme
|
|
(require (lib "etc.ss") "util.ss")
|
|
(provide read-lines)
|
|
(define read-lines
|
|
(opt-lambda (file caption [offset #f])
|
|
(template caption (get-the-lines file offset))))
|
|
(define (semi-flatten lst)
|
|
(if (null? lst)
|
|
'()
|
|
(list* (caar lst) (cadar lst) (semi-flatten (cdr lst)))))
|
|
(define temp-anchor `(a ((name "temp")) ""))
|
|
(define (spacify s)
|
|
(if (and (string? s) (string=? s ""))
|
|
" " ; to appease IE
|
|
s))
|
|
(define (template caption lines)
|
|
`(table ([cellpadding "0"] [cellspacing "0"])
|
|
(b ,(with-color "blue" caption))
|
|
(p)
|
|
(pre ([style "font-family:monospace"])
|
|
;; use <BR>'s instead of newlines, for Opera don't put in a <BR>
|
|
;; for the temp-anchor, which wasn't a line in the source
|
|
,@(semi-flatten
|
|
(map (lambda (ln)
|
|
(if (eq? ln temp-anchor)
|
|
`(,ln "")
|
|
`(,(spacify ln) (BR)))) lines)))))
|
|
|
|
(define url-regexp-base "://([^\\s]*)($|\\s|(\\.(\\s|$))|>)")
|
|
(define trailing-regexp (pregexp "[\\s>)(\"]"))
|
|
|
|
(define (make-url-regexp ty)
|
|
(pregexp (string-append ty url-regexp-base)))
|
|
|
|
(define http-regexp (make-url-regexp "http"))
|
|
(define (http-format url) `(a ((href ,url)) ,url))
|
|
(define ftp-regexp (make-url-regexp "ftp"))
|
|
(define ftp-format http-format)
|
|
|
|
(define email-regexp
|
|
(let ([chars "[^\\s)(<>\"']"]
|
|
[no-comma-chars "[^\\s)(<>\"',]"])
|
|
(pregexp (string-append no-comma-chars chars "*" "@" chars "{3,}"))))
|
|
(define (email-format addr)
|
|
`(a ((href ,(string-append "mailto:" addr))) ,addr))
|
|
|
|
(define (rtrim s)
|
|
(let* ([presult (regexp-replace* trailing-regexp s "")]
|
|
[plen (string-length presult)]
|
|
[qlen (sub1 plen)])
|
|
(if (and (> qlen 0) (char=? (string-ref presult qlen) #\.))
|
|
(substring presult 0 qlen)
|
|
presult)))
|
|
|
|
(define (process-for-urls line)
|
|
(let loop ([built-line line])
|
|
(let ([curr-len (string-length built-line)])
|
|
(let-values ([(raw-indices formatter)
|
|
(let regexp-loop ([regexps (list http-regexp
|
|
ftp-regexp
|
|
email-regexp)]
|
|
[formats (list http-format
|
|
ftp-format
|
|
email-format)])
|
|
(if (null? regexps)
|
|
(values #f #f)
|
|
(let* ([curr-regexp (car regexps)]
|
|
[curr-formatter (car formats)]
|
|
[match-indices (regexp-match-positions
|
|
curr-regexp built-line)])
|
|
(if match-indices
|
|
(values match-indices curr-formatter)
|
|
(regexp-loop (cdr regexps) (cdr formats))))))])
|
|
(if raw-indices
|
|
(let* ([indices (car raw-indices)]
|
|
[string-start (car indices)]
|
|
[string-end (cdr indices)]
|
|
[raw-item (substring built-line string-start string-end)]
|
|
[raw-item-len (string-length raw-item)]
|
|
[item (rtrim raw-item)]
|
|
[item-len (string-length item)])
|
|
`(tt ,(substring built-line 0 string-start)
|
|
,(formatter item)
|
|
,(substring raw-item ; text removed by rtrim
|
|
item-len
|
|
raw-item-len)
|
|
,(loop (substring built-line string-end
|
|
curr-len))))
|
|
built-line)))))
|
|
|
|
(define (process-for-keywords line)
|
|
(let ([len (string-length line)])
|
|
(if (and (> len 3)
|
|
(char=? (string-ref line 0) #\>))
|
|
(let* ([rest-of-line (substring line 1 len)]
|
|
[port (open-input-string rest-of-line)]
|
|
[dist
|
|
(with-handlers ([exn:fail:read? (lambda (x) #f)])
|
|
(read port)
|
|
(let-values ([(_1 _2 pos) (port-next-location port)])
|
|
pos))])
|
|
(if dist
|
|
`(div (b ">" ,(color-highlight (substring line 1 dist)))
|
|
,(substring line dist len))
|
|
line))
|
|
#f)))
|
|
|
|
;; format line for doc.txt files
|
|
(define (process-doc-line line)
|
|
(let ([key-result (process-for-keywords line)])
|
|
(if key-result key-result (process-for-urls line))))
|
|
|
|
(define (get-the-lines file offset)
|
|
(let* ([port (open-input-file file 'text)]
|
|
[doc-txt? (let ([len (string-length file)])
|
|
(string=? (substring file (- len 7) len) "doc.txt"))]
|
|
[process-line
|
|
(if doc-txt?
|
|
process-doc-line
|
|
(lambda (x) x))]
|
|
[lines (let loop ([lines '()])
|
|
(let ([line (read-line port)])
|
|
(if (eof-object? line)
|
|
(begin
|
|
(close-input-port port)
|
|
(reverse lines))
|
|
(loop (cons line lines)))))])
|
|
(if offset
|
|
(let loop ([lines lines] [count 0])
|
|
(if (null? lines)
|
|
'()
|
|
(let ([len (add1 (string-length (car lines)))])
|
|
;; add1 because newline in source omitted
|
|
(if (>= count offset)
|
|
(cons temp-anchor
|
|
(if doc-txt? (map process-doc-line lines) lines))
|
|
(cons (process-line (car lines))
|
|
(loop (cdr lines) (+ count len)))))))
|
|
(map process-line lines)))))
|