Gauche:SXML:SXSLT:tree-transを使ってsxmlを処理する

yamasushi(2013/03/22 10:07:58 UTC) sxmlを処理するのにtree-transをつかってみました。

(use sxml.tree-trans)
(use srfi-13) ;string
(use srfi-1)

; sxml特殊文字のハンドラ
; html5の文字参照をつかう
(define (tokushumoji-handler x)
  (cond
    ((and (symbol? x) (ref hash-html5-entities x #f) ) => identity )
    ((symbol? x) (string-append "&" (symbol->string x)))
    ((number? x) ($ string $ integer->char x ) )
    (else (error (format #f "unknown ~a" x) ) )
  ) )

(※hash-html5-entitiesは"大きな変換テーブルを使うとき"で用意します。)

; listのなかの連続する文字列を連結
(define (list-string-concatenate l)
  ;#?=l
  (cond 
    ((null? l) '())
    ((pair? l)
      (receive (head tail) (span string? l)
        (if (null? head)
          (cons (car tail) 
                ($ list-string-concatenate $ cdr tail) )
          (cons (string-concatenate head) 
                (list-string-concatenate tail))
      ) ) )
    (else l) ) )

; sxmlの特殊文字を文字列にする
; htmlpragで読み込んだsxml用
; ( HtmlPrag http://www.neilvandyke.org/htmlprag/ )
(define (sxml-tokushu sx)
  (post-order sx
    `( 
      (|&|       . ,(^(trigger x) (tokushumoji-handler x) ) )
      ;
      (*text*    . ,(^(trigger x) x ) )
      (*default* . ,(^ x (list-string-concatenate x) ) ) ) ) )

; sxmlを文字列にする
; TODO テーブル内テーブルはどうなる？
; TODO テーブル要素内の改行をとると、テーブルでレイアウトしているときに困る
;      単純にテーブルを使っているときと区別する必要？
; TODO string-trim-both はどれくらい必要か？
(define (sxml->string sx)
  (define (line-handler nl x)
    ($ (cut string-append <> nl ) $ string-trim-both $ string-concatenate x) )
  ;
  (post-order sx
    `(
      (img
        ( ( |@|   . ,(^ (t . sl) (string-concatenate sl) ) )
          ( alt   . ,(^ (t s) (format #f "~a\n" s) ))
          ( title . ,(^ (t s) (format #f "~a\n" s) ))
          ( *text*    . ,(^(t s) s ) )
          ( *default* . ,(^ _ "" ) )
        )
        . ,(^ (t . sl) (string-concatenate sl) ) )
      ;
      (style     *preorder* . ,(^ x "" ) ) ; style削除
      (script    *preorder* . ,(^ x "" ) ) ; script削除
      (*PI*      *preorder* . ,(^ x "" ) ) ; *PI*削除
      (*DECL*    *preorder* . ,(^ x "" ) ) ; *DECL*削除
      (*COMMENT* *preorder* . ,(^ x "" ) ) ; コメント削除
      (|@|       *preorder* . ,(^ x "" ) ) ; 属性削除
      (br        . ,(^ x "\n" ) ) ; brは改行
      (hr        . ,(^ x "\n" ) ) ; hrは改行
      ;
      (|&|  . ,(^(trigger x) (tokushumoji-handler x) ) ) ; 特殊文字
      ;
      (p   . ,(^ (trigger . x) (line-handler "\n\n" x) ) )
      (h1  . ,(^ (trigger . x) (line-handler "\n\n" x) ) )
      (h2  . ,(^ (trigger . x) (line-handler "\n\n" x) ) )
      (h3  . ,(^ (trigger . x) (line-handler "\n\n" x) ) )
      (h4  . ,(^ (trigger . x) (line-handler "\n\n" x) ) )
      (h5  . ,(^ (trigger . x) (line-handler "\n\n" x) ) )
      (h6  . ,(^ (trigger . x) (line-handler "\n\n" x) ) )
      ;
      (span . ,(^ (trigger . x) (line-handler "\n" x) ) )
      ;
      ;リストの処理
      (ul  . ,(^ (trigger . x) (line-handler "\n\n" x) ) )
      (li  . ,(^ (trigger . x) (line-handler "\n"   x) ) )
      ;
      (th . ,(^ (trigger . x)
          ($ string-concatenate $ append x '("\t") )
          ) )
      (td . ,(^ (trigger . x)
          ($ string-concatenate $ append x '("\t") )
          ) )
      ; 余分についた\tをとってから改行
      (tr . ,(^ (trigger . x) (line-handler "\n" x) ) )

      (*text* . ,(^(trigger x)
        ;#?=trigger
        ;#?=x
        (cond
          ( (string? x) (string-trim-both x) )
          ( else x)
          )
        ) )
      ;
      (*default* . ,(^ x
          ;#?=x
          ($ string-concatenate $ cdr x) ) ) ) ) )

tableなどの構造に注目した変換。

; listのなかのlistをspliceする
; (a b c ( d (e) f) g h .. ) --> ( a b c d (e) f g h)
; == `(a b c ,@'(d (e) f) g h)
; (a b c () g h .. ) --> ( a b c g h)
; == `(a b c ,@'() g h)
(define (list-splice l)
  (cond
    ((null? l) '())
    ((pair? l)
      (append (if ($ list? $ car l) (car l) ($ list $ car l) ) ($ list-splice $ cdr l) ) )
  ) )

; sxmlを文字列のリストにする
(define (sxml->string-list sx)
  (define (node-handler x)
    ($ filter
      (^x (or
        (and (string? x)
          ($ not $ string-null? x)
          ($ not $ #/^\s*$/ x ) )
        (pair? x ) ) )
    $ map
      (^x
        (cond
          ((string? x) (string-trim-both x))
          ((pair? x)
            (if (null? (cdr x) ) (car x) x ) )
          (else     x)))
    $ list-splice $ list-string-concatenate x) )
  (define list-handler ($ list $ node-handler $) )
  ;#?=sx

  (post-order sx
    `(
      (img
        ( ( |@|   . ,(^ ( _ . sl ) (string-concatenate sl)) )
          ( alt   . ,(^ ( _ s ) (format #f "~a\n" s) ))
          ( title . ,(^ ( _ s ) (format #f "~a\n" s) ))
          ( *text*    . ,(^ (t s) s ) )
          ( *default* . ,(^ _ "" ) )
        )
        . ,(^ (t . sl) (string-concatenate sl))  )
      ;
      (style     *preorder* . ,(^ x "" ) ) ; style削除
      (script    *preorder* . ,(^ x "" ) ) ; script削除
      (*PI*      *preorder* . ,(^ x "" ) ) ; *PI*削除
      (*DECL*    *preorder* . ,(^ x "" ) ) ; *DECL*削除
      (*COMMENT* *preorder* . ,(^ x "" ) ) ; コメント削除
      (|@|       *preorder* . ,(^ x "" ) ) ; 属性削除
      (br        *preorder* . ,(^ x "\n" ) ) ; brは
      (hr        *preorder* . ,(^ x "\n" ) ) ; hrは改行
      ;
      (|&|       . ,(^(trigger x) (tokushumoji-handler x) ) ) ; 特殊文字
      ;
      (table     . ,(^ (t . x) (list-handler x) ) )
      (tr        . ,(^ (t . x) (list-handler x) ) )
      (th        . ,(^ (t . x) (list-handler x) ) )
      (td        . ,(^ (t . x) (list-handler x) ) )
      (ul        . ,(^ (t . x) (list-handler x) ) )
      (li        . ,(^ (t . x) (list-handler x) ) )
      ;
      (div       . ,(^ (t . x) (list-handler x) ) )
      ;
      (*text*    . ,(^ x (cadr x) ) )
      (*default* . ,(^ (t . x) (node-handler x) ) )
 ) ) )

Tags: sxml.tree-trans, SXML, SXSLT