;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;;
;;; 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 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
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program.  If not, see
;;; <http://www.gnu.org/licenses/>.

(define (add-to-load-path* directory)
  (unless (member directory %load-path)
    (add-to-load-path directory)))

(add-to-load-path* "/home/dave/Code/guile-syntax-highlight")

(use-modules (haunt asset)
             (haunt builder blog)
             (haunt builder atom)
             (haunt builder assets)
             (haunt html)
             (haunt page)
             (haunt post)
             (haunt reader)
             (haunt reader skribe)
             (haunt reader texinfo)
             (haunt reader commonmark)
             (haunt site)
             (haunt utils)
             (syntax-highlight)
             (syntax-highlight scheme)
             (sxml match)
             (sxml transform)
             (texinfo)
             (texinfo html)
             (srfi srfi-19)
             (ice-9 rdelim)
             (ice-9 regex)
             (ice-9 match)
             (web uri))

(define (stylesheet name)
  `(link (@ (rel "stylesheet")
            (href ,(string-append "/css/" name ".css")))))

(define (anchor content uri)
  `(a (@ (href ,uri)) ,content))

(define %cc-by-sa-link
  '(a (@ (href "https://creativecommons.org/licenses/by-sa/4.0/"))
      "Creative Commons Attribution Share-Alike 4.0 International"))

(define %cc-by-sa-button
  '(a (@ (class "cc-button")
         (href "https://creativecommons.org/licenses/by-sa/4.0/"))
      (img (@ (src "https://licensebuttons.net/l/by-sa/4.0/80x15.png")))))

(define %piwik-code
  '((script (@ (type "text/javascript") (src "/js/piwik.js")))
    (noscript
     (p (img (@ (src "//stats.dthompson.us/piwik.php?idsite=3")
                (style "border:0;")
                (alt "")))))))

(define (link name uri)
  `(a (@ (href ,uri)) ,name))

(define (first-paragraph post)
  (let loop ((sxml (post-sxml post))
             (result '()))
    (match sxml
      (() (reverse result))
      ((or (('p ...) _ ...) (paragraph _ ...))
       (reverse (cons paragraph result)))
      ((head . tail)
       (loop tail (cons head result))))))

(define dthompson-theme
  (theme #:name "dthompson"
         #:layout
         (lambda (site title body)
           `((doctype "html")
             (head
              (meta (@ (charset "utf-8")))
              (title ,(string-append title " — " (site-title site)))
              ,(stylesheet "reset")
              ,(stylesheet "fonts")
              ,(stylesheet "dthompson"))
             (body
              (div (@ (class "container"))
                   (div (@ (class "nav"))
                        (ul (li ,(link "David Thompson" "/"))
                            (li (@ (class "fade-text")) "λ")
                            (li ,(link "About" "/about.html"))
                            (li ,(link "Blog" "/index.html"))
                            (li ,(link "Projects" "/projects.html"))))
                   ,body
                   (footer (@ (class "text-center"))
                           (p (@ (class "copyright"))
                              "© 2015 David Thompson"
                              ,%cc-by-sa-button)
                           (p "The text and images on this site are
free culture works available under the " ,%cc-by-sa-link " license.")
                           (p "This website is built with "
                              (a (@ (href "http://haunt.dthompson.us"))
                                 "Haunt")
                              ", a static site generator written in "
                              (a (@ (href "https://gnu.org/software/guile"))
                                 "Guile Scheme")
                              "."))))))
         #:post-template
         (lambda (post)
           `((h1 (@ (class "title")),(post-ref post 'title))
             (div (@ (class "date"))
                  ,(date->string (post-date post)
                                 "~B ~d, ~Y"))
             (div (@ (class "post"))
                  ,(post-sxml post))))
         #:collection-template
         (lambda (site title posts prefix)
           (define (post-uri post)
             (string-append "/" (or prefix "")
                            (site-post-slug site post) ".html"))

           `((h1 ,title)
             ,(map (lambda (post)
                     (let ((uri (string-append "/"
                                               (site-post-slug site post)
                                               ".html")))
                       `(div (@ (class "summary"))
                             (h2 (a (@ (href ,uri))
                                    ,(post-ref post 'title)))
                             (div (@ (class "date"))
                                  ,(date->string (post-date post)
                                                 "~B ~d, ~Y"))
                             (div (@ (class "post"))
                                  ,(first-paragraph post))
                             (a (@ (href ,uri)) "read more ➔"))))
                   posts)))))

;; (define (static-page file theme reader)
;;   (lambda (site posts)
;;     (make-page "foo.html"
;;                (with-layout theme ))))

(define %collections
  `(("Recent Blog Posts" "index.html" ,posts/reverse-chronological)))

(define parse-lang
  (let ((rx (make-regexp "-*-[ ]+([a-z]*)[ ]+-*-")))
    (lambda (port)
      (let ((line (read-line port)))
        (match:substring (regexp-exec rx line) 1)))))

(define (maybe-highlight-code source)
  (call-with-input-string source
    (lambda (port)
      (let ((lang (string->symbol (parse-lang port))))
        (if lang
            (highlights->sxml
             (highlight (match lang
                          ('scheme lex-scheme)
                          ('xml    lex-xml))
                        port))
            source)))))

(define (sxml-identity . args) args)

(define (highlight-code . tree)
  (sxml-match tree
    ((pre (@ . ,attrs) ,source)
     `(pre (@ ,@attrs)
           ,(maybe-highlight-code source)))))

(define %texi-rules
  `((pre . ,highlight-code)
    (*text* . ,(lambda (tag str) str))
    (*default* . ,sxml-identity)))

(define (texi->shtml port)
  (let ((tree (stexi->shtml (texi-fragment->stexi port))))
    (pre-post-order tree %texi-rules)))

(define texinfo-reader
  (make-reader (make-file-extension-matcher "texi")
               (lambda (file)
                 (call-with-input-file file
                   (lambda (port)
                     (values (read-metadata-headers port)
                             (texi->shtml port)))))))

(site #:title "dthompson"
      #:domain "dthompson.us"
      #:default-metadata
      '((author . "David Thompson")
        (email  . "davet@gnu.org"))
      #:readers (list (make-skribe-reader #:modules '((haunt skribe utils)
                                                      (skribe-utils)))
                      commonmark-reader
                      texinfo-reader)
      #:builders (list (blog #:theme dthompson-theme #:collections %collections)
                       (atom-feed)
                       (atom-feeds-by-tag)
                       (static-directory "css")
                       (static-directory "fonts")
                       (static-directory "images")))