Changes in hh2008/hayamiz/trunk/hascheme/parser.scm [15:23]

Files:

• hh2008/hayamiz/trunk/hascheme/parser.scm (modified) (9 diffs)

hh2008/hayamiz/trunk/hascheme/parser.scm

@@ -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 +16 @@
 (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 +36 @@
     (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 +79 @@
                 )
 
-    (FuncApplyExpression <- AtomExpression +)
+    (FuncApplyExpression 
+     <- (:atom AtomExpression)
+     (:rest-atoms ((Spaces (:inatm AtomExpression) :return inatm) *))
+     Spaces* :return `(:funapply ,atom ,@rest-atoms))
     (AtomExpression
      <- QVar
@@ -109 +116 @@
      / "~" Spaces* AtomPattern)
 
-    (QVar <- LexQVarId / "(" Spaces* LexQVarSym Spaces* ")")
+    (QVar <- LexQVarId
+          / "(" Spaces* (:sym LexQVarSym) Spaces* ")" :return sym)
     (GCon <- "(" Spaces* ")"
           / "[" Spaces* "]"
@@ -122 +130 @@
            / 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 +158 @@
            / "(" 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 +224 @@
     (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 +249 @@
 
 
+(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" '(())