;;;; Copyright (C) 2021 Julien Lepiller ;;;; ;;;; SPDX-License-Identifier: AGPL-3.0-or-later ;;;; ;;;; This program is free software: you can redistribute it and/or modify ;;;; it under the terms of the GNU Affero General Public License as published by ;;;; the Free Software Foundation, either version 3 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 Affero General Public License for more details. ;;;; ;;;; You should have received a copy of the GNU Affero General Public License ;;;; along with this program. If not, see . ;;;; (define-module (gitile code) #:use-module (ice-9 match) #:use-module (syntax-highlight) #:use-module (syntax-highlight c) #:use-module (syntax-highlight css) #:use-module (syntax-highlight gitignore) #:use-module (syntax-highlight scheme) #:use-module (syntax-highlight xml) #:use-module (gitile highlight shell) #:export (display-code display-formatted-code)) (define (display-code content path) (let* ((extension (car (reverse (string-split (basename path) #\.)))) (language (match extension ("scm" "scheme") ("gitignore" "gitignore") ("sh" "shell") ("bash" "shell") ("m4" "m4") ("ac" "ac") ("css" "css") ((or "c" "h") "c") ("xml" "xml") (_ (match (basename path) ("bootstrap" "shell") (_ "unknown")))))) `(table (@ (class ,(string-append "file-content language-" language))) ,@(split-tr (highlights->sxml (highlight-code content language)))))) (define (display-formatted-code content language) (highlights->sxml (highlight-code content language))) (define (highlight-code content language) (match language ("scheme" (highlight (lambda (tokens cursor) (lex-scheme tokens cursor)) content)) ("shell" (highlight lex-shell content)) ("gitignore" (highlight lex-gitignore content)) ("m4" (highlight lex-m4 content)) ("ac" (highlight lex-autoconf content)) ("css" (highlight lex-css content)) ("c" (highlight lex-c content)) ("xml" (highlight lex-xml content)) (_ (list content)))) (define (split-lines content) (let loop ((content content) (result '()) (line '())) (match content ((? string? s) (string-split s #\newline)) (() (append result (list line))) (((? string? s) content ...) (let loop2 ((lines (string-split s #\newline)) (added-lines '()) (next-line line)) (match lines ((l) (loop content (append result added-lines) (append next-line (list l)))) ((l rest ...) (loop2 rest (append added-lines (list (append next-line (list l)))) '()))))) ((('span ('@ arg ...) s) content ...) (let loop2 ((lines (string-split s #\newline)) (added-lines '()) (next-line line)) (match lines ((l) (loop content (append result added-lines) (append next-line `((span (@ ,@arg) ,l))))) ((l rest ...) (loop2 rest (append added-lines (list (append next-line `((span (@ ,@arg) ,l))))) '())))))))) (define (split-tr content) (let loop ((result '()) (lines (split-lines content)) (line-num 1)) (match lines (() result) ((line lines ...) (loop (append result `((tr (td (@ (class "content-line-num") (id ,(string-append "L" (number->string line-num)))) (a (@ (href ,(string-append "#L" (number->string line-num)))) ,line-num)) (td (@ (class "content-line")) (pre ,line))))) lines (+ line-num 1))))))