;;; 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)))