#|
   Copyright (c) 1997-2003, Dorai Sitaram.
   Portions copyright (c) 2004, Anton van Straaten.
   All rights reserved.

   Permission to distribute and use this work for any
   purpose is hereby granted provided this copyright
   notice is included in the copy.  This work is provided
   as is, with no warranty of any kind.
|#

(module scm2xexpr mzscheme

  (provide scheme-text->xexpr
           scheme-file->xexpr
           scheme->xexpr)

  ; constants
  (define *invisible-space* (list '*invisible-space*))
  (define *return* (integer->char 13))
  (define *scm-token-delims*
    (list #\( #\) #\[ #\] #\{ #\} #\' #\` #\" #\; #\, #\|))

  (define *scm-builtins* 
    '("abs"
      "acos"
      "angle"
      "append"
      "apply"
      "asin"
      "assq" "assv" "assoc"
      "atan"
      "boolean?"
      "car" "cdr"
      "caar"   "cadr"   "cdar"   "cddr"
      "caaar"  "caadr"  "cadar"  "caddr"  "cdaar"  "cdadr"  "cddar"  "cdddr"
      "caaaar" "caaadr" "caadar" "caaddr" "cadaar" "cadadr" "caddar" "cadddr" 
      "cdaaar" "cdaadr" "cdadar" "cdaddr" "cddaar" "cddadr" "cdddar" "cddddr"
      "call-with-current-continuation" "call/cc"
      "call-with-input-file"
      "call-with-output-file"
      "call-with-values"
      "char?"
      "char=?"    "char<?"    "char>?"    "char<=?"    "char>=?"
      "char-ci=?" "char-ci<?" "char-ci>?" "char-ci<=?" "char-ci>=?"
      "char-alphabetic?" "char-numeric?" "char-whitespace?" "char-upper-case?" "char-lower-case?"
      "char-ready?"
      "char->integer"
      "char-upcase" "char-downcase"
      "cons"
      "ceiling"
      "close-input=port"
      "close-output-port"
      "complex?"
      "cos"
      "current-input-port"
      "current-output-port"
      "denominator"
      "display"
      "dynamic-wind"
      "eof-object?"
      "eq?"
      "equal?"
      "eqv?"
      "eval"
      "even?"
      "exact?"
      "exact->inexact"
      "exp"
      "expt"
      "floor"
      "for-each"
      "force"
      "gcd"
      "imag-part"
      "inexact?"
      "inexact->exact"
      "input-port?"
      "integer?"
      "integer->char"
      "interaction-environment"
      "lcm"
      "length"
      "list"
      "list?"
      "list-ref"
      "list-tail"
      "list->string"
      "list->vector"
      "load"
      "log"
      "magnitude"
      "make-polar"
      "make-rectangular"
      "make-string"
      "make-vector"
      "map"
      "max" "min"
      "memq" "memv" "member"
      "modulo"
      "negative?"
      "newline"
      "not"
      "null?"
      "null-environment"
      "number?"
      "number->string"
      "numerator"
      "odd?"
      "open-input-file"
      "open-output-file"
      "output-port?"
      "pair?"
      "peek-char"
      "positive?"
      "procedure?"
      "quotient"
      "rational?"
      "rationalize"
      "read"
      "read-char"
      "real?"
      "real-part"
      "remainder"
      "reverse"
      "round"
      "scheme-report-environment"
      "sin"
      "set-car!"
      "set-cdr!"
      "sqrt"
      "string"
      "string?"
      "string-append"
      "string-copy"
      "string-fill!"
      "string-length"
      "string-ref"
      "string-set!"
      "string->list"
      "string->number"
      "string->symbol"
      "string=?"
      "string-ci=?"
      "string<?" "string>?" "string<=?" "string>=?"
      "string-ci<?" "string-ci>?" "string-ci<=?" "string-ci>=?"
      "substring"
      "symbol?"
      "symbol->string"
      "tan"
      "transcript-on"
      "transcript-off"
      "truncate"
      "values"
      "vector"
      "vector?"
      "vector-fill!"
      "vector-length"
      "vector-ref"
      "vector-set!"
      "vector->list"
      "with-input-from-file"
      "with-output-to-file"
      "write"
      "write-char"
      "zero?"
      "=" "<" ">" "<=" ">="
      "+" "*" "-" "/"
      ))
  
  (define *scm-keywords*
    '("=>"
      "and"
      "begin"
      "begin0"
      "case"
      "cond"
      "define"
      "define-macro"
      "define-syntax"
      "define-struct"
      "delay"
      "do"
      "else"
      "fluid-let"
      "if"
      "lambda"
      "let"
      "let-syntax"
      "let*"
      "letrec"
      "letrec-syntax"
      "module"
      "or"
      "provide"
      "quasiquote"
      "quote"
      "require"
      "require-for-syntax"
      "set!"
      "syntax-case"
      "syntax-rules"
      "unless"
      "unquote"
      "unquote-splicing"
      "when"
      "with-handlers"))
  
  (define *scm-variables* '())

  (define scheme-file->xexpr
    (lambda (filename . stylesheet-name)
      (apply scheme->xexpr filename 'file stylesheet-name)))

  (define scheme-text->xexpr
    (lambda (source-text . stylesheet-name)
      (apply scheme->xexpr source-text 'source stylesheet-name)))
  
  (define scheme->xexpr
    (lambda (input-source input-type . stylesheet-name)
      ; the following functions are defined here to provide access to
      ; unique lexical instances of current-input and input-line-no,
      ; which were global in the original code.
      (letrec
          ([current-input #f]
           [input-line-no  1]
           
           [call-with-input-file/buffered
            (lambda (f th)
              (if (file-exists? f)
                  (call-with-input-file f
                    (lambda (i)
                      (set! current-input (make-bport 'port i))
                      (th)))
                  `((p (b "Error: file not found: ") ,f))))]

           [call-with-input-string/buffered
            (lambda (s th)
              (set! current-input (make-bport 'buffer (string->list s)))
              (th))]

           [get-char
            (lambda ()
              (let ((b (bport-buffer current-input)))
                (if (null? b)
                    (let ((p (bport-port current-input)))
                      (if (not p)
                          eof
                          (let ((c (read-char p)))
                            (cond
                              ((eof-object? c) c)
                              ((char=? c #\newline)
                               (set! input-line-no (+ input-line-no 1))
                               c)
                              (else c)))))
                    (let ((c (car b)))
                      (set-bport-buffer! current-input (cdr b))
                      c))))]
           
           [toss-back-char
            (lambda (c)
              (set-bport-buffer!
               current-input
               (cons c (bport-buffer current-input))))]
           
           [scm-output-hash
            (lambda ()
              (get-actual-char)
              (let ((c (snoop-actual-char)))
                (cond
                  ((eof-object? c)
                   '(span ([class "selfeval"]) "#"))
                  ((char=? c #\|) (scm-output-extended-comment))
                  (else (toss-back-char #\#) (scm-output-token (scm-get-token))))))]
           
           [scm-output-next-chunk
            (lambda ()
              (let ((c (snoop-actual-char)))
                (cond
                  ((char=? c #\;) (scm-output-comment))
                  ((char=? c #\") (scm-output-string))
                  ((char=? c #\#) (scm-output-hash))
                  ((char=? c #\,)
                   (get-actual-char)
                   `(span ([class "keyword"])
                          ,(let ((c (snoop-actual-char)))
                             (cond 
                               ((char=? c #\@) (get-actual-char) ",@")
                               (else ",")))))
                  ((or (char=? c #\') (char=? c #\`))
                   (get-actual-char)
                   `(span ([class "keyword"]) 
                          ,(scm-emit-html-char c)))
                  ((or (char-whitespace? c) (memv c *scm-token-delims*))
                   (get-actual-char)
                   (scm-emit-html-char c))
                  (else (scm-output-token (scm-get-token))))))]

           [snoop-actual-char
            (lambda ()
              (let ((c (snoop-char)))
                (cond
                  ((eof-object? c) c)
                  ((invisible-space? c) (get-char) (snoop-actual-char))
                  ((char=? c *return*)
                   (get-char)
                   (let ((c (snoop-actual-char)))
                     (if (and (not (eof-object? c)) (char=? c #\newline))
                         c
                         (begin (toss-back-char #\newline) #\newline))))
                  (else c))))]

           [scm-output-comment
            (lambda ()
              `(span ([class "comment"])
                     ,(list->string 
                       (reverse!
                        (let loop ((comment-chars '()))
                          (let ((c (get-actual-char)))
                            (cond
                              ((eof-object? c) comment-chars)
                              ((char=? c #\newline) (cons c comment-chars))  ; final newline included in comment
                              ((and (char-whitespace? c)
                                    (let ((c2 (snoop-actual-char)))
                                      (or (eof-object? c2) (char=? c2 #\newline))))
                               (get-actual-char)
                               (cons #\newline comment-chars))               ; ditto here
                              (else (loop (cons c comment-chars))))))))))]

           [scm-output-extended-comment
            (lambda ()
              (get-actual-char)
              `(span ([class "comment"])
                     ,(string-append
                       "#|"
                       (list->string
                        (reverse!
                         (let loop ((comment-chars '()))
                           (let ((c (get-actual-char)))
                             (cond
                               ((eof-object? c) comment-chars)
                               ((char=? c #\|)
                                (let ((c2 (snoop-actual-char)))
                                  (cond
                                    ((eof-object? c2) comment-chars)
                                    ((char=? c2 #\#) (get-actual-char) comment-chars)
                                    (else (loop (cons c comment-chars))))))
                               (else (loop (cons c comment-chars))))))))
                       "|#")))]
           
           [scm-get-token
            (lambda ()
              (list->string
               (reverse!
                (let loop ((s '()) (esc? #f))
                  (let ((c (snoop-actual-char)))
                    (cond
                      ((eof-object? c) s)
                      (esc? (get-actual-char) (loop (cons c s) #f))
                      ((char=? c #\\) (get-actual-char) (loop (cons c s) #t))
                      ((or (char-whitespace? c) (memv c *scm-token-delims*)) s)
                      (else (get-actual-char) (loop (cons c s) #f))))))))]
           
           [snoop-char (lambda () (let ((c (get-char))) (toss-back-char c) c))]
           
           [get-actual-char
            (lambda ()
              (let ((c (get-char)))
                (cond
                  ((eof-object? c) c)
                  ((invisible-space? c) (get-actual-char))
                  ((char=? c *return*)
                   (let ((c (snoop-actual-char)))
                     (if (and (not (eof-object? c)) (char=? c #\newline))
                         (get-actual-char)
                         #\newline)))
                  (else c))))]
           
           [scm-output-string
            (lambda ()
              (get-actual-char) 
              `(span ([class "selfeval"])
                     ,(string-append
                       "\""
                       (list->string
                        (reverse!
                         (let loop ((s '()) (esc? #f))
                           (let ((c (get-actual-char)))
                             (case c
                               ((#\") (if esc? (loop (cons c s) #f)
                                          s))
                               ((#\\) (loop (cons c s) (not esc?)))
                               (else  (loop (cons c s) #f)))))))
                       "\"")))])
        
        (apply maybe-wrap-in-page
               `(div ([class "scheme"])
                 (pre ; twiki only recognizes unadorned pre tag (no class)
                  ,@((case input-type
                       ((file)   call-with-input-file/buffered)
                       ((source) call-with-input-string/buffered))
                     input-source
                     (lambda ()
                       (let loop ((output-elements '()))
                         (let ((c (snoop-actual-char)))
                           (if (eof-object? c) (reverse! output-elements)
                               (loop (cons (scm-output-next-chunk) 
                                           output-elements)))))))))
               stylesheet-name))))
  
  ; todo: add support for title
  (define maybe-wrap-in-page
    (lambda (xexpr . stylesheet-name)
      (if (null? stylesheet-name)
          xexpr
          `(html
            (head
             (link ([rel "stylesheet"]
                    [type "text/css"]
                    [href ,(car stylesheet-name)])))
            (body ,xexpr)))))

  (define scm-emit-html-char
    (lambda (c)
      (if (eof-object? c) '()
          (list->string (list c)))))

  (define scm-output-token
    (lambda (s)
      (let ((type (scm-get-type s)))
        (if (eq? type 'background) s
            `(span ([class ,(symbol->string type)]) ,s)))))

  (define member/string-ci=?
    (lambda (s ss) (ormap (lambda (x) (string-ci=? x s)) ss)))
  
  (define string-is-flanked-by-stars?
    (lambda (s)
      (let ((n (string-length s)))
        (and (>= n 3)
             (char=? (string-ref s 0) #\*)
             (char=? (string-ref s (- n 1)) #\*)))))
  
  (define string-starts-with-hash? (lambda (s) (char=? (string-ref s 0) #\#)))
  
  (define scm-get-type
    (lambda (s)
      (cond
        ((member/string-ci=? s *scm-keywords*) 'keyword)
        ((member/string-ci=? s *scm-builtins*) 'builtin)
        ((member/string-ci=? s *scm-variables*) 'variable)
        ((string-is-flanked-by-stars? s) 'global)
        (else
         (let ((colon (string-index s #\:)))
           (cond
             (colon (if (= colon 0) 'selfeval 'variable))
             ((string-is-all-dots? s) 'background)
             ((string-starts-with-hash? s) 'selfeval)
             ((string->number s) 'selfeval)
             (else 'variable)))))))
  
  (define-struct bport (port buffer))

  ; wrap plt constructor to match tex2page requirements
  (set! make-bport
    (let ((make-bport-orig make-bport))
      (lambda (field value)
        (apply make-bport-orig
               (case field
                 ((buffer) (list #f value))
                 ((port)   (list value '())))))))
  
  (define invisible-space? (lambda (x) (eq? x *invisible-space*)))
  
  (define string-index
    (lambda (s c)
      (let ((n (string-length s)))
        (let loop ((i 0))
          (cond
            ((>= i n) #f)
            ((char=? (string-ref s i) c) i)
            (else (loop (+ i 1))))))))
  
  (define string-is-all-dots?
    (lambda (s)
      (let ((n (string-length s)))
        (let loop ((i 0))
          (cond
            ((>= i n) #t)
            ((char=? (string-ref s i) #\.) (loop (+ i 1)))
            (else #f))))))
)