Highlight code in formatted content.
gitile/code.scm
19 | 19 | #:use-module (ice-9 match) | |
20 | 20 | #:use-module (syntax-highlight) | |
21 | 21 | #:use-module (syntax-highlight scheme) | |
22 | - | #:export (display-code)) | |
22 | + | #:export (display-code | |
23 | + | display-formatted-code)) | |
23 | 24 | ||
24 | 25 | (define (display-code content path) | |
25 | - | `(table (@ (class "file-content")) | |
26 | - | ,@(split-tr (highlights->sxml (highlight-code content path))))) | |
26 | + | (let* ((extension (car (reverse (string-split (basename path) #\.)))) | |
27 | + | (language (match extension | |
28 | + | ("scm" "scheme") | |
29 | + | (_ "unknown")))) | |
30 | + | `(table (@ (class "file-content")) | |
31 | + | ,@(split-tr (highlights->sxml (highlight-code content language)))))) | |
27 | 32 | ||
28 | - | (define (highlight-code content path) | |
29 | - | (let ((extension (car (reverse (string-split (basename path) #\.))))) | |
30 | - | (match extension | |
31 | - | ("scm" (highlight lex-scheme content)) | |
32 | - | (_ (list content))))) | |
33 | + | (define (display-formatted-code content language) | |
34 | + | (highlights->sxml (highlight-code content language))) | |
35 | + | ||
36 | + | (define (highlight-code content language) | |
37 | + | (match language | |
38 | + | ("scheme" (highlight lex-scheme content)) | |
39 | + | (_ (list content)))) | |
33 | 40 | ||
34 | 41 | (define (split-lines content) | |
35 | 42 | (let loop ((content content) (result '()) (line '())) |
gitile/handler.scm
43 | 43 | (meta (@ (charset "UTF-8"))) | |
44 | 44 | (meta (@ (name "viewport") (content "width=device-width, initial-scale=1"))) | |
45 | 45 | (link (@ (rel "stylesheet") (href "/css/gitile.css"))) | |
46 | + | (link (@ (rel "stylesheet") (href "/css/highlight.css"))) | |
46 | 47 | (link (@ (rel "icon") (href "/images/icon.png") (sizes "32x32"))) | |
47 | 48 | (script (@ (src "/js/gitile.js")) "") | |
48 | 49 | (title ,project)) |
gitile/pages.scm
63 | 63 | link | |
64 | 64 | (string-append "/" repository-name "/tree/" (or ref "-") "/" link))) | |
65 | 65 | ||
66 | - | (define check-links | |
66 | + | (define improve-content | |
67 | 67 | (match-lambda | |
68 | 68 | ((? string? s) s) | |
69 | 69 | (('a ('@ arg ...) content ...) | |
… | |||
77 | 77 | (arg arg)) | |
78 | 78 | arg)) | |
79 | 79 | ,@content)) | |
80 | + | (('code ('@ ('class language)) content) | |
81 | + | `(code (@ (class ,language)) | |
82 | + | ,(display-formatted-code | |
83 | + | content | |
84 | + | (if (string-prefix? "language-" language) | |
85 | + | (substring language 9) | |
86 | + | "unknown")))) | |
80 | 87 | ((tag ('@ arg ...) content ...) | |
81 | - | `(,tag (@ ,@arg) ,@(map check-links content))) | |
88 | + | `(,tag (@ ,@arg) ,@(map improve-content content))) | |
82 | 89 | ((tag content ...) | |
83 | - | `(,tag ,@(map check-links content))))) | |
90 | + | `(,tag ,@(map improve-content content))))) | |
84 | 91 | ||
85 | 92 | `((div (@ (class "content")) | |
86 | 93 | (p ,(basename path)) | |
… | |||
91 | 98 | ,(let ((content (utf8->string (get-file-content repo path #:ref ref)))) | |
92 | 99 | (if (string-suffix? ".md" path) | |
93 | 100 | `(article (@ (class "formatted-file-content")) | |
94 | - | ,(check-links (commonmark->sxml content))) | |
101 | + | ,(improve-content (commonmark->sxml content))) | |
95 | 102 | (display-code content path))))) | |
96 | 103 | ||
97 | 104 | (define* (project-files repository-name repo #:key (ref "-") (path '())) |