;;; Copyright © 2015 Amirouche Boubekki
;;; Copyright © 2005, 2006 Ludovic Courtès
;;;
;;; 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
;;; .
;; 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 "))
;; (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.
;; It's possible to pass variables to the template but right now it's hardcoded cf. `flyeval`.
;;
(use-modules (srfi srfi-1))
(use-modules ((srfi srfi-26) #:select (cut)))
(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 (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)))
(define skribe (make-skribe-reader))
;; FIXME: the environment is hardcoded inside flyeval
(use-modules (person))
(define value (make-parameter 42))
(define amirouche (make-person "amirouche" 30))
(define env (let ((value value)
(amirouche amirouche))
(the-environment)))
(define (flyeval sexpr)
((local-eval `(lambda () ,sexpr) env)))
(define* (read-eval-template #:optional out)
(let ((sexp (skribe)))
(if (eof-object? sexp)
out
(read-eval-template (flyeval sexp)))))
(define (output)
(with-input-from-file "index.scm"
(lambda ()
(display "")
(sxml->xml (flyeval (list 'quasiquote (sfx->sxml (read-eval-template))))))))
;; (output) ;; display html to stdout
(with-output-to-file "index.html"
(lambda () (output)))