gitile/code.scm \

    gitile/git.scm \

;;;; Copyright (C) 2021 Julien Lepiller <julien@lepiller.eu>

;;;; 

;;;; This library is free software; you can redistribute it and/or

;;;; modify it under the terms of the GNU Lesser General Public

;;;; License as published by the Free Software Foundation; either

;;;; version 3 of the License, or (at your option) any later version.

;;;; 

;;;; This library 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

;;;; Lesser General Public License for more details.

;;;; 

;;;; You should have received a copy of the GNU Lesser General Public

;;;; License along with this library; if not, write to the Free Software

;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;;; 

(define-module (gitile code)

  #:use-module (ice-9 match)

  #:use-module (syntax-highlight)

  #:use-module (syntax-highlight scheme)

  #:export (display-code))

(define (display-code content path)

  `(table (@ (class "file-content"))

     ,@(split-tr (highlights->sxml (highlight-code content path)))))

(define (highlight-code content path)

  (let ((extension (car (reverse (string-split (basename path) #\.)))))

    (match extension

      ("scm" (highlight lex-scheme content))

      (_ 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))))))

  #:use-module (gitile code)

         `(article (@ (class "formatted-file-content"))

         (display-code content path)))))

(define my-guile-syntax-highlight

  (package

    (inherit guile-syntax-highlight)

    (source (origin

              (method git-fetch)

              (uri (git-reference

                     (url "https://git.dthompson.us/guile-syntax-highlight.git")

                     (commit "51727cbb7fc05ef743aab2d7b16314ea1ed790e4")))

              (file-name (git-file-name "guile-syntax-highlight" "0.1.51727cb"))

              (sha256

               (base32

                "1cvacy4y5qxajygb1qg8hvhjdf2xnnwnm5j918cabsi8wfwchig7"))))

    (native-inputs

     `(("autoconf" ,autoconf)

       ("automake" ,automake)

       ("texinfo" ,texinfo)

       ,@(package-native-inputs guile-syntax-highlight)))))

     ("guile-syntax-highlight" ,my-guile-syntax-highlight)