;;; Copyright © 2015  Amirouche Boubekki <address@hidden>
;;; Copyright © 2005, 2006 Ludovic Courtès <address@hidden>
;;;
;;; 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, see
;;; <http://www.gnu.org/licenses/>.

;; sfx.scm
;;
;; sxml and skribe based mini html template engine
;;
;; takes as input a quasiquoted pseudo sxml e.g.:
;;
;; `(html
;;   (head
;;    (meta (@ :charset "utf-8"))
;;    (title [This is a page generated from scheme])
;;    (meta (@ :name "author" :content "Amirouche BOUBEKKI <address@hidden>"))
;;    (meta (@ :name "viewport" :content "width=device-width, initial-scale=1"))
;;    (link (@ :rel "stylesheet" :href "static/css/bootstrap.min.css"))
;;    (link (@ :rel "stylesheet" :href "static/css/bootstrap-theme.min.css"))
;;    (link (@ :rel "stylesheet" :href "static/css/main.css")))  
;;   (body (@ :class "index")
;;         (div (@ :class container)
;;              (div (@ :class "header clearfix")
;;                   (nav
;;                    (ul (@ :class "nav nav-pills pull-right")                     
;;                        (li (@ :role "presentation" :class "active")
;;                            (a (@ :href "#") [Home]))
;;                        (li (@ :role "presentation" )
;;                            (a (@ :href "#") [About]))
;;                        (li (@ :role "presentation" )
;;                            (a (@ :href "#") [Contact]))))
;;                   (h3 (@ :class "text-muted") [hypermove.net])))))
;;
;; It's similar to sxml except the syntax to declare attributes is less verbose
;; *and* you can use some scheme code but they are limitations. You can (use-modules)
;; and variable must wrapped with `(make-parameter)`. The sxml must appear last in the file.
;;
;; Use of `map` inside a template:
;;
;;  (div (@ :class "row")
;;    (ul ,(map (lambda (person) `(li ,(person-name person)))
;;              persons)))
;;
;; Use of `extend` inside a template:
;;
;;
;;   (extend "base.sfx"
;;           (current-module)
;;           `((title `(h1 [Héllo again hacker!!]))
;;             (intro "This is a little presentation of sfx template language")))
;;
;; Mind the fact  that there is no quasiquote at the beginning
;; of this template, since it's a procedure call and not skribe
;; sxml.
;;
;; Then you can use in `base.sfx` template `title` and `intro`
;; like variables using the unquote syntax e.g. `,(title)`.
;;
;; Here is an example `base.sfx`:
;;
;;   `(html
;;     (head
;;      (meta (@ :charset "utf-8"))
;;      (title [This is a page generated from scheme])
;;      (meta (@ :name "author" :content "Amirouche BOUBEKKI <address@hidden>"))
;;      (meta (@ :name "viewport" :content "width=device-width, initial-scale=1"))
;;      (link (@ :rel "stylesheet" :href "static/css/bootstrap.min.css"))
;;      (link (@ :rel "stylesheet" :href "static/css/bootstrap-theme.min.css"))
;;      (link (@ :rel "stylesheet" :href "static/css/main.css")))  
;;     (body (@ :class "index")
;;           (div (@ :class container)
;;                (div (@ :class "header clearfix")
;;                     (nav
;;                      (ul (@ :class "nav nav-pills pull-right")                     
;;                          (li (@ :role "presentation" :class "active")
;;                              (a (@ :href "#") [Home]))
;;                          (li (@ :role "presentation" )
;;                              (a (@ :href "mailto:address@hidden") [Contact]))))
;;                     (h3 (@ :class "text-muted") [hyperdev.fr]))
;;                (h1 [,(title)])
;;                ,(intro))))
;;

(use-modules (srfi srfi-1))
(use-modules ((srfi srfi-26) #:select (cut)))

(use-modules (ice-9 r5rs))  ;; scheme-report-environment
(use-modules (ice-9 match))
(use-modules (ice-9 format))
(use-modules (ice-9 hash-table))
(use-modules (ice-9 optargs))
(use-modules (ice-9 local-eval))

(use-modules (sxml simple))

;; the Scheme reader composition framework (guile-reader)
(use-modules ((system reader) #:renamer (symbol-prefix-proc 'r:)))

;;;
;;; skribe reader (borrowed from skribilo)
;;;

(define (make-colon-free-token-reader tr)
  ;; Stolen from `guile-reader' 0.3.
  "If token reader @var{tr} handles the @code{:} (colon) character, remove it
from its specification and return the new token reader."
  (let* ((spec (r:token-reader-specification tr))
         (proc (r:token-reader-procedure tr)))
    (r:make-token-reader (filter (lambda (chr)
                                   (not (char=? chr #\:)))
                                 spec)
                         proc)))

(define &sharp-reader
  ;; The reader for what comes after a `#' character.
  (let* ((dsssl-keyword-reader  ;; keywords à la `#!key'
          (r:make-token-reader #\!
                               (r:token-reader-procedure
                                (r:standard-token-reader 'keyword)))))
      (r:make-reader (cons dsssl-keyword-reader
                           (map r:standard-token-reader
                                '(character srfi-4 vector
                                  number+radix boolean
                                  srfi30-block-comment
                                  srfi62-sexp-comment)))
                     #f ;; use default fault handler
                     'reader/record-positions)))

(define (make-skribe-reader)
  (let ((colon-keywords ;; keywords à la `:key' fashion
         (r:make-token-reader #\:
                              (r:token-reader-procedure
                               (r:standard-token-reader 'keyword))))
        (symbol-misc-chars-tr
         ;; Make sure `:' is handled only by the keyword token reader.
         (make-colon-free-token-reader
          (r:standard-token-reader 'r6rs-symbol-misc-chars))))


    ;; Note: we use the `r6rs-symbol-*' and `r6rs-number' token readers since
    ;; they consider square brackets as delimiters.
    (r:make-reader (cons* (r:make-token-reader #\# &sharp-reader)
                          colon-keywords
                          symbol-misc-chars-tr
                          (map r:standard-token-reader
                               `(whitespace
                                 sexp string r6rs-number
                                 r6rs-symbol-lower-case
                                 r6rs-symbol-upper-case
                                 quote-quasiquote-unquote
                                 semicolon-comment
                                 skribe-exp)))
                   #f ;; use the default fault handler
                   'reader/record-positions
                   )))

(define skribe (make-skribe-reader))

;;;
;;; sfx template specifics
;;;

(define (keywords->attributes keywords)
  "Convert (list :one \"key\" :two \"word\") to sxml attributes (list ('one \"key\") ('two \"word\"))"
  (match keywords
    ((keyword value rest ...) (cons (list (keyword->symbol keyword) value) (keywords->attributes rest)))
    (_ '())))

(define (sfx->sxml sfx)
  "Turn sfx template into sxml"
  (match sfx
    (('quasiquote value) (map sfx->sxml value))
    (('unquote value) (list 'unquote value))
    ((tag ('@ keywords ...)) (list tag (append '(@) (keywords->attributes keywords))))
    ((tag ('@ keywords ...) children ...) (append (list tag (append '(@) (keywords->attributes keywords))) (map sfx->sxml children)))
    
    ((tag children ...) (append (list tag) (map sfx->sxml children)))
    
    ((value ...) (map sfx->sxml value))
    (_ sfx)))

;;;
;;; template rendering
;;;

(define* (read-eval-template env #:optional out)
  (let ((sexp (skribe)))
    (if (eof-object? sexp)
        out
        (read-eval-template env (flyeval sexp env)))))

(define (template->xml env port)
  (sxml->xml (flyeval (list 'quasiquote (sfx->sxml (read-eval-template env))) env)) port)

(define (flyeval sexpr env)
  ((local-eval `(lambda () ,sexpr) env)))

;;;
;;; template procedures
;;;

(define (extend base env context)
  "Extend BASE template with values defined in ENV and CONTEXT.

   This must be used inside a template"
  (map (lambda (pair)
         (match pair
                ((name value)
                 (module-add! env
                              name
                              (make-variable 
                               (make-parameter (flyeval value env)))))))
       context)
  (call-with-output-string
   (lambda (port)
     (with-input-from-file base
       (lambda ()
         (template->xml env port))))))

;;;
;;; render
;;;

(define (render template bindings)
  (define env (scheme-report-environment 5))
  (module-add! env 'extend (make-variable extend))
  (module-add! env 'current-module (make-variable current-module))
  (map (lambda (pair)
         (match pair ((name value) (module-add! env name (make-variable value)))))
       bindings)
  (call-with-output-string
   (lambda (port)
     (with-input-from-file template
       (lambda ()
         (display "<!DOCTYPE html>")
         (template->xml env port))))))

;;;
;;; Example use
;;;
;;; This requires at least a `index.sfx` file and `person.scm` where
;;; a `<person>` record is defined.
;;;

;; (use-modules (person))

;; (define persons (list (make-person "amirouche" 30)
;;                       (make-person "julien" 30)
;;                       (make-person "mez" 27)
;;                       (make-person "moh" 113)))

;; (define bindings `((value ,(make-parameter 42))
;;                    (title '(h1 "Héllo (again (and again)) hacker!"))
;;                    (persons ,persons)))

;; (with-output-to-file "index.html"
;;   (lambda () (render "index.sfx" bindings)))