From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!.POSTED!not-for-mail From: Amirouche Newsgroups: gmane.lisp.guile.devel Subject: What's required to include sxml->html? Date: Sun, 3 Sep 2017 13:40:48 +0200 Message-ID: <0bdbd22c-99a1-505d-bada-d96621c02ca0@hypermove.net> NNTP-Posting-Host: blaine.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="------------5472AE663EECA37F55921FEA" X-Trace: blaine.gmane.org 1504438789 28082 195.159.176.226 (3 Sep 2017 11:39:49 GMT) X-Complaints-To: usenet@blaine.gmane.org NNTP-Posting-Date: Sun, 3 Sep 2017 11:39:49 +0000 (UTC) User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:52.0) Gecko/20100101 Thunderbird/52.2.1 To: guile-devel@gnu.org Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Sun Sep 03 13:39:34 2017 Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by blaine.gmane.org with esmtp (Exim 4.84_2) (envelope-from ) id 1doTFR-0006JF-Jc for guile-devel@m.gmane.org; Sun, 03 Sep 2017 13:39:29 +0200 Original-Received: from localhost ([::1]:34601 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1doTFX-00077M-1H for guile-devel@m.gmane.org; Sun, 03 Sep 2017 07:39:35 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:57639) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1doTFH-00073y-Vr for guile-devel@gnu.org; Sun, 03 Sep 2017 07:39:25 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1doTFC-0000rr-LD for guile-devel@gnu.org; Sun, 03 Sep 2017 07:39:19 -0400 Original-Received: from relay4-d.mail.gandi.net ([217.70.183.196]:37792) by eggs.gnu.org with esmtps (TLS1.0:DHE_RSA_AES_256_CBC_SHA1:32) (Exim 4.71) (envelope-from ) id 1doTFC-0000rI-ER for guile-devel@gnu.org; Sun, 03 Sep 2017 07:39:14 -0400 Original-Received: from [IPv6:2a01:e35:2ef3:d930:64e5:b859:de44:cfe7] (unknown [IPv6:2a01:e35:2ef3:d930:64e5:b859:de44:cfe7]) (Authenticated sender: amirouche@hypermove.net) by relay4-d.mail.gandi.net (Postfix) with ESMTPSA id 3499F17209A for ; Sun, 3 Sep 2017 13:39:09 +0200 (CEST) Content-Language: en-US X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] [fuzzy] X-Received-From: 217.70.183.196 X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.21 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Original-Sender: "guile-devel" Xref: news.gmane.org gmane.lisp.guile.devel:19272 Archived-At: This is a multi-part message in MIME format. --------------5472AE663EECA37F55921FEA Content-Type: text/plain; charset=utf-8; format=flowed Content-Transfer-Encoding: 7bit What's required to include sxml->html inside guile? --------------5472AE663EECA37F55921FEA Content-Type: text/x-scheme; name="html.scm" Content-Transfer-Encoding: 8bit Content-Disposition: attachment; filename="html.scm" ;;; Copyright © 2015 David Thompson ;;; Copyright © 2016-2017 Amirouche Boubekki ;;; ;;; 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 . ;; ChangeLog: ;; ;; - 2017-XX-XX: add support for script tags ;; (define-module (web html)) (use-modules (ice-9 rdelim)) (use-modules (sxml simple)) (use-modules (srfi srfi-26)) (use-modules (ice-9 match)) (use-modules (ice-9 format)) (use-modules (ice-9 hash-table)) (use-modules (srfi srfi-1)) (use-modules (web uri)) (use-modules ((sxml xpath) #:renamer (symbol-prefix-proc 'sxml:))) ;;; ;;; sxml->html ;;; (define %void-elements '(area base br col command embed hr img input keygen link meta param source track wbr)) (define (void-element? tag) "Return #t if TAG is a void element." (pair? (memq tag %void-elements))) (define %escape-chars (alist->hash-table '((#\" . "quot") (#\& . "amp") (#\' . "apos") (#\< . "lt") (#\> . "gt")))) (define (string->escaped-html s port) "Write the HTML escaped form of S to PORT." (define (escape c) (let ((escaped (hash-ref %escape-chars c))) (if escaped (format port "&~a;" escaped) (display c port)))) (string-for-each escape s)) (define (object->escaped-html obj port) "Write the HTML escaped form of OBJ to PORT." (string->escaped-html (call-with-output-string (cut display obj <>)) port)) (define (attribute-value->html value port) "Write the HTML escaped form of VALUE to PORT." (if (string? value) (string->escaped-html value port) (object->escaped-html value port))) (define (attribute->html attr value port) "Write ATTR and VALUE to PORT." (format port "~a=\"" attr) (attribute-value->html value port) (display #\" port)) (define (element->html tag attrs body port) "Write the HTML TAG to PORT, where TAG has the attributes in the list ATTRS and the child nodes in BODY." (format port "<~a" tag) (for-each (match-lambda ((attr value) (display #\space port) (attribute->html attr value port))) attrs) (cond ((and (null? body) (void-element? tag)) (display " />" port)) ((eqv? tag 'script) (display #\> port) (unless (null? body) (display (car body) port)) (display "" port)) (else (begin (display #\> port) (for-each (cut sxml->html <> port) body) (format port "" tag))))) (define (doctype->html doctype port) (format port "" doctype)) (define* (sxml->html tree #:optional (port (current-output-port))) "Write the serialized HTML form of TREE to PORT." (match tree (() *unspecified*) (('doctype type) (doctype->html type port)) (((? symbol? tag) ('@ attrs ...) body ...) (element->html tag attrs body port)) (((? symbol? tag) body ...) (element->html tag '() body port)) ((nodes ...) (for-each (cut sxml->html <> port) nodes)) ((? string? text) (string->escaped-html text port)) ;; Render arbitrary Scheme objects, too. (obj (object->escaped-html obj port)))) (export sxml->html) --------------5472AE663EECA37F55921FEA--