;;; File: parser/typedecl-parser     Author: John

(define (parse-type-decl interface?)
 (save-parser-context
  (let* ((sig (parse-signature))
	 (contexts (signature-context sig))
	 (simple (signature-type sig))
	 (deriving '())
	 (constrs '()))
    ;; #t = builtins ([] (,,) ->) not allowed
    (check-simple simple '#t "type declaration")
    (let ((annotations (parse-constr-annotations)))
     (token-case
      (= (setf constrs (parse-constrs))
	 (token-case
	  (|deriving|
	   (setf deriving
	     (token-case
		 (\( 
		  (token-case
		   (\) '())
		   (else (parse-class-list))))
		 (tycon (list (class->ast)))
		 (else (signal-invalid-syntax "a deriving clause")))))))
      (else
       (when (not interface?)
	 (signal-missing-constructors))))
    (make data-decl (context contexts) (simple simple)
		    (constrs constrs) (deriving deriving)
		    (annotations annotations))))))

(define (signal-missing-constructors)
  (parser-error 'missing-constructors
		"Data type definition requires constructors"))

(define (check-simple simple fresh? where)
  (when (not (tycon? simple))
    (signal-not-simple where))
  (when (and fresh? (not (eq? (tycon-def simple) *undefined-def*)))
    (signal-not-simple where))
  (let ((tyvars (map (lambda (arg)
		       (when (not (tyvar? arg))
			     (signal-not-simple where))
		       (tyvar-name arg))
		     (tycon-args simple))))
    (when (not (null? (find-duplicates tyvars)))
      (signal-unique-tyvars-required))))

(define (signal-unique-tyvars-required)
  (parser-error 'unique-tyvars-required
		"Duplicate type variables appear in simple."))

(define (signal-not-simple where)
  (parser-error 'not-simple "Simple type required in ~a." where))

(define (parse-constrs)
  (let ((constr (parse-constr)))
    (token-case
     (\| (cons constr (parse-constrs)))
     (else (list constr)))))

(define (parse-constr)
 (save-parser-context
  (let ((saved-excursion (save-scanner-state)))
    (token-case
     (consym/paren
      (parse-prefix-constr))
     (else
      (let ((type1 (parse-btype))
	    (anns (parse-constr-annotations)))
	(token-case
	 (conop
	  (parse-infix-constr (tuple type1 anns)))
	 (else
	  (restore-excursion saved-excursion)
	  (parse-prefix-constr)))))))))

(define (parse-prefix-constr)
  (token-case
   (con
    (let* ((con (con->ast))
	   (types (parse-constr-type-list)))
      (make constr (constructor con) (types types))))
   (else
    (signal-missing-token "<con>" "constrs list"))))

(define (parse-constr-type-list)
  (token-case
    (atype-start
     (let* ((atype (parse-atype))
	    (anns (parse-constr-annotations)))
       (cons (tuple atype anns)
	     (parse-constr-type-list))))
    (else '())))

(define (parse-infix-constr t+a1)
  (let* ((con (conop->ast))
	 (type2 (parse-btype))
	 (anns (parse-constr-annotations)))
    (make constr (constructor con) (types (list t+a1 (tuple type2 anns))))))

(define (parse-class-list)
  (token-case
   (tycon (let ((class (class->ast)))
	     (token-case
	      (\, (cons class (parse-class-list)))
	      (\) (list class))
	      (else (signal-missing-token "`)' or `,'" "deriving clause")))))
   (else (signal-missing-token "<tycon>" "deriving clause"))))

(define (parse-constr-annotations)
  (token-case
   ((begin-annotation no-advance)
    (let ((annotations (parse-annotations)))
      (append annotations (parse-constr-annotations))))
   (else '())))

(define (parse-synonym-decl)
 (save-parser-context
  (let* ((sig (parse-signature))
	 (contexts (signature-context sig))
	 (simple (signature-type sig)))
    (check-simple simple '#t "type synonym declaration")
    (when (not (null? contexts))
      (signal-no-context-in-synonym))
    (require-token = (signal-missing-token "`='" "type synonym declaration"))
    (let ((body (parse-type)))
      (make synonym-decl (simple simple) (body body))))))

(define (signal-no-context-in-synonym)
  (parser-error 'no-context-in-synonym
		"Context is not permitted in type synonym declaration."))

(define (parse-class-decl)
 (save-parser-context
  (let ((supers (parse-optional-context)))
    (token-case
     (tycon
      (let ((class (class->ast)))
	(token-case
	 (tyvar
	  (let* ((class-var (token->symbol))
		 (decls (parse-where-decls)))
	    (make class-decl (class class) (super-classes supers)
		             (class-var class-var) (decls decls))))
	 (else
	  (signal-missing-token "<tyvar>" "class declaration")))))
     (else (signal-missing-token "<tycon>" "class declaration"))))))

(define (parse-instance-decl interface?)
 (save-parser-context
  (let ((contexts (parse-optional-context))
	(decls '()))
    (token-case
     (tycon
      (let* ((class (class->ast))
	     (simple (parse-type)))
	(when (not interface?)
	   (setf decls (parse-where-decls)))
	(check-simple simple '#f "instance declaration")
	(make instance-decl (context contexts) (class class)
	                    (simple simple) (decls decls))))
     (else (signal-missing-token "<tycon>" "instance declaration"))))))