;;; File: type-parser        Author: John

(define (parse-type)
  (let ((type (parse-btype)))
    (token-case
      (->
       (**tycon/def (core-symbol "Arrow") (list type (parse-type))))
      (else type))))

(define (parse-btype)
  (token-case
   (tycon (let* ((tycon (tycon->ast))
		 (tycon-args (parse-atype-list)))
	    (setf (tycon-args tycon) tycon-args)
	    tycon))
   (else
    (parse-atype))))

(define (parse-atype-list)
  (token-case
    (atype-start
     (let ((atype (parse-atype)))
       (cons atype (parse-atype-list))))
    (else '())))

(define (parse-atype)
  (token-case
    (tyvar (tyvar->ast))
    (tycon (tycon->ast))
    (\( (token-case
	  (\) (**tycon/def (core-symbol "UnitType") '()))
	  (else
	    (let ((type (parse-type)))
	      (token-case
	       (\) type)
	       (\, (let ((types  (cons type (parse-type-list))))
		     (**tycon/def (tuple-tycon (length types)) types)))
	       (else
		(signal-missing-token "`)' or `,'" "type expression")))))))
    (\[ (let ((type (parse-type)))
	  (require-token \] (signal-missing-token "`]'" "type expression"))
	  (**tycon/def (core-symbol "List") (list type))))
    (else
     (signal-invalid-syntax "an atype"))))

(define (parse-type-list)
  (let ((type (parse-type)))
    (token-case (\, (cons type (parse-type-list)))
		(\) (list type))
		(else (signal-missing-token "`)' or `,'" "type expression")))))

;;; This is used to determine whether a type is preceded by a context

(define (has-optional-context?)
  (let* ((saved-excursion (save-scanner-state))
	 (res (token-case
		(conid	
		 (token-case
		  (varid (eq-token? '=>))
		  (else '#f)))
		(\( (scan-context))
		(else '#f))))
    (restore-excursion saved-excursion)
    res))

(define (scan-context)
  (token-case
    (conid
     (token-case
       (varid
	 (token-case
	   (\) (eq-token? '=>))
	   (\, (scan-context))
	   (else '#f)))
       (else '#f)))
    (else '#f)))

(define (parse-context)
 (let ((contexts (token-case
	           (tycon
		    (list (parse-single-context)))
		   (\( (parse-contexts))
		   (else
		    (signal-invalid-syntax "a context")))))
   (require-token => (signal-missing-token "`=>'" "context"))
   contexts))

(define (parse-single-context)
  (let ((class (class->ast)))
    (token-case
      (tyvar
       (let ((tyvar (token->symbol)))
	 (make context (class class) (tyvar tyvar))))
      (else (signal-missing-token "<tyvar>" "class assertion")))))

(define (parse-contexts)
  (token-case
    (tycon (let ((context (parse-single-context)))
	      (token-case
		(\, (cons context (parse-contexts)))
		(\) (list context))
		(else (signal-missing-token "`)' or `,'" "context")))))
    (else (signal-missing-token "<tycon>" "class assertion"))))

(define (parse-optional-context)
  (if (has-optional-context?)
      (parse-context)
      '()))

(define (parse-signature)
  (let* ((contexts (parse-optional-context))
	 (type (parse-type)))
    (make signature (context contexts) (type type))))