;;; File: expr-parser           Author: John

(define (parse-exp)
 (trace-parser exp
   (parse-exp-0)))

(define (parse-exp-0)  ;; This picks up expr type signatures
  (let ((exp (parse-exp-i)))
    (token-case
     (\:\: (let ((signature (parse-signature)))
	     (make exp-sign (exp exp) (signature signature))))
   (else exp))))

(define (parse-exp-i)  ;; This collects a list of exps for later prec parsing
  (let ((exps (parse-infix-exps)))
    (if (null? (cdr exps))
	(car exps)
	(make pp-exp-list (exps exps)))))

(define (parse-infix-exps)
  (token-case
     (- (cons (make negate) (parse-infix-exps)))
     (\\ (list (parse-lambda)))
     (|let| (list (parse-let)))
     (|if| (list (parse-if)))
     (|case| (parse-possible-app (parse-case)))
     (else (let ((aexp (parse-aexp)))
	     (parse-possible-app aexp)))))

(define (parse-possible-app exp)
  (token-case
    (aexp-start
     (let ((exp2 (parse-aexp)))
      (parse-possible-app (make app (fn exp) (arg exp2)))))
    (varop
     (let ((varop (varop->ast)))
       (if (eq-token? '\))
	   (list exp varop)
	   `(,exp ,varop ,@(parse-infix-exps)))))
    (conop
     (let ((conop (conop->ast)))
       (if (eq-token? '\))
	   (list exp conop)
	   `(,exp ,conop ,@(parse-infix-exps)))))
    (else (list exp))))

(define (parse-lambda)
  (trace-parser lambda
   (save-parser-context
    (let ((pats (parse-apat-list)))
      (require-token -> (signal-missing-token "`->'" "lambda expression"))
      (let ((exp (parse-exp)))
	(make lambda (pats pats) (body exp)))))))

(define (parse-let)
  (trace-parser let
   (save-parser-context
    (let ((decls (parse-decl-list)))
      (require-token |in| (signal-missing-token "`in'" "let expression"))
      (let ((exp (parse-exp)))
	(make let (decls decls) (body exp)))))))

(define (parse-if)
  (trace-parser if
   (save-parser-context
    (let ((test-exp (parse-exp)))
      (require-token |then| (signal-missing-token "`then'" "if expression"))
      (let ((then-exp (parse-exp)))
	(require-token |else| (signal-missing-token "`else'" "if expression"))
	(let ((else-exp (parse-exp)))
	  (make if (test-exp test-exp)
		   (then-exp then-exp)
		   (else-exp else-exp))))))))

(define (parse-case)
  (trace-parser case
   (save-parser-context
    (let ((exp (parse-exp)))
      (require-token |of| (signal-missing-token "`of'" "case expression"))
      (let ((alts (start-layout (function parse-alts))))
	(make case (exp exp) (alts alts)))))))

(define (parse-alts in-layout?)
  (token-case
    (pat-start
     (let ((alt (parse-alt)))
       (token-case
	(\; (cons alt (parse-alts in-layout?)))
	(else (close-layout in-layout?)
	      (list alt)))))
    (else
     (close-layout in-layout?)
     '())))

(define (parse-alt)
 (trace-parser alt
  (let* ((pat (parse-pat))
	 (rhs-list (token-case
		    (-> (let ((exp (parse-exp)))
			  (list (make guarded-rhs (guard (make omitted-guard))
				                  (rhs exp)))))
		    (\| (parse-guarded-alt-rhs))
		    (else (signal-missing-token "`->' or `|'" "rhs of alt"))))
	 (decls (parse-where-decls)))
    (make alt (pat pat) (rhs-list rhs-list) (where-decls decls)))))

(define (parse-guarded-alt-rhs)
  (let ((guard (parse-exp)))
    (require-token -> (signal-missing-token "`->'" "alt"))
    (let* ((exp (parse-exp))
	   (res (make guarded-rhs (guard guard) (rhs exp))))
      (token-case
       (\| (cons res (parse-guarded-alt-rhs)))
       (else (list res))))))

(define (parse-aexp)
 (trace-parser aexp
  (token-case
    (var (save-parser-context (var->ast)))
    (con (save-parser-context (con->ast)))
    (literal (literal->ast))
    (\(
     (token-case
       (\) (**con/def (core-symbol "UnitConstructor")))
       ((no-advance -) (parse-exp-or-tuple))
       (varop
	(let ((varop (varop->ast)))
	  (make-right-section varop)))
       (conop
	(let ((conop (conop->ast)))
	  (make-right-section conop)))
       (else
	(parse-exp-or-tuple))))
    (\[
     (token-case
      (\] (make list-exp (exps '())))
      (else
       (let ((exp (parse-exp)))
        (token-case
         (\, (let ((exp2 (parse-exp)))
	       (token-case
		 (\] (make list-exp (exps (list exp exp2))))
		 (\.\. (token-case
			 (\] (make sequence-then (from exp) (then exp2)))
			 (else
			   (let ((exp3 (parse-exp)))
			     (require-token
			       \]
			       (signal-missing-token
				 "`]'" "sequence expression"))
			     (make sequence-then-to (from exp) (then exp2)
				                    (to exp3))))))
		 (else
		  (make list-exp
			(exps `(,exp ,exp2 ,@(parse-exp-list))))))))
	 (\.\. (token-case
		 (\] (make sequence (from exp)))
		 (else
		  (let ((exp2 (parse-exp)))
		    (require-token
		      \]
		      (signal-missing-token "`]'" "sequence expression"))
		    (make sequence-to (from exp) (to exp2))))))
	 (\] (make list-exp (exps (list exp))))
	 (\| (parse-list-comp exp))
	 (else
	  (signal-invalid-syntax
	    "a list, sequence, or list comprehension")))))))
    (else
     (signal-invalid-syntax "an aexp")))))

(define (make-right-section op)
  (let ((exps (parse-infix-exps)))
    (token-case
     (\) (make pp-exp-list (exps (cons op exps))))
     (else (signal-missing-token "`)'" "right section expression")))))

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

(define (parse-exp-or-tuple)
  (let ((exp (parse-exp)))
    (token-case
     (\) exp)  ; Note - sections ending in an op are parsed elsewhere
     (else (make-tuple-cons (cons exp (parse-tuple-exp)))))))

(define (parse-tuple-exp)
  (token-case
   (\) '())
   (\, (let ((exp (parse-exp))) (cons exp (parse-tuple-exp))))
   (else (signal-missing-token
	  "`)' or `,'" "tuple or parenthesized expression"))))

;;; List comprehensions

;;; Assume | has been consumed

(define (parse-list-comp exp)
 (save-parser-context 
  (let ((quals (parse-qual-list)))
    (make list-comp (exp exp) (quals quals)))))

(define (parse-qual-list)
  (let ((qual (parse-qual)))
    (token-case
      (\, (cons qual (parse-qual-list)))
      (\] (list qual))
      (else (signal-missing-token "`]' or `,'" "list comprehension")))))

(define (parse-qual)
 (trace-parser qual
  (save-parser-context 
   (let* ((saved-excursion (save-scanner-state))
	  (is-gen? (and (scan-pat) (eq-token? '<-))))
    (restore-excursion saved-excursion)
    (cond (is-gen?
	   (let ((pat (parse-pat)))
	     (advance-token) ; past the <-
	     (let ((exp (parse-exp)))
	       (make qual-generator (pat pat) (exp exp)))))
	  (else
	   (let ((exp (parse-exp)))
	     (make qual-filter (exp exp)))))))))

(define (make-tuple-cons args)
  (let ((tuple-con (**con/def (tuple-constructor (length args)))))
    (**app/l tuple-con args)))