Gauche:JavaScriptをパースする

• rfc.jsonを改造してパース
  JavaScriptの変数宣言部をパースしてデータを読み取りたいときがあったので、rfc.jsonを改造してみました。
  http://chaton.practical-scheme.net/gauche/a/2013/03/12

  ;; JavaScriptの変数表現をパースするように
  ;; rfc.jsonを改造
  
  ; 文字列表現 "..." '....' の二種類ある。
  
  ;;;
  ;;; json.scm - JSON (RFC4627) Parser
  ;;;
  ;;;   Copyright (c) 2006 Rui Ueyama (rui314@gmail.com)
  ;;;
  ;;;   Redistribution and use in source and binary forms, with or without
  ;;;   modification, are permitted provided that the following conditions
  ;;;   are met:
  ;;;
  ;;;   1. Redistributions of source code must retain the above copyright
  ;;;      notice, this list of conditions and the following disclaimer.
  ;;;
  ;;;   2. Redistributions in binary form must reproduce the above copyright
  ;;;      notice, this list of conditions and the following disclaimer in the
  ;;;      documentation and/or other materials provided with the distribution.
  ;;;
  ;;;   3. Neither the name of the authors nor the names of its contributors
  ;;;      may be used to endorse or promote products derived from this
  ;;;      software without specific prior written permission.
  ;;;
  ;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  ;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  ;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
  ;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
  ;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  ;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
  ;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
  ;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
  ;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  ;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  ;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  ;;;
  
  ;;; http://www.ietf.org/rfc/rfc4627.txt
  
  ;; NOTE: This module depends on parser.peg, whose API is not officially
  ;; fixed.  Hence do not take this code as an example of parser.peg;
  ;; this will likely to be rewritten once parser.peg's API is changed.
  
  (define-module js-object
    (use gauche.parameter)
    (use gauche.sequence)
    (use gauche.generator)
    (use parser.peg)
    (use srfi-13)
    (use srfi-14)
    (use srfi-43)
    (export <js-parse-error>
            parse-js parse-js-string
            parse-js*
  
            js-array-handler js-object-handler js-special-handler
  
            js-parser                   ;experimental
            ))
  (select-module js-object)
  
  ;; NB: We have <js-parse-error> independent from <parse-error> for
  ;; now, since parser.peg's interface may be changed later.
  (define-condition-type <js-parse-error> <error> #f
    (position)                            ;stream position
    (objects))                            ;offending object(s) or messages
  
  (define-condition-type <js-construct-error> <error> #f
    (object))                             ;offending object
  
  (define js-array-handler   (make-parameter list->vector))
  (define js-object-handler  (make-parameter identity))
  (define js-special-handler (make-parameter identity))
  
  (define (build-array   elts)   ((js-array-handler) elts))
  (define (build-object  pairs)  ((js-object-handler) pairs))
  (define (build-special symbol) ((js-special-handler) symbol))
  
  ;;;============================================================
  ;;; Parser
  ;;;
  (define %ws ($skip-many ($one-of #[ \t\r\n])))
  
  (define %begin-array     ($seq ($char #\[) %ws))
  (define %begin-object    ($seq ($char #\{) %ws))
  (define %end-array       ($seq ($char #\]) %ws))
  (define %end-object      ($seq ($char #\}) %ws))
  (define %name-separator  ($seq ($char #\:) %ws))
  (define %value-separator ($seq ($char #\,) %ws))
  
  
  (define %special
    ($fmap ($ build-special $ string->symbol $ rope-finalize $)
           ($or ($string "false") ($string "true") ($string "null"))))
  
  (define %value
    ($lazy
     ($fmap (^[v _] v) ($or %special %object %array %number %string) %ws)))
  
  (define %array
    ($fmap (^[_0 lis _1] (build-array (rope-finalize lis)))
           %begin-array ($sep-by %value %value-separator) %end-array))
  
  (define %number
    (let* ([%sign ($or ($do [($char #\-)] ($return -1))
                       ($do [($char #\+)] ($return 1))
                       ($return 1))]
           [%digits ($fmap ($ string->number $ list->string $) ($many digit 1))]
           [%int %digits]
           [%frac ($do [($char #\.)]
                       [d ($many digit 1)]
                       ($return (string->number (apply string #\0 #\. d))))]
           [%exp ($fmap (^[_ s d] (* s d)) ($one-of #[eE]) %sign %digits)])
      ($fmap (^[sign int frac exp]
               (let1 mantissa (+ int frac)
                 (* sign (if exp (exact->inexact mantissa) mantissa)
                    (if exp (expt 10 exp) 1))))
             %sign %int ($or %frac ($return 0)) ($or %exp ($return #f)))))
  
  (define (make-string q)
    (let* ([%quote ($char q)]
           [%escape ($char #\\)]
           [%hex4 ($fmap (^s (string->number (list->string s) 16))
                         ($many hexdigit 4 4))]
           [%special-char
            ($do %escape
                 ($or ($char q)
                      ($char #\\)
                      ($char #\/)
                      ($do [($char #\b)] ($return #\x08))
                      ($do [($char #\f)] ($return #\page))
                      ($do [($char #\n)] ($return #\newline))
                      ($do [($char #\r)] ($return #\return))
                      ($do [($char #\t)] ($return #\tab))
                      ($do [($char #\u)] (c %hex4) ($return (ucs->char c)))))]
           [%unescaped ($none-of (char-set q) )]
           [%body-char ($or %special-char %unescaped)]
           [%string-body ($->rope ($many %body-char))])
      ($between %quote %string-body %quote)))
  
  ; 文字列はシングルクオートとダブルクオート
  (define %string ($or (make-string #\') (make-string #\") ) )
  
  (define %word ($->rope ($do [h ($one-of #[A-Za-z_$])]
                              [t ($many-chars #[A-Za-z0-9_$])]
                              ($return (cons h t)))))
  
  ; objectのキーは引用符つき、と引用符なしを許す。
  (define %key ($or %word %string))
  
  (define %object
    (let1 %member ($do [k %key] %ws
                       %name-separator
                       [v %value]
                       ($return (cons k v)))
      ($between %begin-object
                ($fmap ($ build-object $ rope-finalize $)
                       ($sep-by %member %value-separator))
                %end-object)))
  
  ; 文字列、Object、配列をパース
  (define js-parser ($seq %ws ($or eof %string %object %array)))
  
  ;; entry point
  (define (parse-js :optional (port (current-input-port)))
    (guard (e [(<parse-error> e)
               ;; not to expose parser.peg's <parse-error>.
               (error <js-parse-error>
                      :position (~ e'position) :objects (~ e'objects)
                      :message (~ e'message))])
      (peg-parse-port js-parser port)))
  
  (define (parse-js-string str)
    (call-with-input-string str (cut parse-js <>)))
  
  (define (parse-js* :optional (port (current-input-port)))
    (guard (e [(<parse-error> e)
               ;; not to expose parser.peg's <parse-error>.
               (error <js-parse-error>
                      :position (~ e'position) :objects (~ e'objects)
                      :message (~ e'message))])
      (generator->list (peg-parser->generator js-parser port))))
  

• その他
  • http://chaton.practical-scheme.net/gauche/a/2013/03/12

    koguro
    Gaucheでの解決策じゃないんですが、そのページのデータだと副作用がなさそうなので、JS処理系に食わせてしまったらどうでしょう。
    齊藤
    ナイスアイデア!!
    

    • yamasushi(2013/04/21 08:30:04 UTC) とりあえず、node.jsを入れてはみたのですが、どうしたものかと思案中です。(汗
      

Tag: parser.peg