$ more Markdown.scm (module Markdown (* Markdown) (import scheme) (import chicken) (use extras) (use md5) (use matchable) (use srfi-13) ; string-downcase (require-extension regex) (import irregex) (define *tab-width* 4) (define *less-than-tab* (- *tab-width* 1)) (define *escape-table* (let gen ((t '(#\\ #\` #\* #\_ #\{ #\} #\[ #\] #\( #\) #\# #\+ #\- #\. #\!))) (if (null? t) '() (cons `(,(car t) . ,(md5-digest (string (car t)))) (gen (cdr t)))))) ;(define cons-and-carry-on begin) (define (is-blank? str) (irregex-match "^[[:space:]]*$" str)) (define (generator lst) (let ((lst lst)) (lambda () (if (null? lst) #f (let ((item (car lst))) (set! lst (cdr lst)) item))))) ; Main procedure ; The order in which other procs are called here is essential. Link and image ; substitutions need to happen before _EscapeSpecialChars, so that any *'s or ; _'s in the and tags get encoded. ; ; We read from current-input-port and return sxml in a list. ; (define (Markdown) ; Standardize the line endings ; read-line returns the lines without newline characters (let* ((lines ; Here we read every line of the file converting tabs to aligned spaces ; (_Detab regex) as we go. We also transform consecutive blank lines ; (i.e. lines with no characers or consisting of whitespace only) into a ; single blank line (i.e. lines with no characters). ; Canonicalising blank lines makes subsequent regexes easier to write, because ; we can match consecutive blank lines with /\n+/ instead of something ; contorted like /[ \t]*\n+/ . Of course, in this version there are no ; I'm not sure in which situations it's dangerous to change tabs to spaces but ; it's what the original Perl version does. (read-file (current-input-port) (let ((prev-line '())) (lambda (port) (let loop ((str (read-line port))) (cond ((eof-object? str) str) ((and (is-blank? str) (is-blank? prev-line)) (loop (read-line port))) ; Strip consecutive blank lines (else (set! prev-line str) (if (is-blank? str) "" ; Return empty lines as blank (irregex-replace/all "(.*?)\t" str ; _Detab : Convert all tabs to spaces (lambda (match) ; Regex from http://www.nntp.perl.org/group/perl.macperl.anyperl/2002/03/msg154.html (let ((match (irregex-match-substring match 1))) (string-append match (make-string (- *tab-width* (modulo (string-length match) *tab-width*)) #\ ))))))))))))) (next-line (generator lines)) ; TODO: Pull out all the preformed HTML sections as we don't render them. See _HashHTMLBlocks, pg.6. ; We can put them back into the list as sxml lists and we can ignore them later because they won't be strings. (lines ; We only want to do this for block-level HTML tags, such as headers, ; lists, and tables. That's because we still want to wrap s around ; "paragraphs" that are wrapped in non-block-level tags, such as anchors, ; phrase emphasis, and spans. The list of tags we're looking for is ; hard-coded: (let ((block-tags-a (string->sre "p|div|h[1-6]|blockquote|pre|table|dl|ol|ul|script|noscript|form|fieldset|iframe|math|ins|del")) (block-tags-b "p|div|h[1-6]|blockquote|pre|table|dl|ol|ul|script|noscript|form|fieldset|iframe|math") (lines (make-parameter '()))) ; First, look for nested blocks, e.g.: ; ; ; tags for inner block must be indented. ; ; ; ; The outermost tags must start at the left margin for this to match, and ; the inner nested divs must be indented. ; We need to do this before the next, more liberal match, because the next ; match will start at the first `` and stop at the first ``. (let loop ((line (next-line)) (prev-line '())) (if line (if (not (string? line)) ;(cons-and-carry-on ; Already processed (begin ; Already processed (lines (cons line (lines))) (loop (next-line) line)) (let ((irmatch (irregex-match (irregex `(: bos "<" (submatch ,block-tags-a) eow (* nonl)) 'i ) line))) (if irmatch (let* ((tag (irregex-match-substring irmatch 1))) ; TODO: This bit (display (format "found starting tag~A\n" tag)))) (lines (cons line (lines))) (loop (next-line) line) )))) (lines))) (lines (reverse lines)) (next-line (generator lines)) ; Here we loop through every line and try to decide if there's a link ; to strip. If we find one then we strip it. We are careful to not ; leave consecutive blank lines in the file. _StripLinkDefinitions ; We must strip links before anything else to have the same "re-use id" ; semantics as the original parser. (link-refs (make-parameter '())) (lines (let ((lines (make-parameter '()))) (let loop ((line (next-line)) (prev-line '())) (if line ; TODO: (if !string (cons-and-carry-on) (else... ; Is it a link reference? (let ((irmatch (irregex-match (string-append "^[ ]{0," (format "~A" *less-than-tab*) "}" ; Up to "3" spaces. "\\[(.+)\\]:" ; Then the link id in square brackets followed by a colon. "[ ]*" ; Maybe some space. "(?)?" ; Then maybe the URL itself, possibly enclosed between <>. "[ ]*" ; Maybe some more space. "([\"(](.+)[\")])?" ; Then maybe an optional title maybe enclosed in " or ( or possibly a mixture. "[ ]*" ; Possibly some trailing space. ) line))) (if irmatch (let* ((id (irregex-match-substring irmatch 1)) (url (irregex-match-substring irmatch 2)) (url (if url (irregex-replace "^?$" url 1) #f)) (title (irregex-match-substring irmatch 4)) (stow-and-continue (lambda (id url title next) ; stow the id, url and title in the dictionary (link-refs (cons (list (string-downcase id) url title) (link-refs))) ; Preserve "no consecutive blank lines". ; If the previous line was blank, strip the next line if it's also blank and pass on a blank "prev-line" ; otherwise pass on the next line and the previous line, not the current line as we're stripping it. (if (and (is-blank? prev-line) (is-blank? next)) (loop (next-line) prev-line) (loop next prev-line)))) (find-title (lambda (id url) ; There's a chance that the title will be on the next line. (let* ((next (next-line)) (irmatch (irregex-match (string-append "[ ]*" ; Always allowing the blank space. "([\"(](.+)[\")])" ; If we're lucky there will be a title, maybe enclosed in " or ( or possibly a mixture. "[ ]*" ; Nothing else to be found on this line except maybe those whitespaces. ) next))) (if irmatch (let ((title (irregex-match-substring irmatch 1))) (stow-and-continue id url title (next-line))) (stow-and-continue id url #f next)))))) ; This next line wasn't a title so stow this link without one. (match (list id url title) ((#f #f #f) ; Something went horribly wrong: just cons up the line and carry on. ;(cons-and-carry-on (begin (lines (cons line (lines))) (loop (next-line) line))) ((_ #f #f) ; We might have found a link, provided the URL (and maybe also title) are on the next line. (let* ((next (next-line)) (irmatch (irregex-match (string-append "[ ]*" ; Maybe some space. "(?)" ; Then definitely the URL itself, possibly enclosed between <>. "[ ]*" ; Maybe a bit more space. "([\"(](.+)[\")])?" ; Then maybe an optional title maybe enclosed in " or ( or possibly a mixture. "[ ]*" ; Of course, space is allowed. ) next))) ; This will match unless the line is blank. The original parser can produce all sorts of bogus URLS. (if irmatch (let ((url (irregex-replace "^?$" (irregex-match-substring irmatch 1) 1)) (title (irregex-match-substring irmatch 2))) (match (list id url title) ((_ _ #f) ; We found a URL but not a title. (find-title id url)) ((_ _ _ ) ; We've got everything. (stow-and-continue id url title (next-line))))) ;(cons-and-carry-on ; Oops.. we didn't really find a link. (begin ; Oops.. we didn't really find a link. (lines (cons line (lines))) (loop next line))))) ((_ _ #f) ; We got an ID and URL but not a title. (find-title id url)) ((_ _ _ ) ; Everything all on one line: super! (stow-and-continue id url title (next-line))))) ;(cons-and-carry-on ; This doesn't look like a link reference. (begin ; This doesn't look like a link reference. (lines (cons line (lines))) (loop (next-line) line)))))) (lines))) (lines (reverse lines)) (next-line (generator lines))) ; Work out the type of that line and enclose it in the ; correct sxml forms, escaping and converting as we go... ; ; Write something that just returns the line prefixed by the type we think it is? ; that's virtually the whole thing anyway... ; This clause needs to evaluate to the sxml document ; The document will probably need a final processing step to render all the ; links. (let loop ((line (next-line))) (if line (begin (display line) (newline) (loop (next-line))))) ;(link-refs)) "done") ; From the syntax document: ; Inline HTML: *blocks* are in their own paragraph and the first tag starts ; in column 1. ; Make sure that the input ends with a couple of newlines ; Why?? ; Turn block-level HTML blocks into hash entries ; Strip link definitions, store in hashes. ; -- strip these as we go and store them somewhere. ; Whenever we generate a link, generate a procedure that we can evaluate ; later and pass in the store of definitions. ; Converting inline html to sxml: use irregex to find the start of the tag ; match. emit the text until that point, then emit an sxml form containing the ; substring from the match. This will need to be recursive. ) )
s around ; "paragraphs" that are wrapped in non-block-level tags, such as anchors, ; phrase emphasis, and spans. The list of tags we're looking for is ; hard-coded: (let ((block-tags-a (string->sre "p|div|h[1-6]|blockquote|pre|table|dl|ol|ul|script|noscript|form|fieldset|iframe|math|ins|del")) (block-tags-b "p|div|h[1-6]|blockquote|pre|table|dl|ol|ul|script|noscript|form|fieldset|iframe|math") (lines (make-parameter '()))) ; First, look for nested blocks, e.g.: ;