diff options
Diffstat (limited to 'src/guile/skribilo/source.scm')
-rw-r--r-- | src/guile/skribilo/source.scm | 208 |
1 files changed, 208 insertions, 0 deletions
diff --git a/src/guile/skribilo/source.scm b/src/guile/skribilo/source.scm new file mode 100644 index 0000000..a61de4f --- /dev/null +++ b/src/guile/skribilo/source.scm @@ -0,0 +1,208 @@ +;;;; source.scm -- Highlighting source files. +;;;; +;;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr> +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;;; USA. +;;;; + +(define-module (skribilo source) + :export (<language> language? language-extractor language-fontifier + source-read-lines source-read-definition source-fontify) + + :use-module (srfi srfi-35) + :autoload (srfi srfi-34) (raise) + :autoload (srfi srfi-13) (string-prefix-length) + :autoload (skribilo condition) (&file-search-error &file-open-error) + + :use-module (skribilo utils syntax) + :use-module (skribilo parameters) + :use-module (skribilo lib) + :use-module (oop goops) + :use-module (ice-9 rdelim)) + + +(fluid-set! current-reader %skribilo-module-reader) + + +;;; +;;; Class definition. +;;; + +(define-class <language> () + (name :init-keyword :name :init-value #f :getter langage-name) + (fontifier :init-keyword :fontifier :init-value #f + :getter language-fontifier) + (extractor :init-keyword :extractor :init-value #f + :getter language-extractor)) + +(define (language? obj) + (is-a? obj <language>)) + + + +;*---------------------------------------------------------------------*/ +;* source-read-lines ... */ +;*---------------------------------------------------------------------*/ +(define (source-read-lines file start stop tab) + (let ((p (search-path (*source-path*) file))) + (if (or (not (string? p)) (not (file-exists? p))) + (raise (condition (&file-search-error (file-name file) + (path (*source-path*))))) + (with-input-from-file p + (lambda () + (if (> (*verbose*) 0) + (format (current-error-port) " [source file: ~S]\n" p)) + (let ((startl (if (string? start) (string-length start) -1)) + (stopl (if (string? stop) (string-length stop) -1))) + (let loop ((l 0) ;; In Guile, line nums are 0-origined. + (armedp (not (or (integer? start) (string? start)))) + (s (read-line)) + (r '())) + (cond + ((or (eof-object? s) + (and (integer? stop) (> l stop)) + (and (string? stop) + (= (string-prefix-length stop s) stopl))) + (apply string-append (reverse! r))) + (armedp + (loop (+ l 1) + #t + (read-line) + (cons* "\n" (untabify s tab) r))) + ((and (integer? start) (>= l start)) + (loop (+ l 1) + #t + (read-line) + (cons* "\n" (untabify s tab) r))) + ((and (string? start) + (= (string-prefix-length start s) startl)) + (loop (+ l 1) #t (read-line) r)) + (else + (loop (+ l 1) #f (read-line) r)))))))))) + +;*---------------------------------------------------------------------*/ +;* untabify ... */ +;*---------------------------------------------------------------------*/ +(define (untabify obj tab) + (if (not tab) + obj + (let ((len (string-length obj)) + (tabl tab)) + (let loop ((i 0) + (col 1)) + (cond + ((= i len) + (let ((nlen (- col 1))) + (if (= len nlen) + obj + (let ((new (make-string col #\space))) + (let liip ((i 0) + (j 0) + (col 1)) + (cond + ((= i len) + new) + ((char=? (string-ref obj i) #\tab) + (let ((next-tab (* (/ (+ col tabl) + tabl) + tabl))) + (liip (+ i 1) + next-tab + next-tab))) + (else + (string-set! new j (string-ref obj i)) + (liip (+ i 1) (+ j 1) (+ col 1))))))))) + ((char=? (string-ref obj i) #\tab) + (loop (+ i 1) + (* (/ (+ col tabl) tabl) tabl))) + (else + (loop (+ i 1) (+ col 1)))))))) + +;*---------------------------------------------------------------------*/ +;* source-read-definition ... */ +;*---------------------------------------------------------------------*/ +(define (source-read-definition file definition tab lang) + (let ((p (search-path (*source-path*) file))) + (cond + ((not (language-extractor lang)) + (skribe-error 'source + "The specified language has not defined extractor" + (slot-ref lang 'name))) + + ((or (not p) (not (file-exists? p))) + (raise (condition (&file-search-error (file-name file) + (path (*source-path*)))))) + + (else + (let ((ip (open-input-file p))) + (if (> (*verbose*) 0) + (format (current-error-port) " [source file: ~S]\n" p)) + (if (not (input-port? ip)) + (raise (condition (&file-open-error (file-name p)))) + (unwind-protect + (let ((s ((language-extractor lang) ip definition tab))) + (if (not (string? s)) + (skribe-error 'source + "Can't find definition" + definition) + s)) + (close-input-port ip)))))))) + +;*---------------------------------------------------------------------*/ +;* source-fontify ... */ +;*---------------------------------------------------------------------*/ +(define (source-fontify o language) + (define (fontify f o) + (cond + ((string? o) (f o)) + ((pair? o) (map (lambda (s) (if (string? s) (f s) (fontify f s))) o)) + (else o))) + (let ((f (language-fontifier language))) + (if (procedure? f) + (fontify f o) + o))) + +;*---------------------------------------------------------------------*/ +;* split-string-newline ... */ +;*---------------------------------------------------------------------*/ +(define (split-string-newline str) + (let ((l (string-length str))) + (let loop ((i 0) + (j 0) + (r '())) + (cond + ((= i l) + (if (= i j) + (reverse! r) + (reverse! (cons (substring str j i) r)))) + ((char=? (string-ref str i) #\newline) + (loop (+ i 1) + (+ i 1) + (if (= i j) + (cons 'eol r) + (cons* 'eol (substring str j i) r)))) + ((and (char=? (string-ref str i) #\cr) + (< (+ i 1) l) + (char=? (string-ref str (+ i 1)) #\newline)) + (loop (+ i 2) + (+ i 2) + (if (= i j) + (cons 'eol r) + (cons* 'eol (substring str j i) r)))) + (else + (loop (+ i 1) j r)))))) |