; Scheme code for TeXmacs literate programming mode
; copyright 2006 David MENTRE
; code under GNU GPL

;; needed modules
(use-modules (ice-9 regex)) ; to have Guile's regexp procedures
(use-modules (ice-9 rdelim)) ; to have Guile's (read-line) & Co. procedures

;; database of comment styles
(define comment-db
  '((c . #((".c" ".h") ; suffix-list
           comment-pair ; comment-style
           "/*" ; comment-start
           "*/" ; comment-end
           #\\)) ; escape-character
    (scheme . #((".scm")
                comment-until-eol
                ";"
                ""
                #f)) ; no escape character
    (c++ . #((".cpp" ".hpp")
             comment-until-eol
             "//"
             ""
             #f))
    ))

;; accessors for this database
(define (comment-config language) (cdr (assoc language comment-db)))

(define (comment-suffixes comment-cfg) (vector-ref comment-cfg 0))
(define (comment-style comment-cfg) (vector-ref comment-cfg 1))
(define (comment-start comment-cfg) (vector-ref comment-cfg 2))
(define (comment-end comment-cfg) (vector-ref comment-cfg 3))
(define (escape-character comment-cfg) (vector-ref comment-cfg 4))

;; output procedures
(define (escape-comment-delimiter comment-cfg comment)
  (define (add-escaped-char lst c)
    (append lst (list (escape-character comment-cfg) c)))
  (define (escape-chars res lst)
    (if (null? lst)
        res
        (escape-chars (add-escaped-char res (car lst)) (cdr lst))))
  (list->string (escape-chars '() (string->list comment))))

(define (substitute-in-string in-str matched-str by-str)
  (let ((quoted-matched-str (regexp-quote matched-str)))
    (regexp-substitute/global #f 
                              quoted-matched-str
                              in-str
                              'pre
                              (lambda (x) by-str)
                              'post)))

(define (escape-comment-sequences comment-cfg str)
  (if (eqv? (comment-style comment-cfg) 'comment-until-eol)
                                        ; no need to escape comment
                                        ; sequence for comment-until-eol
      str
      (let ((escaped-start 
             (escape-comment-delimiter comment-cfg 
                                       (comment-start comment-cfg)))
            (escaped-end
             (escape-comment-delimiter comment-cfg 
                                       (comment-end comment-cfg))))
        (let ((str-sub-start
               (substitute-in-string str ; escape start of comment delimiter
                                     (comment-start comment-cfg)
                                     escaped-start)))
                                        
          (substitute-in-string str-sub-start ; escape end of comment delimiter
                                (comment-end comment-cfg)
                                escaped-end)))))

(define (output-blocks comment-cfg blocks)
  (if (not (null? blocks))
      (let* ((head (car blocks))
             (type (car head))
             (data (cdr head)))
        (if (eqv? type 'code)
            (begin (display data)
                   (display #\newline)
                   (output-blocks comment-cfg (cdr blocks)))
            (begin (display (comment-start comment-cfg))
                   (display (escape-comment-sequences comment-cfg data))
                   (display (comment-end comment-cfg))
                   (display #\newline)
                   (output-blocks comment-cfg (cdr blocks)))))))

(define (output-to-file filename comment-cfg blocks)
  (with-output-to-file filename 
    (lambda () (output-blocks comment-cfg blocks))))

;; input procedures
(define (unescape-comment-sequences comment-cfg str)
  (if (eqv? (comment-style comment-cfg) 'comment-until-eol)
                                        ; no need to escape comment
                                        ; sequence for comment-until-eol
      str
      (let ((escaped-start 
             (escape-comment-delimiter comment-cfg 
                                       (comment-start comment-cfg)))
            (escaped-end
             (escape-comment-delimiter comment-cfg 
                                       (comment-end comment-cfg))))
        (let ((str-sub-start
               (substitute-in-string str ; escape start of comment delimiter
                                     escaped-start
                                     (comment-start comment-cfg))))
                                        
          (substitute-in-string str-sub-start ; escape end of comment delimiter
                                escaped-end
                                (comment-end comment-cfg))))))

(define (remove-comment-until-eol comment-cfg str)
  (let ((delim-len (string-length (comment-start comment-cfg))))
    (substring str delim-len (string-length str))))

(define (remove-comment-pair comment-cfg str)
  (let ((start-delim-len (string-length (comment-start comment-cfg)))
        (end-delim-len (string-length (comment-end comment-cfg))))
    (substring str start-delim-len (- (string-length str)
                                      end-delim-len))))

(define (input-as-blocks comment-cfg)
  (let ((remove-comment (if (eqv? (comment-style comment-cfg) 'comment-pair)
                            remove-comment-pair
                            remove-comment-until-eol))
        (start-delim (comment-start comment-cfg))
        (start-delim-len (string-length (comment-start comment-cfg))))
    (define (read-new-line blocks)
      (let ((line (read-line)))
        (if (eof-object? line)
            (reverse blocks)
            (if (< (string-length line) start-delim-len)
                                        ; line too short for a comment
                (read-new-line (cons (cons 'code line) blocks))
                (if (string=? (substring line 0 start-delim-len)
                              start-delim)
                                        ; we have a comment
                    (let* ((bare-line (remove-comment comment-cfg line))
                           (unescaped (unescape-comment-sequences comment-cfg
                                                                  bare-line)))
                      (read-new-line (cons (cons 'tm unescaped) blocks)))
                                        ; we have some code
                    (read-new-line (cons (cons 'code line) blocks)))))))
    (read-new-line '())))

(define (input-from-file filename comment-cfg)
  (with-input-from-file filename (lambda () (input-as-blocks comment-cfg))))

;; some tests for previous code
(define test-scheme-blocks
  '((tm . "<TeXmacs|1.0.6")
    (tm . "<style|generic>")
    (tm . "<\\body>")
    (tm . "<tag|;>")
    (code . "(define (hello-world) (display \"Hello world!\"))")
    (code . "")
    (tm . "</body>")
    ))

(define test-c-blocks
  '((tm . "<TeXmacs|1.0.6")
    (tm . "<style|generic>")
    (tm . "<\\body>")
    (tm . "<tag|/* */>")
    (code . " /* comment */")
    (code . "int v;")
    (code . "")
    (tm . "</body>")
    ))


(display "\nScheme\n")
(output-blocks (comment-config 'scheme) test-scheme-blocks)

(display "\nC\n")
(output-blocks (comment-config 'c) test-c-blocks)

(output-to-file "/tmp/scheme" (comment-config 'scheme) test-scheme-blocks)
(display (equal? test-scheme-blocks
                 (input-from-file "/tmp/scheme" (comment-config 'scheme))))


(output-to-file "/tmp/c" (comment-config 'c) test-c-blocks)
(display (equal? test-c-blocks
                 (input-from-file "/tmp/c" (comment-config 'c))))