Index: hh2008/hayamiz/trunk/hascheme/parser.scm
===================================================================
--- hh2008/hayamiz/trunk/hascheme/parser.scm (revision 15)
+++ hh2008/hayamiz/trunk/hascheme/parser.scm (revision 23)
@@ -6,4 +6,6 @@
 (define-class <ast> () ())
 (define-class <ast-decl> (<ast>) ())
+(define-class <ast-decls> (<ast>)
+  ((delcs :init-keyword :decls :getter decls)))
 (define-class <ast-type-decl> (<ast-decl>)
   ((left :init-keyword :left :getter type-decl-left)
@@ -14,13 +16,15 @@
 (define-class <ast-single-type> (<ast-type>)
   ((type-name :init-keyword :name :getter type-name)
-   (type-arity :init-keyword :arity :accessor type-arity)
+   (type-arity :init-keyword :arity :accessor type-arity :init-value #f)
    (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-class <ast-simple-type> (<ast>)
+  ((type-name :init-keyword :name :getter type-name)
+   (type-vars :init-keyword :vars :getter type-vars)))
+
 (define-method make-type-decl ((left <ast-simple-type>) (right <ast-type>))
-  ; (make <type-decl> :left left :right right)
-  `(:type-decl ,left ,right))
+  (make <ast-type-decl> :left left :right right))
 
 (define (hascheme:parse str)
@@ -32,5 +36,5 @@
     (Body <- "{" (:decls TopDecls) "}" :return decls)
     (TopDecls <- Spaces* (:decl TopDecl) (:rest-decls TopDecls%) Spaces*
-	      :return `(:decls ,decl ,@rest-decls)
+	      :return (make <ast-decls> :decls (cons decl rest-decls))
 	      / Spaces* :return ())
     (TopDecls% <- Spaces* ";" Spaces* TopDecl TopDecls%
@@ -75,5 +79,8 @@
 		)
 
-    (FuncApplyExpression <- AtomExpression +)
+    (FuncApplyExpression 
+     <- (:atom AtomExpression)
+     (:rest-atoms ((Spaces (:inatm AtomExpression) :return inatm) *))
+     Spaces* :return `(:funapply ,atom ,@rest-atoms))
     (AtomExpression
      <- QVar
@@ -109,5 +116,6 @@
      / "~" Spaces* AtomPattern)
 
-    (QVar <- LexQVarId / "(" Spaces* LexQVarSym Spaces* ")")
+    (QVar <- LexQVarId
+	  / "(" Spaces* (:sym LexQVarSym) Spaces* ")" :return sym)
     (GCon <- "(" Spaces* ")"
 	  / "[" Spaces* "]"
@@ -122,15 +130,25 @@
 	   / LexQtyCls "(" LexTyVar AType + ")")
     (SimpleType <- (:con LexTyCon) (:vars SimpleTypeVars)
-		:return `(:type-name ,con :vars ,vars))
+		:return (make <ast-simple-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))
+	  :return
+	  (if (null? rest-types)
+	      type
+	      (make <ast-multi-type> :types (cons 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))
+	   :return (cond 
+		    ((is-a? type <ast-single-type>)
+		     (begin (set! (type-vars type) rest-types)
+			    type))
+		    ((and (is-a? #?=type <ast-multi-type>)
+			  (null? #?=rest-types))
+		     type)
+		    (else (error "Type error"))))
     (BType% <- Spaces (:type AType) (:rest-types BType%)
 	    :return (cons type rest-types)
@@ -140,15 +158,17 @@
 	   / "(" Spaces* (:t1 Type) Spaces* ","
 	   Spaces* (:t2 Type) Spaces* (:rest AType%) ")"
-	   :return (make <ast-simple-type> :name '$Tuple
+	   :return (make <ast-single-type> :name '$Tuple
 			 :arity (+ 2 (length rest))
 			 :vars `(,t1 ,t2 ,@rest))
 	   / "[" Spaces* Type Spaces* "]"
-	   / "(" Spaces* Type Spaces* ")")
+	   / "(" Spaces* (:t Type) Spaces* ")" :return t)
     (AType% <- "," Spaces* (:t Type) Spaces* (:rest AType%)
 	    :return (cons t rest)
 	    / :return ())
-    (GtyCon <- LexQtyCon
+    (GtyCon <- (:tycon LexQtyCon)
+	    :return (make <ast-single-type> :name (cadr tycon)
+			  :module (car tycon))
 	    / "(" Spaces* ")"
-	    :return (make <ast-single-type> :name '$Unit :arity 0 :vars ())
+	    :return (make <ast-single-type> :name '$Unit :arity 0)
 	    / "[" Spaces* "]"
 	    :return '(make <ast-single-type> :name '$Unit :arity 0)
@@ -204,6 +224,6 @@
     (LexQConSym <- (LexModId ".") ? LexConSym)
     (LexQtyCon <- (:mod ((LexModId ".") ?)) (:tycon LexTyCon)
-	       :return (if mod `(:module ,(car mod) ,@tycon)
-			   `(:module #f ,@tycon)))
+	       :return (if mod `(,(car mod) ,tycon)
+			   `(#f ,tycon)))
     (LexQtyCls <- (LexModId ".") ? LexTyCls)
     (LexGConSym <- ":" / LexQConSym )
@@ -229,4 +249,48 @@
 
 
+(define-method hascheme:ast-print ((ast <ast-decls>))
+  (let1 ast-decls (decls ast)
+    (unless (null? ast-decls)
+      (hascheme:ast-print (car ast-decls))
+      (unless (null? (cdr ast-decls))
+	(display "; ")
+	(for-each hascheme:ast-print (cdr ast-decls))))))
+
+(define-method hascheme:ast-print ((ast <ast-type-decl>))
+  (hascheme:ast-print (type-decl-left ast))
+  (display " = ")
+  (hascheme:ast-print (type-decl-right ast)))
+
+(define-method hascheme:ast-print ((ast <ast-simple-type>))
+  (let1 vars (type-vars ast)
+    (cond
+     ((null? vars) (display (type-name ast)))
+     (else
+      (display (type-name ast))
+      (for-each (lambda (sym) (format #t " ~a" sym))
+		vars)))))
+
+(define-method hascheme:ast-print ((ast <ast-single-type>))
+  (let1 vars (type-vars ast)
+    (cond
+     ((null? vars) (display (type-name ast)))
+     (else
+      (display (type-name ast))
+      (for-each (lambda (var)
+		  (cond
+		   ((symbol? var) (format #t " ~a" var))
+		   ((is-a? var <ast-type-var>)
+		    (display " ")
+		    (hascheme:ast-print var))
+		   ((is-a? var <ast>)
+		    (display " (")
+		    (hascheme:ast-print var)
+		    (display ")"))
+		   (error "Invalid type")))
+		vars)))))
+
+(define-method hascheme:ast-print ((ast <ast-type-var>))
+  (display (type-var ast)))
+
 (define (hascheme:parser-test)
   (test* "Simplest body" '(())
Index: hh2008/hayamiz/sandbox/hoge.hs
===================================================================
--- hh2008/hayamiz/sandbox/hoge.hs (revision 23)
+++ hh2008/hayamiz/sandbox/hoge.hs (revision 23)
@@ -0,0 +1,10 @@
+
+import Text.ParserCombinators.Parsec
+
+main = putStrLn "unk cnk mnk"
+
+ho'ge :: Int
+ho'ge = 1
+
+foo :: (Int -> (,) Int) Int -> Int
+foo = fst