;;; Lisp2HTML: Write Lisp to write HTML+CSS pages. ;;; Copyright (C) <2009> ;;; ;;; 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 . (defparameter *protect-html-set* '(("&" "&") ;; & must be in first place ("<" "<") (">" ">"))) (defun protect-html-single (old new string &optional (start 0)) (let ((pos (search old string :start2 start))) (if pos (protect-html-single old new (concatenate 'string (subseq string 0 pos) new (subseq string (+ pos (length old)))) (+ pos (length old))) string))) (defun protect-html (string &optional (set-list *protect-html-set*)) (if set-list (let ((set (first set-list))) (protect-html (protect-html-single (first set) (second set) string) (rest set-list))) string)) (defun header (str title) (let ((title (protect-html title))) (format str " ~A
" title title))) (defun prepare-navigation (str) (format str "
")) (defun do-footer (str &rest footer) (format str "
" (if (first footer) footer '("")))) (defun title (&rest title) (format nil "

~A~{~A~}

" (first title) (rest title))) (defun subtitle (&rest title) (format nil "
~{~A~}
" title)) (defun a (href &rest string) (format nil "~{~A~}" href (if string string (list href)))) (defun p (&rest lines) (format nil "

~{~A~}

" lines)) (defun section (id title &rest line) (format nil "
^ return

~A

~{~A~}~%" id title line)) (defun section-nav (id title &rest line) (declare (ignore line)) (format nil "
  • ~A
    • " id title)) (defun br () (format nil "
    ~%")) (defun img (image alt &optional width height) (labels ((maybe (string val) (if val (format nil "~A='~A' " string val) ""))) (format nil "" image (maybe "width" width) (maybe "height" height) (maybe "alt" alt)))) (defun itemize (&rest lines) (format nil " " lines)) (defun code (&rest lines) (format nil "
    ~{~A~}
    " lines)) (defun group (&rest items) (format nil "~{~A~}" items)) (defun footer (&rest line) (format nil "~{~A~}" line)) (let ((jours '("Lundi" "Mardi" "Mercredi" "Jeudi" "Vendredi" "Samedi" "Dimanche")) (mois '("Janvier" "Fevrier" "Mars" "Avril" "Mai" "Juin" "Juillet" "Aout" "Septembre" "Octobre" "Novembre" "Decembre")) (days '("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday")) (months '("January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December"))) (defun update-date (&optional (lang :us)) (multiple-value-bind (second minute hour date month year day) (get-decoded-time) (declare (ignore second minute hour)) (if (equal lang :fr) (format nil "Derniere mise a jour : ~A ~2,'0D ~A ~A" (nth day jours) date (nth (1- month) mois) year) (format nil "Last update: ~A ~A ~2,'0D ~A" (nth day days) (nth (1- month) months) date year))))) (defmacro with-html (() &body body) `(with-output-to-string (str) (header str (second ',(assoc 'title body))) (format str "~A" ,(assoc 'title body)) (format str "~A" ,(assoc 'subtitle body)) (prepare-navigation str) ,@(loop for b in body when (equal (first b) 'section) collect `(format str "~A~%" (section-nav ,@(rest b)))) (end-navigation str) ,@(loop for b in (remove (assoc 'footer body) (remove (assoc 'subtitle body) (remove (assoc 'title body) body))) collect `(format str "~A~%" ,b)) (do-footer str ,(assoc 'footer body)))) (defmacro html->file ((file) &body body) `(with-open-file (stream ,file :direction :output :if-exists :supersede) (format stream "~A" (with-html () ,@body)))) ;;(with-open-file (stream "test.html" :direction :output ;; :if-exists :supersede) ;; (format stream "~A" ;; (with-html () ;; (title "My title" " foo bar") ;; (subtitle "My full description" (br) ;; "Pouf pouf pouf") ;; (section "S1" "Section 1") ;; (p "A first paragraph ;;under many lines" (br) ;;"Return to the line begining") ;; (p "Another paragraph" ;; (br) ;; (a "http://hocwp.free.fr" "hocwp.free")) ;; (itemize "toto" ;; (group (a "http://google.fr" "Google") " a test with" " many things") ;; "plop" ;; "kdfslm" ;; "poidsf") ;; (code "(defun lisp () ;; (print 'toto))") ;; (section "S2" "Section 2") ;; (p "plop") ;; (footer "Last update : sat 11 apr 2009" (br) ;; (a "http://validator.w3.org/check?uri=referer" ;; (img "http://www.w3.org/Icons/valid-xhtml10" ;; 88 31 "Valid XHTML 1.0 Strict")))))) ;; ;; ;;(html->file ("test.html") ;; (title "My title" " foo bar") ;; (subtitle "My full description" (br) ;; "Pouf pouf pouf") ;; (section "S1" "Section 1") ;; (p "A first paragraph ;;under many lines" (br) ;;"Return to the line begining") ;; (p "Another paragraph" ;; (br) ;; (a "http://hocwp.free.fr" "hocwp.free")) ;; (itemize "toto" ;; (group (a "http://google.fr" "Google") " a test with" " many things") ;; "plop" ;; "kdfslm" ;; "poidsf") ;; (code "(defun lisp () ;; (print 'toto))") ;; (section "S2" "Section 2") ;; (p "plop") ;; (footer "Last update : sat 11 apr 2009" (br) ;; (a "http://validator.w3.org/check?uri=referer" ;; (img "http://www.w3.org/Icons/valid-xhtml10" ;; 88 31 "Valid XHTML 1.0 Strict"))))))