Index: /hh2008/hayamiz/trunk/hascheme/peg-parser.scm
===================================================================
--- /hh2008/hayamiz/trunk/hascheme/peg-parser.scm (revision 15)
+++ /hh2008/hayamiz/trunk/hascheme/peg-parser.scm (revision 15)
@@ -0,0 +1,732 @@
+#!/usr/bin/env gosh
+;; -*- coding: utf-8 mode: scheme -*-
+
+;;;
+;;; Original PEG Grammars
+;;;
+;; Hierarchical syntax
+; Grammar <- Spacing Definition+ EndOfFile
+; Definition <- Identifier LEFTARROW Expression
+;
+; Expression <- Sequence (SLASH Sequence)*
+; Sequence <- Prefix*
+; Prefix <- (AND / NOT)? Suffix
+; Suffix <- Primary (QUESTION / STAR / PLUS)?
+; Primary <- Identifier !LEFTARROW
+;          / OPEN Expression CLOSE
+;          / Literal / Class / DOT
+;
+;; Lexical syntax
+; Identifier <- IdentStart IdentCont* Spacing
+; IdentStart <- [a-zA-Z_]
+; IdentCont <- IdentStart / [0-9]
+;
+; Literal <- ['] (!['] Char)* ['] Spacing
+;          / ["] (!["] Char)* ["] Spacing
+; Class <- '[' (!']' Range)* ']' Spacing
+; Range <- Char '-' Char / Char
+; Char <- '\\' [nrt'"\[\]\\]
+;       / '\\' [0-2][0-7][0-7]
+;       / '\\' [0-7][0-7]?
+;       / !'\\' .
+;
+; LEFTARROW <- '<-' Spacing
+; SLASH <- '/' Spacing
+; AND <- '&' Spacing
+; NOT <- '!' Spacing
+; QUESTION <- '?' Spacing
+; STAR <- '*' Spacing
+; PLUS <- '+' Spacing
+; OPEN <- '(' Spacing
+; CLOSE <- ')' Spacing
+; DOT <- '.' Spacing
+;
+; Spacing <- (Space / Comment)*
+; Comment <- '#' (!EndOfLine .)* EndOfLine
+; Space <- ' ' / '\t' / EndOfLine
+; EndOfLine <- '\r\n' / '\n' / '\r'
+; EndOfFile <- !.
+
+;;;
+;;; S-exp PEG Grammar
+;;;
+;
+;; Hierarchical syntax
+;
+; Definition <- Identifier LEFTARROW Expression
+;
+; Expression <- Sequence (SLASH Sequence)*
+; Sequence <- Prefix* (RETURN .)?
+; Prefix <- IdentifierClause / (AND / NOT)? Suffix
+; Suffix <- Primary (QUESTION / STAR / PLUS)?
+; IdentifierClause <- OPEN CaptureName Primary CLOSE
+; Primary <- Identifier !LEFTARROW
+;          / OPEN Expression CLOSE
+;          / Literal / Class / ANY
+;
+;; Lexical syntax
+;
+; Identifier <- !NonIdentifier <scheme-symbol>
+; NonIdentifier <- OPEN / CLOSE
+; CaptureName <- <scheme-keyword>
+; Literal <- <scheme-string> / <scheme-char>
+; Class <- <scheme-char-set>
+;
+; OPEN <- |<|
+; CLOSE <- |>|
+; LEFTARROW <- |<-|
+; SLASH <- |/|
+; AND <- |&|
+; NOT <- |!|
+; QUESTION <- |?|
+; STAR <- |*|
+; PLUS <- |+|
+; RETURN <- :return
+; ANY <- |%any%|
+
+; (define-parser math-exp
+;   (additive <- (multitive left-val) #\+ (additive right-val)
+; 	    &return (+ left-val right-val)
+; 	    / multitive)
+;   (multitive <- (primary left-val) #\* (multitive right-val)
+; 	     &return (* left-val right-val)
+; 	     / primary)
+;   (primary <- #\( (additive val) #\) &return val
+; 	   / decimal)
+;   (decimal <- (#[0-9] num-char)
+; 	   &return (- (char->integer num-char) (char->integer #\0))))
+
+(use peg)
+(use util.match)
+
+(define (main args)
+  0)
+
+(define nil ())
+
+(define-class <derivs> ()
+  (; Hierarchical tokens (non-terminals)
+   (grammar :init-keyword :grammar)
+   (definition :init-keyword :definition)
+   (expression :init-keyword :expression)
+   (sequence :init-keyword :sequence)
+   (prefix :init-keyword :prefix)
+   (suffix :init-keyword :suffix)
+   (identifier-clause :init-keyword :identifier-clause)
+   (primary :init-keyword :primary)
+
+   ; Lexical tokens (terminals)
+   (identifier :init-keyword :identifier)
+   (non-identifier :init-keyword :non-identifier)
+   (capture-name :init-keyword :capture-name)
+   (literal :init-keyword :literal)
+   (class :init-keyword :class)
+
+   (open :init-keyword :open)
+   (close :init-keyword :close)
+   (leftarrow :init-keyword :leftarrow)
+   (return :init-keyword :return)
+   (any :init-keyword :any)
+   (plus :init-keyword :plus)
+   (star :init-keyword :star)
+   (question :init-keyword :question)
+   (not :init-keyword :not)
+   (and :init-keyword :and)
+   (slash :init-keyword :slash)
+
+   ; Raw input
+   (token :init-keyword :token :getter deriv-token)
+   ))
+
+(define-macro (define-deriv name)
+  `(define-method ,(string->symbol
+		    (string-append "deriv-" (symbol->string name)))
+     ((derivs <derivs>))
+  (let1 slt (slot-ref derivs ',name)
+    (if (promise? slt)
+	(let1 forced (force slt)
+	  (slot-set! derivs ',name forced)
+	  forced)
+	slt))))
+
+(define-macro (define-derivs . names)
+  `(begin
+     ,@(map
+	(lambda (deriv-name)
+	  `(define-deriv ,deriv-name))
+	names)))
+
+(define-derivs ; define generic function *-deriv
+  ; for hierarchical syntax
+  grammar definition expression sequence prefix suffix primary identifier-clause
+  ; for lexical tokens
+  identifier non-identifier capture-name literal class
+  open close leftarrow slash and not question star plus return any)
+
+(define (make-result val chars)
+  `(:result ,val ,chars))
+
+(define (parse tokens)
+  (let loop((ret-deriv nil) (tokens (cons nil (reverse tokens))))
+    (if (null? tokens)
+	ret-deriv
+	(loop
+	 (letrec
+	     ((deriv
+	       (make <derivs>
+; code for generating code
+; (for-each (lambda (ident) (format #t ":~a (lazy (parse-~a deriv))\n" ident ident)) '(leftarrow slash and not question star plus any))
+
+		 ; hierarychical syntax
+		 :grammar (lazy (parse-grammar deriv))
+		 :definition (lazy (parse-definition deriv))
+		 :expression (lazy (parse-expression deriv))
+		 :sequence (lazy (parse-sequence deriv))
+		 :prefix (lazy (parse-prefix deriv))
+		 :suffix (lazy (parse-suffix deriv))
+		 :identifier-clause (lazy (parse-identifier-clause deriv))
+		 :primary (lazy (parse-primary deriv))
+
+		 ; lexical syntax
+		 :identifier (lazy (parse-identifier deriv))
+		 :non-identifier (lazy (parse-non-identifier deriv))
+		 :capture-name (lazy (parse-capture-name deriv))
+		 :literal (lazy (parse-literal deriv))
+		 :class (lazy (parse-class deriv))
+
+		 :open (lazy (parse-open deriv))
+		 :close (lazy (parse-close deriv))
+		 :leftarrow (lazy (parse-leftarrow deriv))
+		 :slash (lazy (parse-slash deriv))
+		 :and (lazy (parse-and deriv))
+		 :not (lazy (parse-not deriv))
+		 :question (lazy (parse-question deriv))
+		 :star (lazy (parse-star deriv))
+		 :plus (lazy (parse-plus deriv))
+		 :return (lazy (parse-return deriv))
+		 :any (lazy (parse-any deriv))
+
+					;raw input
+		 :token (if (null? tokens) 
+			    nil
+			    (make-result (car tokens) ret-deriv)))))
+	   deriv)
+	 (cdr tokens)))))
+
+(define (parse-grammars pegs)
+  (map
+   (lambda (gram)
+     (let1 gram (flatten-grammar gram)
+       (let* ((ret (deriv-definition (parse gram)))
+	      (derivs (caddr (deriv-token (caddr ret)))))
+	 (if (not (null? derivs))
+	     (error (format #f "Syntax error: ~a" gram))
+	     (cadr ret)))))
+   pegs))
+
+
+;;;
+;;; Preprocessor of grammar input
+;;;
+;;; input:
+;;; '(foo -> (e1 bar) (e2 baz) :return (do 'sth) / (e3 hoge) :return (do 'anth))
+;;;
+;;; output:
+;;; '(foo -> < e1 bar > < e2 baz > :return (do 'sth) / < e3 hoge > :return (do 'anth))
+;;;
+(define (flatten-grammar gram)
+  (let loop((ret nil) (gram (reverse gram)) (expression? #f))
+    (if (null? gram)
+	ret
+	(loop
+	 (if (and expression?
+		  (list? (car gram)))
+	     (append `(< ,@(car gram) >) ret)
+	     (cons (car gram) ret))
+	 (cdr gram)
+	 (cond
+	  ((eq? '/ (car gram)) #f)
+	  ((eq? :return (car gram)) #t)
+	  (else expression?))))))
+
+(define (flatten-grammar gram)
+  (concat-with
+   '/
+   (map
+    (lambda (sequence)
+      (concat-with
+       :return
+       (let1 seq-pair (separate (cut eq? :return <>) sequence)
+	 `(,(apply append
+		   (map (lambda (elem)
+			  (if (pair? elem)
+			      `(< ,@(flatten-grammar elem) >)
+			      `(,elem)))
+			(car seq-pair)))
+	   ,@(cdr seq-pair)))))
+    (separate (cut eq? '/ <>) gram))))
+
+(define (separate separator? ls)
+  (let loop1((ret ()) (lst ls))
+    (if (null? lst)
+	(if (separator? (car (reverse ls)))
+	    (reverse (cons () ret))
+	    (reverse ret))
+	(receive (head tails)
+	    (let loop2((ret ()) (ls lst))
+	      (cond
+	       ((null? ls) (values (reverse ret) ls))
+	       ((separator? (car ls))
+		(values (reverse ret) (cdr ls)))
+	       (else
+		(loop2 (cons (car ls) ret) (cdr ls)))))
+	  (loop1 (cons head ret)
+		 tails)))))
+
+(define (concat-with joiner ls)
+  (let loop((ret (car (reverse ls))) (ls (cdr (reverse ls))))
+    (if (null? ls)
+	ret
+	(loop `(,@(car ls) ,joiner ,@ret) (cdr ls)))))
+
+(define-macro (parse-string-with grammars str)
+  `(let ()
+     ,@(map translate-definition
+	    (parse-grammars grammars))
+     (parse-string ,(caar grammars) ,str)))
+
+
+(define-macro (define-parse-symbol ident sym)
+  `(define (,(string->symbol (string-append "parse-" (symbol->string ident))) derivs)
+     (match (deriv-token derivs)
+       ((:result ',sym derivs-) (make-result ',sym derivs-))
+       (_ nil))))
+
+
+(define-parse-symbol open <)
+(define-parse-symbol close >)
+(define-parse-symbol leftarrow <-)
+(define-parse-symbol slash /)
+(define-parse-symbol and &)
+(define-parse-symbol not !)
+(define-parse-symbol question ?)
+(define-parse-symbol star *)
+(define-parse-symbol plus +)
+(define-parse-symbol return :return)
+(define-parse-symbol any %any%)
+
+(define (parse-class derivs)
+  (match (deriv-token derivs)
+    ((:result val derivs-)
+     (if (char-set? val)
+	 (make-result `(:char-set ,val) derivs-)
+	 nil))
+    (_ nil)))
+
+(define (parse-literal derivs)
+  (match (deriv-token derivs)
+    ((:result val derivs-)
+     (cond
+      ((string? val) (make-result `(:string ,val) derivs-))
+      ((char? val) (make-result `(:char ,val) derivs-))
+      (else nil)))
+    (_ nil)))
+
+(define (parse-capture-name derivs)
+  (match (deriv-token derivs)
+    ((:result val derivs-)
+     (if (keyword? val)
+	 (make-result val derivs-)
+	 nil))
+    (_ nil)))
+
+(define (parse-non-identifier derivs)
+  (let* ((alt3
+	  (lazy
+	   (match (deriv-slash derivs)
+	     ((:result ret derivs-)
+	      (make-result '/ derivs-))
+	     (_ nil))))
+	 (alt2
+	  (lazy
+	   (match (deriv-close derivs)
+	     ((:result ret derivs-)
+	      (make-result '> derivs-))
+	     (_ alt3))))
+	 (alt1
+	  (lazy
+	   (match (deriv-open derivs)
+	     ((:result ret derivs-)
+	      (make-result '< derivs-))
+	     (_ alt2)))))
+    (force alt1)))
+
+(define (parse-identifier derivs)
+  (match (deriv-non-identifier derivs)
+    (()
+     (match (deriv-token derivs)
+       ((:result val derivs-)
+	(if (symbol? val)
+	    (make-result `(:identifier ,val) derivs-)
+	    nil))
+       (_ nil)))
+    (_ nil)))
+
+(define (parse-primary derivs)
+  (let* ((alt6
+	  (lazy
+	   (match (deriv-any derivs)
+	     ((:result val derivs-)
+	      (make-result val derivs-))
+	     (_ nil))))
+	 (alt5
+	  (lazy
+	   (match (deriv-class derivs)
+	     ((:result val derivs-)
+	      (make-result val derivs-))
+	     (_ alt6))))
+	 (alt4
+	  (lazy
+	   (match (deriv-literal derivs)
+	     ((:result val derivs-)
+	      (make-result val derivs-))
+	     (_ alt5))))
+	 (alt3
+	  (lazy
+	   (match (deriv-open derivs)
+	     ((:result val derivs-)
+	      (match (deriv-expression derivs-)
+		((:result exp derivs--)
+		 (match (deriv-close derivs--)
+		   ((:result val derivs---)
+		    (make-result exp derivs---))
+		   (_ alt4)))
+		(_ alt4)))
+	     (_ alt4))))
+	 (alt1
+	  (lazy
+	   (match (deriv-identifier derivs)
+	     ((:result ident derivs-)
+	      (match (deriv-leftarrow derivs-)
+		((:result val derivs--) alt3)
+		(_ (make-result ident derivs-))))
+	     (_ alt3)))))
+    (force alt1)))
+
+(define (parse-identifier-clause derivs)
+  (let* ((alt1
+	  (lazy
+	   (match (deriv-open derivs)
+	     ((:result opn derivs-)
+	      (match (deriv-capture-name derivs-)
+		((:result capt derivs--)
+		 (match (deriv-primary derivs--)
+		   ((:result primary derivs---)
+		    (match (deriv-close derivs---)
+		      ((:result cls derivs----)
+		       (make-result `(:identifier-clause
+				      ,primary
+				      :capture
+				      ,(string->symbol (x->string capt)))
+				    derivs----))
+		      (_ nil)))
+		   (_ nil)))
+		(_ nil)))
+	     (_ nil)))))
+    (force alt1)))
+
+(define (parse-suffix derivs)
+  (match (deriv-primary derivs)
+    ((:result prim derivs-)
+     (let* ((alt3
+	     (lazy
+	      (match (deriv-plus derivs-)
+		((:result plus derivs--)
+		 (make-result `(:one-more ,prim) derivs--))
+		(_ (make-result prim derivs-)))))
+	    (alt2
+	     (lazy
+	      (match (deriv-star derivs-)
+		((:result star derivs--)
+		 (make-result `(:zero-more ,prim) derivs--))
+		(_ alt3))))
+	    (alt1
+	     (lazy
+	      (match (deriv-question derivs-)
+		((:result qstn derivs--)
+		 (make-result `(:optional ,prim) derivs--))
+		(_ alt2)))))
+       (force alt1)))
+    (_ nil)))
+
+(define (parse-prefix derivs)
+  (let* ((glob-alt2
+	  (lazy
+	   (let* ((alt2
+		   (lazy
+		    (match (deriv-not derivs)
+		      ((:result val derivs-)
+		       (values :not derivs-))
+		      (_ (values nil derivs)))))
+		  (alt1
+		   (lazy
+		    (match (deriv-and derivs)
+		      ((:result val derivs-)
+		       (values :and derivs-))
+		      (_ alt2)))))
+	     (receive (val derivs-) (force alt1)
+	       (match (deriv-suffix derivs-)
+		 ((:result suffix derivs--)
+		  (if (null? val)
+		      (make-result suffix derivs--)
+		      (make-result `(,val ,suffix) derivs--)))
+		 (_ nil))))))
+	 (glob-alt1
+	  (lazy
+	   (match (deriv-identifier-clause derivs)
+	     ((:result ident-clause derivs-)
+	      (make-result ident-clause derivs-))
+	     (_ glob-alt2)))))
+    (force glob-alt1)))
+
+(define (parse-sequence derivs)
+  (receive (seqs derivs)
+      (let loop((ret ()) (derivs derivs))
+	(match (deriv-prefix derivs)
+	  ((:result val derivs-)
+	   (loop (cons val ret) derivs-))
+	  (_ (values (reverse ret) derivs))))
+    (let* ((alt2
+	    (lazy
+	     (make-result `(:sequence ,seqs :callback ()) derivs)))
+	   (alt1
+	    (lazy
+	     (match (deriv-return derivs)
+	       ((:result val derivs-)
+		(match (deriv-token derivs-)
+		  ((:result callback derivs--)
+		   (make-result `(:sequence ,seqs :callback ,callback) derivs--))
+		  (_ alt2)))
+	       (_ alt2)))))
+      (force alt1))))
+
+(define (parse-expression derivs)
+  (match (deriv-sequence derivs)
+    ((:result seq derivs-)
+     (receive (ret derivs)
+	 (let loop((ret `(,seq)) (derivs derivs-))
+	   (match (deriv-slash derivs)
+	     ((:result sla derivs-)
+	      (match (deriv-sequence derivs-)
+		((:result seq derivs--)
+		 (loop (cons seq ret) derivs--))
+		(_ (values (reverse ret) derivs))))
+	     (_ (values (reverse ret) derivs))))
+       (make-result (if (null? (cdr ret))
+			(car ret)
+			(cons :expression ret))
+		    derivs)))))
+
+(define (parse-definition derivs)
+  (match (deriv-identifier derivs)
+    ((:result ident derivs-)
+     (match (deriv-leftarrow derivs-)
+       ((:result larr derivs--)
+	(match (deriv-expression derivs--)
+	  ((:result expr derivs---)
+	   (make-result `(:definition ,ident ,expr) derivs---))
+	  (_ nil)))
+       (_ nil)))
+    (_ nil)))
+
+;;;
+;;; AST translation to PEG
+;;;
+;;; ref. WiLiKi:Rui:ParsingExpressionGrammar
+;;;
+
+;;
+;; expected input
+;; * identifier
+;;   (:identifier <symbol>)
+;; * identifier-clause
+;;   (:identifier-clause (:identifier <symbol>) :capture <symbol>)
+;; * char(literal)
+;;   (:char <char>)
+;; * string(literal)
+;;   (:string <string>)
+;; * char-set(class)
+;;   (:char-set <char-set>)
+;; * expression
+;;   (:expression (:sequence (...) :callback ...) ...)
+;;
+;; return (values <parser> <captured-name>)
+;;
+(define (translate-primary primary)
+  (let ((tag (car primary))
+	(value (cadr primary)))
+    (case tag
+      ((:identifier) value)
+      ((:char) `($char ,value))
+      ((:string) `($string ,value))
+      ((:char-set) `($one-of ,value))
+      ((:sequence) (translate-sequence primary))
+      ((:expression) (translate-expression primary)))))
+
+;;
+;; expected input
+;; * more than zero
+;; (:zero-more <primary>)
+;; * more than one
+;; (:one-more <primary>)
+;; * primary
+;; <primary> (see translate-primary)
+;;
+;; return (values <parser> <captured-name>)
+;;
+(define (translate-suffix suffix)
+  (let ((tag (car suffix))
+	(value (cadr suffix)))
+    (case tag
+      ((:zero-more) `($many ,(translate-primary value)))
+      ((:one-more) `($many ,(translate-primary value) 1))
+      ((:optional) `($optional ,(translate-primary value)))
+      (else (translate-primary suffix)))))
+
+;;
+;; expected input
+;; * and(syntactic predicate)
+;; (:and <suffix>)
+;; * not(syntactic predicate)
+;; (:not <suffix>)
+;; * suffix
+;; <suffix> (see translate-suffix)
+;;
+;; return (values <parser> <ident-clause?>)
+;;
+(define (translate-prefix prefix)
+  (let ((tag (car prefix))
+	(value (cadr prefix)))
+    (case tag
+      ((:not) (values `($not ,(translate-suffix value)) #f))
+      ((:identifier-clause)
+       (values `(,(get-keyword :capture prefix)
+		 ,(translate-primary value))
+	       #t))
+      (else (values (translate-suffix prefix) #f)))))
+
+(define (translate-sequence sequence)
+  (let ((tag (car sequence))
+	(prefixes (cadr sequence))
+	(callback (get-keyword :callback sequence #f)))
+    (case tag
+      ((:sequence)
+       (if (null? prefixes)
+	   `($do ($return ,callback))
+	   (if
+	    (and (null? (cdr prefixes)) (null? callback))
+	    (translate-prefix (car prefixes))
+	    (let loop((items nil) (capture-names nil) (prefixes prefixes))
+	      (cond
+	       ((null? prefixes)
+		(cons
+		 '$do
+		 (reverse
+		  (cons
+		   (if (null? callback)
+		       `($return (list ,@(reverse capture-names)))
+		       `($return ,callback))
+		   items))))
+	       (else
+		(receive (prefix ident-clause?)
+		    (translate-prefix (car prefixes))
+		  (let1 capt (gensym)
+		    (loop (cons (if ident-clause?
+				    prefix
+				    `(,capt ,prefix))
+				items)
+			  (cons (if ident-clause?
+				    (car prefix)
+				    capt)
+				capture-names)
+			  (cdr prefixes)
+			  )))))))))
+      (else
+       (translate-prefix sequence)))))
+
+(define (translate-expression expression)
+  (let ((tag (car expression)))
+    (case tag
+      ((:expression)
+       (let1 sequences (cdr expression)
+	 (if (null? (cdr sequences))
+	     (translate-sequence (car sequences))
+	     `($or ,@(map translate-sequence sequences)))))
+      (else
+       (translate-sequence expression)))))
+
+(define (translate-definition definition)
+  (let ((tag (car definition))
+	(ident (cadr (cadr definition)))
+	(expression (caddr definition)))
+    (case tag
+      ((:definition)
+       `(define ,ident ,(translate-expression expression)))
+      (else (error "Translation error")))))
+
+(define (hoge)
+  (let* ((spaces ($many ($one-of #[ \t])))
+	 (comma ($seq spaces ($char #\,) spaces))
+	 (dquote ($char #\"))
+	 (double-dquote ($do (($string "\"\"")) ($return #\")))
+	 (quoted-body ($many ($or double-dquote ($one-of #[^\"]))))
+	 (quoted ($between dquote quoted-body dquote))
+	 (unquoted ($many-till anychar ($or comma newline)))
+	 (field ($or quoted unquoted))
+	 (record ($sep-by ($->rope field) comma)))
+    #?=(parse-string record "a,b,c")
+    #?=(parse-string record "\"a\" , b  , c")
+    #?=(parse-string record "\"a  \"\" \n\" , b  , c"))
+
+  (parse-string-with
+   ((Record <- (:fld Field) (:suffix RecordSuffix) :return (cons fld suffix))
+    (RecordSuffix <- Comma (:fld Field) (:suffix RecordSuffix)
+		  :return (cons fld suffix)
+		   / :return () )
+    (Field <- (:charlist Quoted) :return (list->string charlist)
+	   / (:charlist UnQuoted) :return (list->string charlist))
+    (Spaces <- #[ \t] *)
+    (Comma <- Spaces #\, Spaces)
+    (DQuote <- #\")
+    (DoubleDQuote <- #\" #\" :return #\")
+    (Quoted <- DQuote
+	    (:body ((DoubleDQuote / #[^\"]) *))
+	    DQuote
+	    :return body)
+    (UnQuoted <- ((! (Comma / newline) (:ch anychar) :return ch) *))
+    )
+   "\"a\" , b  , c")
+  )
+
+;; (parse-string-with
+;;  ((Record <- (:fld Field)
+;; 	  (:rest-fld ((Comma (:fld Field) :return fld) *))
+;; 	  :return (cons fld rest-fld))
+;;   (Field <- (:charlist Quoted) :return (list->string charlist)
+;; 	 / (:charlist UnQuoted) :return (list->string charlist))
+;;   (Spaces <- #[ \t] *)
+;;   (Comma <- Spaces #\, Spaces)
+;;   (DQuote <- #\")
+;;   (Quoted <- DQuote
+;; 	  (:body ((#\" #\" :return #\" / #[^\"]) *))
+;; 	  DQuote
+;; 	  :return body)
+;;   (UnQuoted <- ! (Comma / newline) (:ch anychar) (:unq UnQuoted)
+;; 	    :return (cons ch unq)
+;; 	    / :return ())
+;;   )
+;;    "\"a\"\"bc\" , b  , c")
+
+;; (parse-string-with
+;;  ((A <- "a" A "a" / "a"))
+;;  "aaaaa")
Index: /hh2008/hayamiz/trunk/hascheme/peg.scm
===================================================================
--- /hh2008/hayamiz/trunk/hascheme/peg.scm (revision 15)
+++ /hh2008/hayamiz/trunk/hascheme/peg.scm (revision 15)
@@ -0,0 +1,509 @@
+;;;
+;;; peg.scm - Parser Expression Grammar 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.
+;;;
+
+(define-module peg
+  (use srfi-1)
+  (use srfi-13)
+  (use srfi-14)
+  (use util.match)
+  (export parse-success? parse-failure?
+          stream-position
+          <parse-error>
+
+          result-value
+          result-next
+          failure-type
+          failure-message
+          failure-position
+          parse-string
+          $return $fail $expect 
+          $do $cut $seq $or $many $skip-many
+          $repeat $optional
+
+          $alternate
+
+          $sep-by $end-by $sep-end-by
+          $count $between
+          $not $many-till $chain-left $chain-right
+          $lazy
+          $string $string-ci
+          $char $one-of $none-of
+          $satisfy
+
+          anychar upper lower letter alphanum digit
+          hexdigit newline tab space spaces eof
+
+          $->rope semantic-value-finalize!
+          )
+  )
+(select-module peg)
+
+(debug-print-width 1024)
+
+;;;============================================================
+;;; How is EBNF represented in the PEG library?
+;;;
+;;;   A ::= B C
+;;;     => (define a ($seq b c))
+;;;    If you need values of B and C, $do can be used:
+;;;     => (define a ($do ((x b) (y c)) (cons x y)))
+;;;
+;;;   A :: B | C
+;;;     => (define a ($or b c))
+;;;
+;;;   A :: B*
+;;;     => (define a ($many b))
+;;;
+;;;   A :: B+
+;;;     => (define a ($many b 1))
+;;;
+;;;   A ::= B B | B B B
+;;;     => (define a ($many b 2 3))
+;;;
+;;;   A ::= B?
+;;;     => (define a ($optional b))
+;;;
+
+;;;============================================================
+;;; Parse result types
+;;;
+
+;; result ::= ('success <semantic-value> <stream>)
+;; error ::= ('fail <failure-type> <message-string> <position>)
+
+(define-condition-type <parse-error> <error> #f
+  (position))
+
+(define-method write-object ((o <parse-error>) out)
+  (format out "#<<parse-error> ~a ~S>"
+          (ref o 'position)
+          (ref o 'message)))
+
+(define (parse-success? obj)
+  (and (vector? obj)
+       (eq? 'success (vector-ref obj 0))))
+
+(define (parse-failure? obj)
+  (and (vector? obj)
+       (eq? 'fail (vector-ref obj 0))))
+
+(define (make-result value stream)
+  (vector 'success value stream))
+
+(define result-value     (cut vector-ref <> 1))
+(define result-next      (cut vector-ref <> 2))
+(define failure-type     (cut vector-ref <> 1))
+(define failure-message  (cut vector-ref <> 2))
+(define failure-position (cut vector-ref <> 3))
+
+(define (make-message-failure m p)
+  (vector 'fail 'message (list m) p))
+(define (make-expect-failure m p)
+  (vector 'fail 'expect (list m) p))
+(define (make-unexpect-failure m p)
+  (vector 'fail 'unexpect (list m) p))
+
+;; entry point
+(define (parse-string parse str)
+  (define (error->string err)
+    (case (failure-type err)
+      ((message)  (failure-message err))
+      ((expect)   (failure-message err))
+      ((unexpect) (format #f "unexpected: ~a" (failure-message err)))))
+  (let1 r (parse (make-string-stream str))
+    (if (parse-success? r)
+      (semantic-value-finalize! (result-value r))
+      (raise (make-condition <parse-error>
+               'position (failure-position r)
+               'message (error->string r))))))
+
+;;;============================================================
+;;; Lazily-constructed string
+;;;
+(define-class <rope> ()
+  ((tree :init-keyword :tree)))
+
+(define (rope->string obj)
+  (define (traverse obj)
+    (cond ((is-a? obj <rope>)
+           (traverse (slot-ref obj 'tree)))
+          ((list? obj) (map traverse obj))
+          ((string? obj) (display obj))
+          ((char? obj) (display obj))
+          (else (error "don't know how to write:" obj))))
+  (with-output-to-string
+   (lambda () (traverse obj))))
+
+(define (make-rope obj)
+  (make <rope> :tree obj))
+
+;;;============================================================
+;;; Input Stream
+;;;
+
+;;(define (make-string-stream str)
+;;  (let loop ((str str) (pos 0))
+;;    (lambda ()
+;;      (if (zero? (string-length str))
+;;        (let loop () (values #f pos loop))
+;;        (values (string-ref str 0)
+;;                pos
+;;                (loop (string-drop str 1) (+ pos 1)))))))
+
+(define (make-string-stream str)
+  (let loop ((ptr (make-string-pointer str)))
+    (lambda ()
+      (let ((c (string-pointer-ref ptr))
+            (pos (string-pointer-index ptr)))
+        (if (eof-object? c)
+          (let loop () (values #f pos loop))
+          (let1 new-ptr (string-pointer-copy ptr)
+            (string-pointer-next! new-ptr)
+            (values c pos (loop new-ptr))))))))
+
+(define (stream-position s)
+  (values-ref (s) 1))
+
+;;;============================================================
+;;; Primitives
+;;;
+(define ($return val)
+  (lambda (s) (make-result val s)))
+
+(define ($fail msg)
+  (lambda (s)
+    (make-message-failure msg (stream-position s))))
+
+(define ($expect parse msg)
+  (lambda (s)
+    (let1 r (parse s)
+      (if (parse-success? r)
+        r
+        (make-expect-failure msg (stream-position s))))))
+
+(define ($unexpect msg pos)
+  (lambda (s)
+    (make-unexpect-failure msg pos)))
+
+;;;============================================================
+;;; Error handler
+;;;
+(define (merge-failure err)
+  (let loop ((r '()) (err err) (pos 0))
+    (if (null? err)
+      (vector 'fail
+              (vector-ref (car r) 1)
+              (append-map (cut vector-ref <> 2) (reverse! r))
+              pos)
+      (let1 npos (failure-position (car err))
+        (cond ((= pos npos)
+               (loop (cons (car err) r) (cdr err) pos))
+              ((< pos npos)
+               (loop (list (car err)) (cdr err) npos))
+              (else (loop r (cdr err) pos)))))))
+
+
+;;;============================================================
+;;; Backtrack control
+;;;
+(define-syntax $cut
+  (syntax-rules ()
+    ((_ mark) (set! mark #t))))
+
+;;;==================================================================
+;;; Combinators
+;;;
+(define-syntax $do
+  (syntax-rules ()
+    (($do :: var clause ...)
+     (begin ($cut var) ($do clause ...)))
+    (($do ((parse))) parse)
+    (($do parse) parse)
+    (($do (var parse) clause ...)
+     (lambda (s)
+       (let1 tmp (parse s)
+         (if (parse-success? tmp)
+           (let1 var (result-value tmp)
+             (($do clause ...) (result-next tmp)))
+           tmp))))
+    (($do ((parse)) clause ...)
+     (lambda (s)
+       (let1 tmp (parse s)
+         (if (parse-success? tmp)
+           (($do clause ...) (result-next tmp))
+           tmp))))
+    (($do c0 c1 c2 ...)
+     ($do (c0) c1 c2 ...))
+    (($do . rest)
+     (syntax-error "malformed $do binding form:" rest))))
+
+(define-syntax $or
+  (syntax-rules (quote)
+    (($or 'mark) ($return #t))
+    (($or 'mark p0 p1 ...)
+     (lambda (s)
+       (let1 mark #f
+         (let loop ((errors '())
+                    (parsers (list p0 p1 ...)))
+           (let1 r ((car parsers) s)
+             (cond ((parse-success? r) r)
+                   ((or mark (null? (cdr parsers)))
+                    (if (null? errors)
+                      r
+                      (merge-failure (reverse! (cons r errors)))))
+                   (else
+                    (loop (cons r errors) (cdr parsers)))))))))
+    (($or) ($return #t))
+    (($or p0) p0)
+    (($or p0 p1 ...)
+     (lambda (s)
+       (let loop ((errors '())
+                  (parsers (list p0 p1 ...)))
+         (let1 r ((car parsers) s)
+           (cond ((parse-success? r) r)
+                 ((null? (cdr parsers))
+                  (if (null? errors)
+                    r
+                    (merge-failure (reverse! (cons r errors)))))
+                 (else
+                  (loop (cons r errors) (cdr parsers))))))))))
+
+(define ($seq . parsers)
+  (match parsers
+    (() ($return #t))
+    ((parse) parse)
+    ((parse . rest)
+     ($do ((parse)) (apply $seq rest)))
+    (_ (error "can't be here"))))
+
+(define (%check-min-max min max)
+  (when (or (negative? min)
+            (and max (> min max)))
+    (error "invalid argument:" min max)))
+
+(define ($many parse . args)
+  (let-optionals* args ((min 0) (max #f))
+    (%check-min-max min max)
+    (lambda (s)
+      (define (max? count)
+        (and max (>= count max)))
+      (let loop ((r '()) (s s) (count 0))
+        (if (max? count)
+          (make-result (reverse! r) s)
+          (let1 v (parse s)
+            (cond ((parse-success? v)
+                   (loop (cons (result-value v) r)
+                         (result-next v)
+                         (+ count 1)))
+                  ((<= min count)
+                   (make-result (reverse! r) s))
+                  (else v))))))))
+
+(define ($skip-many . args)
+  (apply $many args))
+
+(define ($repeat parse n)
+  ($many parse n n))
+
+(define ($optional parse)
+  ($or parse ($return #f)))
+
+(define ($sep-by parse sep . args)
+  (let-optionals* args ((min 0) (max #f))
+    (%check-min-max min max)
+    (if (and max (zero? max))
+      ($return #t)
+      (lambda (s)
+        (let1 r (parse s)
+          (cond ((parse-success? r)
+                 (let1 r2 (($many ($do sep parse)
+                                  (clamp (- min 1) 0)
+                                  (and max (- max 1)))
+                           (result-next r))
+                   (if (parse-success? r2)
+                     (make-result (cons (result-value r) (result-value r2))
+                                  (result-next r2))
+                     r2)))
+                ((zero? min) (make-result #t s))
+                (else r)))))))
+
+(define ($alternate parse sep)
+  ($do (h parse)
+       (t ($many ($do (v1 sep) (v2 parse) ($return (list v1 v2)))))
+       ($return (cons h (apply append! t)))))
+
+(define ($end-by parse sep . args)
+  (apply $many ($do (v parse) sep ($return v)) args))
+
+(define ($sep-end-by parse sep . args)
+  ($do (v (apply $sep-by parse sep args))
+       (($optional sep))
+       ($return v)))
+
+(define ($count parse n)
+  ($many parse n n))
+
+(define ($between open parse close)
+  ($do open (v parse) close ($return v)))
+
+(define ($not parse)
+  (lambda (s)
+    (($or 'grp
+          ($do (v parse) :: grp ($unexpect v (stream-position s)))
+          ($return #f))
+     s)))
+
+(define ($many-till parse end . args)
+  (apply $many ($do (($not end)) parse) args))
+
+(define ($chain-left parse op)
+  (lambda (st)
+    (let1 r (parse st)
+      (if (parse-success? r)
+        (let loop ((r r))
+          (let1 r2 (($do (proc op) (v parse)
+                         ($return (proc (result-value r) v)))
+                    (result-next r))
+            (if (parse-success? r2)
+              (loop r2)
+              r)))
+        r))))
+
+(define ($chain-right parse op)
+  (rec (loop st)
+    (($do (h parse)
+          ($or ($do (proc op)
+                    (t loop)
+                    ($return (proc h t)))
+               ($return h)))
+     st)))
+
+(define-syntax $lazy
+  (syntax-rules ()
+    ((_ parse)
+     (lambda args (apply parse args)))))
+
+;;;============================================================
+;;; Intermediate structure constructor
+;;;
+(define ($->rope parse)
+  ($do (v parse) ($return (make-rope v))))
+
+(define (semantic-value-finalize! obj)
+  (cond ((is-a? obj <rope>) (rope->string obj))
+        ((pair? obj)
+         (cons (semantic-value-finalize! (car obj))
+               (semantic-value-finalize! (cdr obj))))
+        (else obj)))
+
+;;;============================================================
+;;; String parsers
+;;;
+(define ($satisfy pred expect)
+  (lambda (s)
+    (receive (c pos next) (s)
+      (if c
+        (let1 r (pred c)
+          (if r
+            (make-result c next)
+            (make-expect-failure expect pos)))
+        (make-expect-failure expect pos)))))
+
+(define-values ($string $string-ci)
+  (let-syntax
+      ((expand
+        (syntax-rules ()
+          ((_ char=)
+           (lambda (str)
+             (let1 lis (string->list str)
+               (lambda (s)
+                 (let loop ((r '()) (s s) (lis lis))
+                   (if (null? lis)
+                     (make-result (make-rope (reverse! r)) s)
+                     (receive (c pos next) (s)
+                       (if (and c (char= c (car lis)))
+                         (loop (cons c r) next (cdr lis))
+                         (make-expect-failure str (stream-position s)))))))))))))
+    (values (expand char=?)
+            (expand char-ci=?))))
+
+(define ($char c)
+  ($satisfy (cut char=? c <>) c))
+
+(define ($char-ci c)
+  ($satisfy (cut char-ci=? c <>)
+            (list->char-set c (char-upcase c) (char-downcase c))))
+
+(define ($one-of charset)
+  ($satisfy (cut char-set-contains? charset <>)
+            charset))
+
+(define ($none-of charset)
+  ($one-of (char-set-complement charset)))
+
+(define (anychar st)
+  (receive (c pos next) (st)
+    (if c
+      (make-result c next)
+      (make-expect-failure "character" pos))))
+
+(define-syntax define-char-parser
+  (syntax-rules ()
+    ((_ proc charset expect)
+     (define proc
+       ($expect ($one-of charset) expect)))))
+
+(define-char-parser upper    #[A-Z]         "upper case letter")
+(define-char-parser lower    #[a-z]         "lower case letter")
+(define-char-parser letter   #[A-Za-z]      "letter")
+(define-char-parser alphanum #[A-Za-z0-9]   "letter or digit")
+(define-char-parser digit    #[0-9]         "digit")
+(define-char-parser hexdigit #[0-9A-Fa-f]   "hexadecimal digit")
+(define-char-parser newline  #[\n]          "newline")
+(define-char-parser tab      #[\t]          "tab")
+(define-char-parser space    #[ \v\f\t\r\n] "space")
+
+(define spaces ($->rope ($many space)))
+
+(define eof
+  (lambda (s)
+    (receive (c pos next) (s)
+      (if c
+        (make-expect-failure "end of input" pos)
+        (make-result #t next)))))
+
+;;============================================================
+;; Token Parsers
+;;
+
+(provide "peg")
Index: /hh2008/hayamiz/trunk/hascheme/parser.scm
===================================================================
--- /hh2008/hayamiz/trunk/hascheme/parser.scm (revision 15)
+++ /hh2008/hayamiz/trunk/hascheme/parser.scm (revision 15)
@@ -0,0 +1,235 @@
+;; -*- coding: utf-8 mode: scheme -*-
+
+(use text.tree)
+(require "hascheme/peg-parser")
+
+(define-class <ast> () ())
+(define-class <ast-decl> (<ast>) ())
+(define-class <ast-type-decl> (<ast-decl>)
+  ((left :init-keyword :left :getter type-decl-left)
+   (right :init-keyword :right :getter type-decl-right)))
+(define-class <ast-type> (<ast>) ())
+(define-class <ast-type-var> (<ast>) 
+  ((type-var :init-keyword :var :getter type-var)))
+(define-class <ast-single-type> (<ast-type>)
+  ((type-name :init-keyword :name :getter type-name)
+   (type-arity :init-keyword :arity :accessor type-arity)
+   (type-vars :init-keyword :vars :accessor type-vars :init-value #f)
+   (type-module :init-keyword :module :getter type-module :init-value #f)))
+(define-class <ast-multi-type> (<ast-type>)
+  ((types :init-keyword :name :accessor types)))
+(define-class <ast-simple-type> (<ast>) ())
+(define-method make-type-decl ((left <ast-simple-type>) (right <ast-type>))
+  ; (make <type-decl> :left left :right right)
+  `(:type-decl ,left ,right))
+
+(define (hascheme:parse str)
+  (parse-string-with
+   (
+    ;; incompl
+    (Module <- "module" Spaces LexModId Spaces "where" Spaces Body
+	    / Body)
+    (Body <- "{" (:decls TopDecls) "}" :return decls)
+    (TopDecls <- Spaces* (:decl TopDecl) (:rest-decls TopDecls%) Spaces*
+	      :return `(:decls ,decl ,@rest-decls)
+	      / Spaces* :return ())
+    (TopDecls% <- Spaces* ";" Spaces* TopDecl TopDecls%
+	      / :return ())
+
+    ;; incoml
+    (TopDecl <-
+	     "type" Spaces (:left SimpleType) Spaces*
+	     "=" Spaces* (:right Type)
+	     :return (make-type-decl left right)
+	     / "data" Spaces ( Context Spaces* "=>" Spaces*) ? SimpleType
+	     Spaces* "="
+	     Spaces* Constructors
+	     Spaces* Deriving ?
+
+	     / Decl
+	     )
+    (Decls <- "{" Spaces* Decl Spaces* ("," Decl Spaces*) * "}")
+    
+    ;; incompl
+    (Decl <- GenDecl
+	  ;; /(FunctionLHS / Variable) RHS ;; do this later
+	  / Variable Spaces* RHS)
+    ;; incompl
+    (GenDecl <- Variables Spaces* "::" Spaces*
+	     ( Context Spaces* "=>" Spaces* ) ? Type
+	     ;; / Fixity LexInteger ? Operators ;; later
+	     )
+    ;; incompl
+    (RHS <- "=" Spaces* Expression (Spaces "where" Spaces Decls) ?)
+
+    (Expression <- "\\" Spaces* AtomPattern 
+		(Spaces AtomPattern) * Spaces* "->" Spaces* Expression
+		/ "let" Spaces* Decls Spaces* "in" Spaces* Expression
+		/ "if" Spaces* Expression
+		Spaces* "then" Spaces* Expression
+		Spaces* "else" Spaces* Expression
+		/ "case" Spaces* Expression
+		Spaces* "of" Spaces* "{" Alts "}"
+		/ "do" Spaces* "{" Spaces* Statements Spaces* "}"
+		/ FuncApplyExpression
+		)
+
+    (FuncApplyExpression <- AtomExpression +)
+    (AtomExpression
+     <- QVar
+     / GCon
+     / Literal
+     / "(" Spaces* Expression Spaces* ")"
+     / "(" Spaces* Expression Spaces* ("," Spaces* Expression Spaces*)+ ")"
+     / "[" Spaces* Expression Spaces* ("," Spaces* Expression Spaces*)* "]"
+     / "[" Spaces* Expression ( "," Spaces* Expression Spaces* )?
+     ".." Spaces* Expression?  Spaces* "]"
+     / "[" Spaces* Expression Spaces*
+     "|" Spaces* Qual Spaces* ("," Spaces* Qual Spaces*)+ "]"
+     ;; / "(" Spaces* Expression Spaces* QualifiedOperator(A,i) ")"
+     ;; / "(" LeftExpression(i) QualifiedOperator(L,i) ")"
+     ;; / "(" QualifiedOperator(A,i) "<->" Expression(i+1) ")"
+     ;; / "(" QualifiedOperator(R,i) "<->" RightExpression(i) ")"
+     ;; / QualifiedConstructor "{" [ FBind ("," FBind)* ] "}"
+     ;; / AtomExpression<QualifiedConstructor> "{" FBind ("," FBind)* "}"
+     )
+
+    (AtomPattern
+     <- QVar
+     / GCon
+     QCon Spaces "{" Spaces*
+     ( FieldPattern Spaces*
+		    ("," Spaces* FieldPattern Spaces*) * )
+     ? "}"
+     / Literal
+     / "_"
+     / "(" Spaces* Pattern Spaces* ")"
+     / "(" Spaces* Pattern Spaces* ("," Spaces* Pattern Spaces*) + ")"
+     / "[" Spaces* Pattern Spaces* ("," Spaces* Pattern Spaces*) * "]"
+     / "~" Spaces* AtomPattern)
+
+    (QVar <- LexQVarId / "(" Spaces* LexQVarSym Spaces* ")")
+    (GCon <- "(" Spaces* ")"
+	  / "[" Spaces* "]"
+	  / "(" Spaces* ("," Spaces*)+ ")"
+	  / QCon)
+    (QCon <- LexQConId / "(" Spaces* LexGConSym Spaces* ")")
+
+    (Context <-  Class / 
+	     "(" Spaces* 
+	     ( Class Spaces* ("," Spaces* Class Spaces*) * ) ? ")")
+    (Class <- LexQtyCls Spaces LexTyVar
+	   / LexQtyCls "(" LexTyVar AType + ")")
+    (SimpleType <- (:con LexTyCon) (:vars SimpleTypeVars)
+		:return `(:type-name ,con :vars ,vars))
+    (SimpleTypeVars <- Spaces (:var LexTyVar) (:vars SimpleTypeVars)
+		    :return (cons var vars)
+		    / :return ())
+    (Type <- (:type BType) Spaces* (:rest-types Type%)
+	  :return `(:type ,type ,@rest-types))
+    (Type% <- "->" Spaces* (:type Type) (:rest-types Type%)
+	   :return (cons type rest-types)
+	   / :return ())
+    (BType <- (:type AType) (:rest-types BType%) 
+	   :return (cons type rest-types))
+    (BType% <- Spaces (:type AType) (:rest-types BType%)
+	    :return (cons type rest-types)
+	    / :return ())
+    (AType <- GtyCon
+	   / (:id LexTyVar) :return (make <ast-type-var> :var id)
+	   / "(" Spaces* (:t1 Type) Spaces* ","
+	   Spaces* (:t2 Type) Spaces* (:rest AType%) ")"
+	   :return (make <ast-simple-type> :name '$Tuple
+			 :arity (+ 2 (length rest))
+			 :vars `(,t1 ,t2 ,@rest))
+	   / "[" Spaces* Type Spaces* "]"
+	   / "(" Spaces* Type Spaces* ")")
+    (AType% <- "," Spaces* (:t Type) Spaces* (:rest AType%)
+	    :return (cons t rest)
+	    / :return ())
+    (GtyCon <- LexQtyCon
+	    / "(" Spaces* ")"
+	    :return (make <ast-single-type> :name '$Unit :arity 0 :vars ())
+	    / "[" Spaces* "]"
+	    :return '(make <ast-single-type> :name '$Unit :arity 0)
+	    ; / "(" Spaces* "->" Spaces* ")"
+	    / "(" Spaces* (:commas (("," Spaces*) +)) ")"
+	    :return (make <ast-single-type> :name '$Tuple 
+			  :arity (+ 1 (length commas))))
+    (Literal <- Float / Integer / Char / String)
+    (Integer <- Decimal / "0o" Octal / "00" Octal
+	     / "0x" Hexadecimal / "0X" Hexadecimal)
+    (Float <- Decimal "." Decimal Exponent ?
+	   / Decimal Exponent)
+    (Char <- "'" (LexGraphic / LexSpace / LexEscape) "'")
+    (String <- "\"" (LexGraphic / LexSpace / LexEscape / LexGap) * "\"")
+    (Decimal <- LexDigit LexDigit *)
+    (Exponent <- #[eE] #[-+] Decimal)
+
+    (Constructors <- Constructor Spaces* ("|" Spaces* Constructor Spaces*) *)
+    (Constructor <-
+		 ;; I don't know about this case
+;; 		 / (BType / "!" Spaces* AType)
+;; 		 Spaces* ConstructorOperator
+;; 		 Spaces* (BType / "!" Spaces* AType)
+		 LexCon Spaces*
+		 "{" (Spaces*
+		 FieldDecl Spaces*
+		 ("," Spaces* FieldDecl Spaces*) * )* "}"
+		 /  LexCon Spaces* ("!" ? Spaces* AType Spaces*) *
+		 )
+    (FieldDecl <- Variables Spaces* "::"
+	       Spaces* (Type / "!" Spaces* AType))
+    (Variables <- Variable Spaces* ("," Spaces* Variable Spaces*) *)
+    (Variable <- LexVarId / "(" Spaces* LexVarSym Spaces* ")")
+    (Deriving <- "deriving"
+	      Spaces
+	      (DClass 
+	       / "(" (DClass Spaces* ("," Spaces* DClass Spaces) * )? ")"))
+
+    ;; Tokens
+
+    ;; incompl
+    (LexCon <- LexConId
+	    ; / LexConSym
+	    )
+    (LexConSym <- I Dont Know)
+    (LexModId <- LexConId)
+    (LexTyVar <- LexVarId)
+    (LexTyCon <- LexConId)
+    (LexTyCls <- LexConId)
+    (LexQVarId <- (LexModId ".") ? LexVarId)
+    (LexQVarSym <- (LexModId ".") ? LexVarSym)
+    (LexQConId <- (LexModId ".") ? LexConId)
+    (LexQConSym <- (LexModId ".") ? LexConSym)
+    (LexQtyCon <- (:mod ((LexModId ".") ?)) (:tycon LexTyCon)
+	       :return (if mod `(:module ,(car mod) ,@tycon)
+			   `(:module #f ,@tycon)))
+    (LexQtyCls <- (LexModId ".") ? LexTyCls)
+    (LexGConSym <- ":" / LexQConSym )
+
+    (LexConId <- (:init LexLarge) (:rest LexIdRest)
+	      :return (string->symbol (tree->string (cons init rest))))
+    (LexVarId <- (:init LexSmall) (:rest LexIdRest)
+	      :return (string->symbol (tree->string (cons init rest))))
+    (LexVarSym <- LexSymbol (":" / LexSymbol) *)
+    (LexConSym <- LexSymbol (":" / LexSymbol) *)
+    (LexLarge <- #[A-Z])
+    (LexSmall <- #[a-z])
+    (LexIdRest <- #[A-Za-z'0-9] *)
+    (LexSymbol <- #[-!#$%&*+\./<=>?@\\^\|~])
+
+    (LexDigit <- #[0-9])
+
+    (Spaces* <- Space *)
+    (Spaces <- Space +)
+    (Space <- #[ \t\n])
+    )
+   str))
+
+
+(define (hascheme:parser-test)
+  (test* "Simplest body" '(())
+	 (hascheme:parse "{}")))
+
+(provide "hascheme/parser")
Index: /hh2008/hayamiz/trunk/hascheme.scm
===================================================================
--- /hh2008/hayamiz/trunk/hascheme.scm (revision 15)
+++ /hh2008/hayamiz/trunk/hascheme.scm (revision 15)
@@ -0,0 +1,10 @@
+#!/usr/bin/env gosh
+;; -*- coding: utf-8 mode: scheme -*-
+
+;; init
+(add-load-path "/home/haya/lambdarepos/hh2008/hayamiz/trunk")
+(require "hascheme/parser")
+
+(define (main args)
+  
+  0)