diff --git a/src/analysis/analysis.lisp b/src/analysis/analysis.lisp index e65c587d..2bda8422 100644 --- a/src/analysis/analysis.lisp +++ b/src/analysis/analysis.lisp @@ -10,7 +10,6 @@ #:coalton-impl/analysis/underapplied-values #:find-underapplied-values) (:local-nicknames - (#:se #:source-error) (#:source #:coalton-impl/source) (#:util #:coalton-impl/util) (#:tc #:coalton-impl/typechecker)) @@ -19,25 +18,15 @@ (in-package #:coalton-impl/analysis/analysis) -(define-condition non-exhaustive-match-warning (se:source-base-warning) - ()) - -(define-condition useless-pattern-warning (se:source-base-warning) - ()) - -(define-condition pattern-var-matches-constructor (se:source-base-warning) - ()) - (defun check-pattern-exhaustiveness (pattern env) (declare (type tc:pattern pattern) (type tc:environment env)) (let ((missing (find-non-matching-value (list (list pattern)) 1 env))) (unless (eq t missing) - (tc-error pattern - "Non-exhaustive match" - (format nil "Missing case ~W" - (print-pattern (first missing))))))) + (tc-error "Non-exhaustive match" + (source:note pattern "missing case ~w" + (print-pattern (first missing))))))) (defun analyze-translation-unit (translation-unit env) "Perform analysis passes on TRANSLATION-UNIT, potentially producing errors or warnings." @@ -54,33 +43,18 @@ (let ((exhaustive-or-missing (find-non-matching-value (mapcar #'list patterns) 1 env))) (unless (eq t exhaustive-or-missing) - (warn 'non-exhaustive-match-warning - :err (source:source-error - :type :warn - :location (source:location node) - :message "Non-exhaustive match" - :primary-note "non-exhaustive match" - :notes (when (first exhaustive-or-missing) - (list - (se:make-source-error-note - :type :secondary - :span (source:location-span (source:location node)) - :message (format nil "Missing case ~W" - (print-pattern (first exhaustive-or-missing))))))))) + (apply #'source:warn "non-exhaustive match" + (cons (source:note node "non-exhaustive match") + (when (first exhaustive-or-missing) + (list + (source:note node "missing case ~w" + (print-pattern + (first exhaustive-or-missing)))))))) (loop :for pattern :in patterns :unless (useful-pattern-p patterns pattern env) :do - (warn 'useless-pattern-warning - :err (source:source-error - :type :warn - :location (source:location pattern) - :message "Useless match case" - :primary-note "useless match case" - :notes - (list - (se:make-source-error-note - :type :secondary - :span (source:location-span (source:location node)) - :message "in this match"))))))) + (source:warn "Useless match case" + (source:note pattern "useless match case") + (source:note node "in this match"))))) node) :abstraction (lambda (node) (declare (type tc:node-abstraction node)) @@ -122,12 +96,8 @@ (let ((ctor (tc:lookup-constructor env (tc:pattern-var-orig-name pat) :no-error t))) (when ctor - (warn 'pattern-var-matches-constructor - :err (source:source-error - :type :warn - :location (source:location pat) - :message "Pattern warning" - :primary-note "pattern variable matches constructor name"))))) + (source:warn "Pattern warning" + (source:note pat "pattern variable matches constructor name"))))) (:method ((pat tc:pattern-literal) env) (declare (ignore env))) diff --git a/src/analysis/underapplied-values.lisp b/src/analysis/underapplied-values.lisp index 32d5024d..e3034c8d 100644 --- a/src/analysis/underapplied-values.lisp +++ b/src/analysis/underapplied-values.lisp @@ -2,18 +2,13 @@ (:use #:cl) (:local-nicknames - (#:se #:source-error) (#:source #:coalton-impl/source) - (#:util #:coalton-impl/util) (#:tc #:coalton-impl/typechecker)) (:export #:find-underapplied-values)) (in-package #:coalton-impl/analysis/underapplied-values) -(define-condition underapplied-value-warning (se:source-base-warning) - ()) - (defun find-underapplied-values (binding) (tc:traverse (tc:binding-value binding) @@ -24,10 +19,7 @@ (loop :for elem :in (tc:node-body-nodes node) :when (and (typep elem 'tc:node) (tc:function-type-p (tc:qualified-ty-type (tc:node-type elem)))) - :do (warn 'underapplied-value-warning - :err (source:source-error - :type :warn - :location (source:location elem) - :message "Value may be underapplied" - :primary-note "discard explicitly with (let _ = ...) to ignore this warning"))) + :do (source:warn "Value may be underapplied" + (source:note elem + "discard explicitly with (let _ = ...) to ignore this warning"))) node)))) diff --git a/src/analysis/unused-variables.lisp b/src/analysis/unused-variables.lisp index d22920b2..e3377848 100644 --- a/src/analysis/unused-variables.lisp +++ b/src/analysis/unused-variables.lisp @@ -2,20 +2,14 @@ (:use #:cl) (:local-nicknames - (#:se #:source-error) (#:source #:coalton-impl/source) (#:util #:coalton-impl/util) (#:tc #:coalton-impl/typechecker)) (:export - #:find-unused-variables ; FUNCTION - #:unused-variable-warning ; CONDITION - )) + #:find-unused-variables)) (in-package #:coalton-impl/analysis/unused-variables) -(define-condition unused-variable-warning (se:source-base-warning) - ()) - (defun find-unused-variables (binding) (declare (type (or tc:toplevel-define tc:instance-method-definition) binding)) (let ((used-variables (make-hash-table :test #'eq))) @@ -81,16 +75,9 @@ (unless (char= (aref (symbol-name name) 0) #\_) (unless (gethash name used-variables) - (warn 'unused-variable-warning - :err (source:source-error - :type :warn - :location location - :message "Unused variable" - :primary-note "variable defined here" - :help-notes - (list - (se:make-source-error-help - :span (source:location-span location) - :replacement (lambda (name) - (concatenate 'string "_" name)) - :message "prefix the variable with '_' to declare it unused")))))))) + (source:warn "Unused variable" + (source:note location "variable defined here") + (source:help location + (lambda (name) + (concatenate 'string "_" name)) + "prefix the variable with '_' to declare it unused")))))) diff --git a/src/entry.lisp b/src/entry.lisp index 92f30c22..61349d67 100644 --- a/src/entry.lisp +++ b/src/entry.lisp @@ -110,9 +110,9 @@ (setf subs (tc:compose-substitution-lists subs subs_)) (when accessors - (tc:tc-error (first accessors) - "Ambiguous accessor" - "accessor is ambiguous")) + (tc:tc-error "Ambiguous accessor" + (source:note (first accessors) + "accessor is ambiguous"))) (let* ((preds (tc:reduce-context env preds subs)) (subs (tc:compose-substitution-lists @@ -145,25 +145,21 @@ tvars (tc:ty-scheme-type scheme)))) - (tc:tc-error node - "Unable to codegen" - (format nil - "expression has type ~A~{ ~S~}.~{ (~S)~} => ~S with unresolved constraint~A ~S" - (if settings:*coalton-print-unicode* - "∀" - "FORALL") - tvars - (tc:qualified-ty-predicates qual-type) - (tc:qualified-ty-type qual-type) - (if (= (length (tc:qualified-ty-predicates qual-type)) 1) - "" - "s") - (tc:qualified-ty-predicates qual-type)) - (list - (se:make-source-error-note - :type :secondary - :span (source:location-span (source:location node)) - :message "Add a type assertion with THE to resolve ambiguity")))))))))) + (tc:tc-error "Unable to codegen" + (tc:tc-note node + "expression has type ~A~{ ~S~}.~{ (~S)~} => ~S with unresolved constraint~A ~S" + (if settings:*coalton-print-unicode* + "∀" + "FORALL") + tvars + (tc:qualified-ty-predicates qual-type) + (tc:qualified-ty-type qual-type) + (if (= (length (tc:qualified-ty-predicates qual-type)) 1) + "" + "s") + (tc:qualified-ty-predicates qual-type)) + (tc:tc-note node + "Add a type assertion with THE to resolve ambiguity"))))))))) (defmacro with-environment-updates (updates &body body) "Collect environment updates into a vector bound to UPDATES." diff --git a/src/parser/base.lisp b/src/parser/base.lisp index 5f78451a..b3a25a7c 100644 --- a/src/parser/base.lisp +++ b/src/parser/base.lisp @@ -20,10 +20,12 @@ #:make-identifier-src ; CONSTRUCTOR #:identifier-src-name ; ACCESSOR #:identifier-src-list ; TYPE - #:parse-error ; CONDITION - #:source-note ; FUNCTION #:parse-list ; FUNCTION - )) + #:parse-error + #:note + #:note-end + #:help + #:form-location)) (in-package #:coalton-impl/parser/base) @@ -89,8 +91,8 @@ ;;; A complex parse error may be signaled with: ;;; ;;; (parse-error "Overall description of condition" -;;; (source-note SOURCE CST1 "Primary ~A: ~A" ARG1 ARG2) -;;; (source-note SOURCE CST2 "Related ~A: ~A" ARG3 ARG4) +;;; (note SOURCE CST1 "Primary ~A: ~A" ARG1 ARG2) +;;; (note SOURCE CST2 "Related: ~A" ARG3) ;;; ... ) (define-condition parse-error (se:source-base-error) @@ -98,13 +100,35 @@ (:documentation "A condition indicating a syntax error in Coalton source code.")) (defun parse-error (message &rest notes) - "Signal a PARSE-ERROR with provided MESSAGE and source NOTES." + "Signal PARSE-ERROR with provided MESSAGE and source NOTES." (error 'parse-error :err (source:make-source-error ':error message notes))) -(defun source-note (source cst format-string &rest format-args) - "Helper function to make a source note using SOURCE and CST:SOURCE as location." - (declare (type cst:cst cst) - (type string format-string)) +(defun ensure-span (spanning) + "Is SPANNING is a span, return it unchanged; if it is a cst node, return the node's span." + (etypecase spanning + (cst:cst (cst:source spanning)) + (source:span spanning))) + +(defun note (source locatable format-string &rest format-args) + "Make a source note using SOURCE and CST:SOURCE as location." + (declare (type string format-string)) + (apply #'source:note (source:make-location source (ensure-span locatable)) + format-string format-args)) + +(defun note-end (source locatable format-string &rest format-args) + "Make a source note using SOURCE and the location immediately following CST:SOURCE as location." (apply #'source:note - (source:make-location source (cst:source cst)) + (source:end-location (source:make-location source + (ensure-span locatable))) format-string format-args)) + +(defun help (source locatable replace format-string &rest format-args) + "Make a help note using SOURCE and CST:SOURCE as location." + (declare (type string format-string)) + (apply #'source:help (source:make-location source (ensure-span locatable)) + replace format-string format-args)) + +(defun form-location (source cst) + "Make a source location from a SOURCE and a CST node." + (declare (type cst:cst cst)) + (source:make-location source (cst:source cst))) diff --git a/src/parser/expression.lisp b/src/parser/expression.lisp index 1ea6f67c..86f50085 100644 --- a/src/parser/expression.lisp +++ b/src/parser/expression.lisp @@ -566,12 +566,8 @@ Rebound to NIL parsing an anonymous FN.") ((cst:atom form) (typecase (cst:raw form) (null - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Malformed expression" - :primary-note "unexpected `nil` or `()`"))) + (parse-error "Malformed expression" + (note source form "unexpected `nil` or `()`"))) (symbol (if (char= #\. (aref (symbol-name (cst:raw form)) 0)) @@ -586,12 +582,8 @@ Rebound to NIL parsing an anonymous FN.") ;; ((not (cst:proper-list-p form)) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Malformed expression" - :primary-note "unexpected dotted list"))) + (parse-error "Malformed expression" + (note source form "unexpected dotted list"))) ;; ;; Keywords @@ -605,43 +597,26 @@ Rebound to NIL parsing an anonymous FN.") ;; (fn) (unless (cst:consp (cst:rest form)) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :highlight :end - :message "Malformed function" - :primary-note "expected function arguments"))) + (parse-error "Malformed function" + (note-end source form "expected function arguments"))) ;; (fn (...)) (unless (cst:consp (cst:rest (cst:rest form))) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :highlight :end - :message "Malformed function" - :primary-note "expected function body"))) + (parse-error "Malformed function" + (note-end source form "expected function body"))) ;; (fn x ...) ;; ;; NOTE: (fn () ...) is allowed (when (and (cst:atom (cst:second form)) (not (null (cst:raw (cst:second form))))) - (error 'parse-error - :err (se:source-error - :span (cst:source (cst:second form)) - :source source - :message "Malformed function" - :primary-note "malformed argument list" - :help-notes - (list - (se:make-source-error-help - :span (cst:source (cst:second form)) - :replacement - (lambda (existing) - (concatenate 'string "(" existing ")")) - :message "add parentheses"))))) + (parse-error "Malformed function" + (note source (cst:second form) + "malformed argument list") + (help source (cst:second form) + (lambda (existing) + (concatenate 'string "(" existing ")")) + "add parentheses"))) ;; Bind *LOOP-LABEL-CONTEXT* to NIL to disallow BREAKing from ;; or CONTINUING with loops that enclose the FN form. (let ((*loop-label-context* nil)) @@ -653,38 +628,24 @@ Rebound to NIL parsing an anonymous FN.") (make-node-abstraction :params params :body body - :location (source:make-location source form))))) + :location (form-location source form))))) ((and (cst:atom (cst:first form)) (eq 'coalton:let (cst:raw (cst:first form)))) ;; (let) (unless (cst:consp (cst:rest form)) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :highlight :end - :message "Malformed let" - :primary-note "expected let binding list"))) + (parse-error "Malformed let" + (note-end source form "expected let binding list"))) ;; (let (...)) (unless (cst:consp (cst:rest (cst:rest form))) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :highlight :end - :message "Malformed let" - :primary-note "expected let body"))) - - (unless (cst:proper-list-p (cst:second form)) - (error 'parse-error - :err (se:source-error - :span (cst:source (cst:second form)) - :source source - :message "Malformed let" - :primary-note "expected binding list"))) + (parse-error "Malformed let" + (note-end source form "expected let body"))) + + (unless (cst:proper-list-p (cst:second form)) + (parse-error "Malformed let" + (note source (cst:second form) "expected binding list"))) (let* (declares @@ -705,39 +666,24 @@ Rebound to NIL parsing an anonymous FN.") :bindings bindings :declares (nreverse declares) :body (parse-body (cst:nthrest 2 form) form source) - :location (source:make-location source form)))) + :location (form-location source form)))) ((and (cst:atom (cst:first form)) (eq 'coalton:lisp (cst:raw (cst:first form)))) ;; (lisp) (unless (cst:consp (cst:rest form)) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :highlight :end - :message "Malformed lisp expression" - :primary-note "expected expression type"))) + (parse-error "Malformed lisp expression" + (note-end source form "expected expression type"))) ;; (lisp T) (unless (cst:consp (cst:rest (cst:rest form))) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :highlight :end - :message "Malformed lisp expression" - :primary-note "expected binding list"))) + (parse-error "Malformed lisp expression" + (note-end source form "expected binding list"))) ;; (lisp T (...)) (unless (cst:consp (cst:rest (cst:rest (cst:rest form)))) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :highlight :all - :message "Malformed lisp expression" - :primary-note "expected body"))) + (parse-error "Malformed lisp expression" + (note source form "expected body"))) (let ((vars (loop :for vars := (cst:third form) :then (cst:rest vars) :while (cst:consp vars) @@ -747,69 +693,51 @@ Rebound to NIL parsing an anonymous FN.") :vars vars :var-names (mapcar #'node-variable-name vars) :body (cst:raw (cst:nthrest 3 form)) - :location (source:make-location source form)))) + :location (form-location source form)))) ((and (cst:atom (cst:first form)) (eq 'coalton:match (cst:raw (cst:first form)))) ;; (match) (unless (cst:consp (cst:rest form)) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :highlight :end - :message "Malformed match expression" - :primary-note "expected expression"))) + (parse-error "Malformed match expression" + (note-end source form "expected expression"))) (make-node-match :expr (parse-expression (cst:second form) source) :branches (loop :for branches := (cst:nthrest 2 form) :then (cst:rest branches) :while (cst:consp branches) :collect (parse-match-branch (cst:first branches) source)) - :location (source:make-location source form))) + :location (form-location source form))) ((and (cst:atom (cst:first form)) (eq 'coalton:progn (cst:raw (cst:first form)))) (make-node-progn :body (parse-body (cst:rest form) form source) - :location (source:make-location source form))) + :location (form-location source form))) ((and (cst:atom (cst:first form)) (eq 'coalton:the (cst:raw (cst:first form)))) ;; (the) (unless (cst:consp (cst:rest form)) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :highlight :end - :message "Malformed the expression" - :primary-note "expected type"))) + (parse-error "Malformed the expression" + (note-end source form "expected type"))) ;; (the T) (unless (cst:consp (cst:rest (cst:rest form))) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :highlight :end - :message "Malformed the expression" - :primary-note "expected value"))) + (parse-error "Malformed the expression" + (note-end source form "expected value"))) ;; (the a b c) (when (cst:consp (cst:rest (cst:rest (cst:rest form)))) - (error 'parse-error - :err (se:source-error - :span (cst:source (cst:first (cst:rest (cst:rest (cst:rest form))))) - :source source - :message "Malformed the expression" - :primary-note "unexpected trailing form"))) + (parse-error "Malformed the expression" + (note source (cst:first (cst:rest (cst:rest (cst:rest form)))) + "unexpected trailing form"))) (make-node-the :type (parse-type (cst:second form) source) :expr (parse-expression (cst:third form) source) - :location (source:make-location source form))) + :location (form-location source form))) ((and (cst:atom (cst:first form)) (eq 'coalton:return (cst:raw (cst:first form)))) @@ -819,148 +747,101 @@ Rebound to NIL parsing an anonymous FN.") (when (cst:consp (cst:rest form)) ;; (return a b ...) (when (cst:consp (cst:rest (cst:rest form))) - (error 'parse-error - :err (se:source-error - :span (cst:source (cst:first (cst:rest (cst:rest form)))) - :source source - :message "Malformed return expression" - :primary-note "unexpected trailing form"))) + (parse-error "Malformed return expression" + (note source (cst:first (cst:rest (cst:rest form))) + "unexpected trailing form"))) (setf expr (parse-expression (cst:second form) source))) (make-node-return :expr expr - :location (source:make-location source form)))) + :location (form-location source form)))) ((and (cst:atom (cst:first form)) (eq 'coalton:or (cst:raw (cst:first form)))) (unless (cst:consp (cst:rest form)) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :highlight :end - :message "Malformed or expression" - :primary-note "expected one or more arguments"))) + (parse-error "Malformed or expression" + (note-end source form "expected one or more arguments"))) (make-node-or :nodes (loop :for args := (cst:rest form) :then (cst:rest args) :while (cst:consp args) :for arg := (cst:first args) :collect (parse-expression arg source)) - :location (source:make-location source form))) + :location (form-location source form))) ((and (cst:atom (cst:first form)) (eq 'coalton:and (cst:raw (cst:first form)))) (unless (cst:consp (cst:rest form)) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :highlight :end - :message "Malformed and expression" - :primary-note "expected one or more arguments"))) + (parse-error "Malformed and expression" + (note-end source form "expected one or more arguments"))) (make-node-and :nodes (loop :for args := (cst:rest form) :then (cst:rest args) :while (cst:consp args) :for arg := (cst:first args) :collect (parse-expression arg source)) - :location (source:make-location source form))) + :location (form-location source form))) ((and (cst:atom (cst:first form)) (eq 'coalton:if (cst:raw (cst:first form)))) (unless (cst:consp (cst:rest form)) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :highlight :end - :message "Malformed if expression" - :primary-note "expected a predicate"))) + (parse-error "Malformed if expression" + (note-end source form "expected a predicate"))) (unless (cst:consp (cst:rest (cst:rest form))) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :highlight :end - :message "Malformed if expression" - :primary-note "expected a form"))) + (parse-error "Malformed if expression" + (note-end source form "expected a form"))) (unless (cst:consp (cst:rest (cst:rest (cst:rest form)))) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :highlight :end - :message "Malformed if expression" - :primary-note "expected a form"))) + (parse-error "Malformed if expression" + (note-end source form "expected a form"))) (when (cst:consp (cst:rest (cst:rest (cst:rest (cst:rest form))))) - (error 'parse-error - :err (se:source-error - :span (cst:source (cst:first (cst:rest (cst:rest (cst:rest (cst:rest form)))))) - :source source - :highlight :end - :message "Malformed if expression" - :primary-note "unexpected trailing form"))) + (parse-error "Malformed if expression" + (note-end source (cst:first (cst:rest (cst:rest (cst:rest (cst:rest form))))) + "unexpected trailing form"))) (make-node-if :expr (parse-expression (cst:second form) source) :then (parse-expression (cst:third form) source) :else (parse-expression (cst:fourth form) source) - :location (source:make-location source form))) + :location (form-location source form))) ((and (cst:atom (cst:first form)) (eq 'coalton:when (cst:raw (cst:first form)))) (unless (cst:consp (cst:rest form)) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :highlight :end - :message "Malformed when expression" - :primary-note "expected a predicate"))) + (parse-error "Malformed when expression" + (note-end source form "expected a predicate"))) (make-node-when :expr (parse-expression (cst:second form) source) :body (parse-body (cst:rest (cst:rest form)) form source) - :location (source:make-location source form))) + :location (form-location source form))) ((and (cst:atom (cst:first form)) (eq 'coalton:unless (cst:raw (cst:first form)))) (unless (cst:consp (cst:rest form)) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :highlight :end - :message "Malformed unless expression" - :primary-note "expected a predicate"))) + (parse-error "Malformed unless expression" + (note-end source form "expected a predicate"))) (make-node-unless :expr (parse-expression (cst:second form) source) :body (parse-body (cst:rest (cst:rest form)) form source) - :location (source:make-location source form))) + :location (form-location source form))) ((and (cst:atom (cst:first form)) (eq 'coalton:cond (cst:raw (cst:first form)))) (unless (cst:consp (cst:rest form)) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :highlight :end - :message "Malformed cond expression" - :primary-note "expected one or more clauses"))) + (parse-error "Malformed cond expression" + (note-end source form "expected one or more clauses"))) (make-node-cond :clauses (loop :for clauses := (cst:rest form) :then (cst:rest clauses) :while (cst:consp clauses) :for clause := (cst:first clauses) :collect (parse-cond-clause clause source)) - :location (source:make-location source form))) + :location (form-location source form))) ((and (cst:atom (cst:first form)) (eq 'coalton:do (cst:raw (cst:first form)))) @@ -972,29 +853,19 @@ Rebound to NIL parsing an anonymous FN.") (multiple-value-bind (label labelled-body) (take-label form) ;; (while [label]) (unless (cst:consp labelled-body) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :highlight :end - :message "Malformed while expression" - :primary-note "expected condition"))) + (parse-error "Malformed while expression" + (note-end source form "expected condition"))) ;; (while [label] condition) (unless (cst:consp (cst:rest labelled-body)) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :highlight :end - :message "Malformed while expression" - :primary-note "expected body"))) + (parse-error "Malformed while expression" + (note-end source form "expected body"))) (let ((*loop-label-context* - (if label + (if label (list* label const:+default-loop-label+ *loop-label-context*) (cons const:+default-loop-label+ *loop-label-context*)))) (make-node-while - :location (source:make-location source form) + :location (form-location source form) :label (or label const:+default-loop-label+) :expr (parse-expression (cst:first labelled-body) source) :body (parse-body (cst:rest labelled-body) form source))))) @@ -1005,52 +876,32 @@ Rebound to NIL parsing an anonymous FN.") (multiple-value-bind (label labelled-body) (take-label form) ;; (while-let [label]) (unless (cst:consp labelled-body) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :highlight :end - :message "Malformed while-let expression" - :primary-note "expected pattern"))) + (parse-error "Malformed while-let expression" + (note-end source form "expected pattern"))) ;; (while-let [label] pattern) (unless (and (cst:consp (cst:rest labelled-body)) (eq 'coalton:= (cst:raw (cst:second labelled-body)))) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :highlight :end - :message "Malformed while-let expression" - :primary-note "expected ="))) - + (parse-error "Malformed while-let expression" + (note-end source form "expected ="))) + ;; (when-let [label] pattern =) (unless (cst:consp (cst:nthrest 2 labelled-body)) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :highlight :end - :message "Malformed while-let expression" - :primary-note "expected expression"))) - + (parse-error "Malformed while-let expression" + (note-end source form "expected expression"))) + ;; (when-let pattern = expr) (unless (cst:consp (cst:nthrest 3 labelled-body)) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :highlight :end - :message "Malformed while-let expression" - :primary-note "expected body"))) + (parse-error "Malformed while-let expression" + (note-end source form "expected body"))) (let* ((*loop-label-context* (if label (list* label const:+default-loop-label+ *loop-label-context*) (cons const:+default-loop-label+ *loop-label-context*)))) (make-node-while-let - :location (source:make-location source form) + :location (form-location source form) :label (or label const:+default-loop-label+) - :pattern (parse-pattern (cst:first labelled-body) source) + :pattern (parse-pattern (cst:first labelled-body) source) :expr (parse-expression (cst:third labelled-body) source) :body (parse-body (cst:nthrest 3 labelled-body) form source))))) @@ -1058,20 +909,15 @@ Rebound to NIL parsing an anonymous FN.") (eq 'coalton:loop (cst:raw (cst:first form)))) (multiple-value-bind (label labelled-body) (take-label form) (unless (cst:consp labelled-body) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :highlight :end - :message "Malformed loop expression" - :primary-note "expected a loop body"))) + (parse-error "Malformed loop expression" + (note-end source form "expected a loop body"))) (let* ((*loop-label-context* (if label (list* label const:+default-loop-label+ *loop-label-context*) (cons const:+default-loop-label+ *loop-label-context*)))) (make-node-loop - :location (source:make-location source form) + :location (form-location source form) :label (or label const:+default-loop-label+) :body (parse-body labelled-body form source))))) @@ -1080,32 +926,23 @@ Rebound to NIL parsing an anonymous FN.") (multiple-value-bind (label postlabel) (take-label form) (unless (cst:null postlabel) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Invalid argument in break" - :primary-note (if label - "unexpected argument after label" - "expected a keyword")))) + (parse-error "Invalid argument in break" + (note-end source form + (if label + "unexpected argument after label" + "expected a keyword")))) (if label (unless (member label *loop-label-context*) - (error 'parse-error - :err (se:source-error - :span (cst:source (cst:second form)) - :source source - :message "Invalid label in break" - :primary-note "label not found in any enclosing loop"))) + (parse-error "Invalid label in break" + (note source (cst:second form) + "label not found in any enclosing loop"))) (unless *loop-label-context* - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Invalid break" - :primary-note "break does not appear in an enclosing loop")))) - - (make-node-break :location (source:make-location source form) + (parse-error "Invalid break" + (note source form + "break does not appear in an enclosing loop")))) + + (make-node-break :location (form-location source form) :label (or label (car *loop-label-context*))))) ((and (cst:atom (cst:first form)) @@ -1113,34 +950,25 @@ Rebound to NIL parsing an anonymous FN.") (multiple-value-bind (label postlabel) (take-label form) (unless (cst:null postlabel) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Invalid argument in continue" - :primary-note (if label - "unexpected argument after label" - "expected a keyword")))) + (parse-error "Invalid argument in continue" + (note source form + (if label + "unexpected argument after label" + "expected a keyword")))) (if label (unless (member label *loop-label-context*) - (error 'parse-error - :err (se:source-error - :span (cst:source (cst:second form)) - :source source - :message "Invalid label in continue" - :primary-note "label not found in any enclosing loop"))) + (parse-error "Invalid label in continue" + (note source (cst:second form) + "label not found in any enclosing loop"))) (unless *loop-label-context* - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Invalid continue" - :primary-note "continue does not appear in an enclosing loop")))) - - (make-node-continue :location (source:make-location source form) + (parse-error "Invalid continue" + (note source form + "continue does not appear in an enclosing loop")))) + + (make-node-continue :location (form-location source form) :label (or label (car *loop-label-context*))))) - + ((and (cst:atom (cst:first form)) (eq 'coalton:for (cst:raw (cst:first form)))) @@ -1148,54 +976,34 @@ Rebound to NIL parsing an anonymous FN.") (multiple-value-bind (label labelled-body) (take-label form) ;; (for [label]) (unless (cst:consp labelled-body) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :highlight :end - :message "Malformed for expression" - :primary-note "expected pattern"))) - + (parse-error "Malformed for expression" + (note-end source form "expected pattern"))) + ;; (for [label] pattern) (unless (and (cst:consp (cst:rest labelled-body)) (cst:atom (cst:second labelled-body)) (eq 'coalton:in (cst:raw (cst:second labelled-body)))) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :highlight :end - :message "Malformed for expression" - :primary-note "expected in"))) + (parse-error "Malformed for expression" + (note-end source form "expected in"))) ;; (for [label] pattern in) (unless (cst:consp (cst:nthrest 2 labelled-body)) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :highlight :end - :message "Malformed for expression" - :primary-note "expected expression"))) - + (parse-error "Malformed for expression" + (note-end source form "expected expression"))) + ;; (for [label] pattern in expr) (unless (cst:consp (cst:nthrest 3 labelled-body)) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :highlight :end - :message "Malformed for expression" - :primary-note "expected body"))) - + (parse-error "Malformed for expression" + (note-end source form "expected body"))) + (let ((*loop-label-context* (if label (list* label const:+default-loop-label+ *loop-label-context*) (cons const:+default-loop-label+ *loop-label-context*)))) (make-node-for - :location (source:make-location source form) + :location (form-location source form) :label (or label const:+default-loop-label+) - :pattern (parse-pattern (cst:first labelled-body) source) + :pattern (parse-pattern (cst:first labelled-body) source) :expr (parse-expression (cst:third labelled-body) source) :body (parse-body (cst:nthrest 3 labelled-body) form source))))) @@ -1210,12 +1018,8 @@ Rebound to NIL parsing an anonymous FN.") (let ((*macro-expansion-count* (+ 1 *macro-expansion-count*))) (when (= *macro-expansion-count* +macro-expansion-max+) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Invalid macro expansion" - :primary-note "macro expansion limit hit"))) + (parse-error "Invalid macro expansion" + (note source form "macro expansion limit hit"))) (let ((se:*source-error-context* (adjoin (se:make-source-error-context @@ -1235,7 +1039,7 @@ Rebound to NIL parsing an anonymous FN.") :while (cst:consp rands) :for rand := (cst:first rands) :collect (parse-expression rand source)) - :location (source:make-location source form))))) + :location (form-location source form))))) (defun parse-variable (form source) (declare (type cst:cst form) @@ -1243,32 +1047,20 @@ Rebound to NIL parsing an anonymous FN.") (unless (and (cst:atom form) (identifierp (cst:raw form))) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Invalid variable" - :primary-note "expected identifier"))) + (parse-error "Invalid variable" + (note source form "expected identifier"))) (when (string= "_" (symbol-name (cst:raw form))) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Invalid variable" - :primary-note "invalid variable name '_'"))) + (parse-error "Invalid variable" + (note source form "invalid variable name '_'"))) (when (char= #\. (aref (symbol-name (cst:raw form)) 0)) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Invalid variable" - :primary-note "variables cannot start with '.'"))) + (parse-error "Invalid variable" + (note source form "variables cannot start with '.'"))) (make-node-variable :name (cst:raw form) - :location (source:make-location source form))) + :location (form-location source form))) (defun parse-accessor (form source) (declare (type cst:cst form) @@ -1280,7 +1072,7 @@ Rebound to NIL parsing an anonymous FN.") (make-node-accessor :name (subseq (symbol-name (cst:raw form)) 1) - :location (source:make-location source form))) + :location (form-location source form))) (defun parse-literal (form source) (declare (type cst:cst form) @@ -1292,33 +1084,24 @@ Rebound to NIL parsing an anonymous FN.") (integer (make-node-integer-literal :value (cst:raw form) - :location (source:make-location source form))) + :location (form-location source form))) (util:literal-value (make-node-literal :value (cst:raw form) - :location (source:make-location source form))) + :location (form-location source form))) (t - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Invalid literal" - :primary-note "unknown literal type"))))) + (parse-error "Invalid literal" + (note source form "unknown literal type"))))) (defun parse-body (form enclosing-form source) (declare (type cst:cst form) (values node-body &optional)) (when (cst:atom form) - (error 'parse-error - :err (se:source-error - :span (cst:source enclosing-form) - :source source - :highlight :end - :message "Malformed function" - :primary-note "expected body"))) + (parse-error "Malformed function" + (note-end source enclosing-form "expected body"))) (assert (cst:proper-list-p form)) @@ -1373,17 +1156,14 @@ Rebound to NIL parsing an anonymous FN.") (values node-bind)) (when (cst:consp (cst:rest (cst:rest (cst:rest (cst:rest form))))) - (error 'parse-error - :err (se:source-error - :span (cst:source (cst:first (cst:rest (cst:rest (cst:rest (cst:rest form)))))) - :source source - :message "Malformed shorthand let" - :primary-note "unexpected trailing form"))) + (parse-error "Malformed shorthand let" + (note source (cst:first (cst:rest (cst:rest (cst:rest (cst:rest form))))) + "unexpected trailing form"))) (make-node-bind :pattern (parse-pattern (cst:second form) source) :expr (parse-expression (cst:fourth form) source) - :location (source:make-location source form))) + :location (form-location source form))) (defun parse-body-element (form source) (declare (type cst:cst form) @@ -1394,12 +1174,8 @@ Rebound to NIL parsing an anonymous FN.") (parse-expression form source))) (unless (cst:proper-list-p form) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Malformed body expression" - :primary-note "unexpected dotted list"))) + (parse-error "Malformed body expression" + (note source form "unexpected dotted list"))) (if (shorthand-let-p form) @@ -1411,12 +1187,9 @@ Rebound to NIL parsing an anonymous FN.") (values node &optional)) (when (shorthand-let-p form) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Malformed body expression" - :primary-note "body forms cannot be terminated by a shorthand let"))) + (parse-error "Malformed body expression" + (note source form + "body forms cannot be terminated by a shorthand let"))) (parse-expression form source)) @@ -1425,104 +1198,68 @@ Rebound to NIL parsing an anonymous FN.") (values node-let-binding &optional)) (when (cst:atom form) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Malformed let binding" - :primary-note "expected list"))) + (parse-error "Malformed let binding" + (note source form "expected list"))) (unless (cst:proper-list-p form) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Malformed let binding" - :primary-note "unexpected dotted list"))) + (parse-error "Malformed let binding" + (note source form "unexpected dotted list"))) ;; (x) (unless (cst:consp (cst:rest form)) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :highlight :end - :message "Malformed let binding" - :primary-note "let bindings must have a value"))) + (parse-error "Malformed let binding" + (note-end source form + "let bindings must have a value"))) ;; (a b c ...) (when (cst:consp (cst:rest (cst:rest form))) - (error 'parse-error - :err (se:source-error - :span (cst:source (cst:first (cst:rest (cst:rest form)))) - :source source - :message "Malformed let binding" - :primary-note "unexpected trailing form"))) + (parse-error "Malformed let binding" + (note source (cst:first (cst:rest (cst:rest form))) + "unexpected trailing form"))) (make-node-let-binding :name (parse-variable (cst:first form) source) :value (parse-expression (cst:second form) source) - :location (source:make-location source form))) + :location (form-location source form))) (defun parse-match-branch (form source) (declare (type cst:cst form) (values node-match-branch &optional)) (when (cst:atom form) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Malformed match branch" - :primary-note "expected list"))) + (parse-error "Malformed match branch" + (note source form "expected list"))) (unless (cst:proper-list-p form) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Malformed match branch" - :primary-note "unexpected dotted list")) ) + (parse-error "Malformed match branch" + (note source form "unexpected dotted list"))) ;; (P) (unless (cst:consp (cst:rest form)) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :highlight :end - :message "Malformed match branch" - :primary-note "expected body"))) + (parse-error "Malformed match branch" + (note-end source form "expected body"))) (make-node-match-branch :pattern (parse-pattern (cst:first form) source) :body (parse-body (cst:rest form) form source) - :location (source:make-location source form))) + :location (form-location source form))) (defun parse-cond-clause (form source) (declare (type cst:cst form) (values node-cond-clause)) (when (cst:atom form) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Malformed cond clause" - :primary-note "expected list"))) + (parse-error "Malformed cond clause" + (note source form "expected list"))) (unless (cst:proper-list-p form) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Malformed cond clause" - :primary-note "unexpected dotted list"))) + (parse-error "Malformed cond clause" + (note source form "unexpected dotted list"))) (make-node-cond-clause :expr (parse-expression (cst:first form) source) :body (parse-body (cst:rest form) form source) - :location (source:make-location source form))) + :location (form-location source form))) (defun parse-do (form source) (declare (type cst:cst form)) @@ -1530,13 +1267,8 @@ Rebound to NIL parsing an anonymous FN.") (assert (cst:consp form)) (unless (cst:consp (cst:rest form)) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :highlight :end - :message "Malformed do expression" - :primary-note "expected one or more forms"))) + (parse-error "Malformed do expression" + (note-end source form "expected one or more forms"))) (let* (last-node @@ -1554,7 +1286,7 @@ Rebound to NIL parsing an anonymous FN.") (make-node-do :nodes nodes :last-node last-node - :location (source:make-location source form)))) + :location (form-location source form)))) (defun do-bind-p (form) "Returns t if FORM is in the form of (x <- y+)" @@ -1586,17 +1318,14 @@ Rebound to NIL parsing an anonymous FN.") (values node-do-bind)) (when (cst:consp (cst:rest (cst:rest (cst:rest form)))) - (error 'parse-error - :err (se:source-error - :span (cst:source (cst:first (cst:rest (cst:rest (cst:rest form))))) - :source source - :message "Malformed bind form" - :primary-note "unexpected trailing form"))) + (parse-error "Malformed bind form" + (note source (cst:first (cst:rest (cst:rest (cst:rest form)))) + "unexpected trailing form"))) (make-node-do-bind :pattern (parse-pattern (cst:first form) source) :expr (parse-expression (cst:third form) source) - :location (source:make-location source form))) + :location (form-location source form))) (defun parse-do-body-element (form source) (declare (type cst:cst form) @@ -1618,32 +1347,16 @@ Rebound to NIL parsing an anonymous FN.") (values node &optional)) (when (shorthand-let-p form) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Malformed do expression" - :primary-note "do expressions cannot be terminated by a shorthand let" - :notes - (list - (se:make-source-error-note - :type :secondary - :span (cst:source parent-form) - :message "when parsing do expression"))))) + (parse-error "Malformed do expression" + (note source form + "do expressions cannot be terminated by a shorthand let") + (note source parent-form "when parsing do expression"))) (when (do-bind-p form) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Malformed do expression" - :primary-note "do expression cannot be terminated by a bind" - :notes - (list - (se:make-source-error-note - :type :secondary - :span (cst:source parent-form) - :message "when parsing do expression"))))) + (parse-error "Malformed do expression" + (note source form + "do expression cannot be terminated by a bind") + (note source parent-form "when parsing do expression"))) (parse-expression form source)) @@ -1659,27 +1372,23 @@ Rebound to NIL parsing an anonymous FN.") (assert (eq (cst:raw (cst:first form)) 'coalton:declare)) (when (cst:consp (cst:rest (cst:rest (cst:rest form)))) - (error 'parse-error - :err (se:source-error - :span (cst:source (cst:fourth form)) - :source source - :message "Malformed declare" - :primary-note "unexpected form"))) + (parse-error "Malformed declare" + (note source (cst:fourth form) "unexpected form"))) (make-node-let-declare :name (parse-variable (cst:second form) source) :type (parse-qualified-type (cst:third form) source) - :location (source:make-location source form))) + :location (form-location source form))) (defun take-label (form) "Takes form (HEAD . (MAYBEKEYWORD . REST)) and returns two values, either -MAYBEKEYWORD REST +MAYBEKEYWORD REST if MAYBEKEYWORD is a keyword, or else -NIL (MAYBEKEYWORD . REST) +NIL (MAYBEKEYWORD . REST) if (CST:SECOND FORM) is not a keyword." (declare (type cst:cst form) diff --git a/src/parser/macro.lisp b/src/parser/macro.lisp index e5861728..80db109e 100644 --- a/src/parser/macro.lisp +++ b/src/parser/macro.lisp @@ -31,12 +31,8 @@ fallback-source (make-hash-table :test #'eq)) (error (condition) - (error 'parse-error - :err (source-error:source-error - :span (cst:source form) - :source source - :message "Error during macro expansion" - :primary-note (princ-to-string condition))))))) + (parse-error "Error during macro expansion" + (note source form (princ-to-string condition))))))) (defun fill-source-table (cst source-table seen-forms) "Fill SOURCE-TABLE with source information in CST and its children." diff --git a/src/parser/pattern.lisp b/src/parser/pattern.lisp index 647691bf..f5f6fee6 100644 --- a/src/parser/pattern.lisp +++ b/src/parser/pattern.lisp @@ -98,51 +98,35 @@ (typep (cst:raw form) 'util:literal-value)) (make-pattern-literal :value (cst:raw form) - :location (source:make-location source form))) + :location (form-location source form))) ((and (cst:atom form) (eq (cst:raw form) 'coalton:_)) (make-pattern-wildcard - :location (source:make-location source form))) + :location (form-location source form))) ((and (cst:atom form) (identifierp (cst:raw form))) (when (string= "_" (symbol-name (cst:raw form))) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Invalid pattern" - :primary-note "invalid variable name '_'"))) + (parse-error "Invalid pattern" + (note source form "invalid variable name '_'"))) (make-pattern-var :name (cst:raw form) :orig-name (cst:raw form) - :location (source:make-location source form))) + :location (form-location source form))) ((cst:atom form) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Invalid pattern" - :primary-note "unknown pattern literal"))) + (parse-error "Invalid pattern" + (note source form "unknown pattern literal"))) ((not (cst:proper-list-p form)) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Invalid pattern" - :primary-note "unexpected dotted list"))) + (parse-error "Invalid pattern" + (note source form "unexpected dotted list"))) ((not (and (cst:atom (cst:first form)) (identifierp (cst:raw (cst:first form))))) - (error 'parse-error - :err (se:source-error - :span (cst:source (cst:first form)) - :source source - :message "Invalid pattern" - :primary-note "invalid constructor in pattern"))) + (parse-error "Invalid pattern" + (note source (cst:first form) "invalid constructor in pattern"))) (t (make-pattern-constructor @@ -150,7 +134,7 @@ :patterns (loop :for patterns := (cst:rest form) :then (cst:rest patterns) :while (cst:consp patterns) :collect (parse-pattern (cst:first patterns) source)) - :location (source:make-location source form))))) + :location (form-location source form))))) (defun pattern-variables (pattern) (declare (type t pattern) diff --git a/src/parser/reader.lisp b/src/parser/reader.lisp index d93f6df6..d26ae4ee 100644 --- a/src/parser/reader.lisp +++ b/src/parser/reader.lisp @@ -1,7 +1,8 @@ (defpackage #:coalton-impl/parser/reader (:use #:cl) (:local-nicknames - (#:cst #:concrete-syntax-tree)) + (#:cst #:concrete-syntax-tree) + (#:source #:coalton-impl/source)) (:shadowing-import-from #:coalton-impl/parser/base #:parse-error) @@ -77,17 +78,11 @@ Returns (VALUES FORM PRESENTP EOFP)" nil 'eof))) (eclector.reader:unterminated-list () (let ((end (file-position stream))) - (error 'parse-error - :err (source-error:source-error - :span (cons begin end) - :source source - :message "Unterminated form" - :primary-note (format nil "Missing close parenthesis for form starting at offset ~a" begin))))) + (parse-error "Unterminated form" + (source:note (source:make-location source (cons begin end)) + "Missing close parenthesis for form starting at offset ~a" begin)))) (error (condition) (let ((end (file-position stream))) - (error 'parse-error - :err (source-error:source-error - :span (cons begin end) - :source source - :message "Reader error" - :primary-note (format nil "reader error: ~a" condition)))))))) + (parse-error "Reader error" + (source:note (source:make-location source (cons begin end)) + "reader error: ~a" condition))))))) diff --git a/src/parser/toplevel.lisp b/src/parser/toplevel.lisp index 158ebd02..642695ff 100644 --- a/src/parser/toplevel.lisp +++ b/src/parser/toplevel.lisp @@ -13,6 +13,7 @@ (:local-nicknames (#:cst #:concrete-syntax-tree) (#:cursor #:coalton-impl/parser/cursor) + (#:source #:coalton-impl/source) (#:se #:source-error) (#:source #:coalton-impl/source) (#:util #:coalton-impl/util)) @@ -452,7 +453,7 @@ (:include toplevel-definition) (:copier nil)) "A Coalton package definition, which can be used to generate either a DEFPACKAGE form or a package instance directly." - (name (util:required 'name) :type string :read-only t) + (name (util:required 'name) :type string :read-only t) (import nil :type list) (import-as nil :type list) (import-from nil :type list) @@ -498,13 +499,10 @@ If MODE is :macro, a package form is forbidden, and an explicit check is made fo (maybe-read-form stream source *coalton-eclector-client*) (when (and eofp (eq mode ':macro)) - (error 'parse-error - :err (se:source-error - :span (cons (- (file-position stream) 2) - (- (file-position stream) 1)) - :source source ; TODO :source - :message "Unexpected EOF" - :primary-note "missing close parenthesis"))) + (parse-error "Unexpected EOF" + (source:note (source:make-location source (cons (- (file-position stream) 2) + (- (file-position stream) 1))) + "missing close parenthesis"))) (unless presentp (return)) @@ -514,12 +512,9 @@ If MODE is :macro, a package form is forbidden, and an explicit check is made fo (util:coalton-bug "parse-toplevel-form indicated that a form was parsed but did not consume all attributes")))) (unless (zerop (length attributes)) - (error 'parse-error - :err (se:source-error - :span (cst:source (cdr (aref attributes 0))) - :source source - :message "Orphan attribute" - :primary-note "attribute must be attached to another form"))) + (parse-error "Orphan attribute" + (note source (cdr (aref attributes 0)) + "attribute must be attached to another form"))) (setf (program-types program) (nreverse (program-types program))) (setf (program-structs program) (nreverse (program-structs program))) @@ -542,25 +537,18 @@ If MODE is :macro, a package form is forbidden, and an explicit check is made fo (maybe-read-form stream source *coalton-eclector-client*) (unless presentp - (error 'parse-error - :err (se:source-error - :span (cons (- (file-position stream) 2) - (- (file-position stream) 1)) - :source source - :message "Malformed coalton expression" - :primary-note "missing expression"))) + (parse-error "Malformed coalton expression" + (source:note (source:make-location source (cons (- (file-position stream) 2) + (- (file-position stream) 1))) + "missing expression"))) ;; Ensure there is only one form (multiple-value-bind (form presentp) (maybe-read-form stream source *coalton-eclector-client*) (when presentp - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Malformed coalton expression" - :primary-note "unexpected form")))) + (parse-error "Malformed coalton expression" + (note source form "unexpected form")))) (parse-expression form source)))) @@ -646,8 +634,8 @@ If MODE is :macro, a package form is forbidden, and an explicit check is made fo (package (make-toplevel-package :name (symbol-name package-name) :docstring package-doc - :location (source:make-location (cursor:cursor-source cursor) - (cursor:cursor-value cursor))))) + :location (form-location (cursor:cursor-source cursor) + (cursor:cursor-value cursor))))) (cursor:do-every cursor (alexandria:curry 'parse-package-clause package)) package)) @@ -700,12 +688,10 @@ If MODE is :macro, a package form is forbidden, and an explicit check is made fo "Create a Lisp package by evaluating the defpackage representation of a PACKAGE form." (handler-case (eval (make-defpackage package)) - (package-error () - (error 'parse-error - :err (se:source-error :span (source:location-span (toplevel-package-location package)) - :source (source:location-source (toplevel-package-location package)) - :message "Malformed package declaration" - :primary-note "unable to evaluate package definition"))))) + (error () + (parse-error "Malformed package declaration" + (source:note package + "unable to evaluate package definition"))))) (defun program-lisp-package (program) "Return the Lisp package associated with PROGRAM, or current *PACKAGE* if none was specified." @@ -739,23 +725,23 @@ If the outermost form matches (eval-when (compile-toplevel) ..), evaluate the en (unless (null options) (cond ((maybe-def-p (car options)) (parse-error "Invalid lisp-toplevel form" - (source-note source (cst:first (cst:rest form)) - "saw 'def' form: in lisp-toplevel, code must be preceded by an empty options list") - (source-note source form - "when parsing lisp-toplevel"))) + (note source (cst:first (cst:rest form)) + "saw 'def' form: in lisp-toplevel, code must be preceded by an empty options list") + (note source form + "when parsing lisp-toplevel"))) (t (parse-error "Invalid lisp-toplevel form" - (source-note source (cst:first (cst:rest form)) - "lisp-toplevel must be followed by an empty options list") - (source-note source form - "when parsing lisp-toplevel")))))) + (note source (cst:first (cst:rest form)) + "lisp-toplevel must be followed by an empty options list") + (note source form + "when parsing lisp-toplevel")))))) (loop :for form :in (cst:raw (cst:rest (cst:rest form))) :when (eval-toplevel-p form) :do (dolist (form (cddr form)) (eval form))) (push (make-toplevel-lisp-form :body (cddr (cst:raw form)) - :location (source:make-location source form)) + :location (form-location source form)) (program-lisp-forms program))) (defun parse-toplevel-form (form program attributes source) @@ -765,21 +751,13 @@ If the outermost form matches (eval-when (compile-toplevel) ..), evaluate the en (values boolean &optional)) (when (cst:atom form) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Malformed toplevel form" - :primary-note "Unexpected atom"))) + (parse-error "Malformed toplevel form" + (note source form "Unexpected atom"))) ;; Toplevel forms must begin with an atom (when (cst:consp (cst:first form)) - (error 'parse-error - :err (se:source-error - :span (cst:source (cst:first form)) - :source source - :message "Malformed toplevel form" - :primary-note "unexpected list"))) + (parse-error "Malformed toplevel form" + (note source (cst:first form) "unexpected list"))) (case (cst:raw (cst:first form)) ((coalton:monomorphize) @@ -805,37 +783,21 @@ If the outermost form matches (eval-when (compile-toplevel) ..), evaluate the en (loop :for (attribute . attribute-form) :across attributes :do (etypecase attribute (attribute-repr - (error 'parse-error - :err (se:source-error - :span (cst:source attribute-form) - :source source - :message "Invalid target for repr attribute" - :primary-note "repr must be attached to a define-type" - :notes - (list - (se:make-source-error-note - :type ':secondary - :span (source:location-span (source:location (toplevel-define-name define))) - :message "when parsing define"))))) + (parse-error "Invalid target for repr attribute" + (note source attribute-form + "repr must be attached to a define-type") + (source:note (toplevel-define-name define) + "when parsing define"))) (attribute-monomorphize (when monomorphize - (error 'parse-error - :err (se:source-error - :span (cst:source attribute-form) - :source source - :message "Duplicate monomorphize attribute" - :primary-note "monomorphize attribute here" - :notes - (list - (se:make-source-error-note - :type ':secondary - :span (cst:source monomorphize-form) - :message "previous attribute here") - (se:make-source-error-note - :type ':secondary - :span (source:location-span (source:location (toplevel-define-name define))) - :message "when parsing define"))))) + (parse-error "Duplicate monomorphize attribute" + (note source attribute-form + "monomorphize attribute here") + (note source monomorphize-form + "previous attribute here") + (source:note (toplevel-define-name define) + "when parsing define"))) (setf monomorphize attribute) (setf monomorphize-form attribute-form)))) @@ -854,37 +816,19 @@ If the outermost form matches (eval-when (compile-toplevel) ..), evaluate the en (loop :for (attribute . attribute-form) :across attributes :do (etypecase attribute (attribute-repr - (error 'parse-error - :err (se:source-error - :span (cst:source attribute-form) - :source source - :message "Invalid target for repr attribute" - :primary-note "repr must be attached to a define-type" - :notes - (list - (se:make-source-error-note - :type ':secondary - :span (cst:source form) - :message "when parsing declare"))))) + (parse-error "Invalid target for repr attribute" + (note source attribute-form + "repr must be attached to a define-type") + (note source form "when parsing declare"))) (attribute-monomorphize (when monomorphize - (error 'parse-error - :err (se:source-error - :span (cst:source attribute-form) - :source source - :message "Duplicate monomorphize attribute" - :primary-note "monomorphize attribute here" - :notes - (list - (se:make-source-error-note - :type ':secondary - :span (cst:source monomorphize-form) - :message "previous attribute here") - (se:make-source-error-note - :type ':secondary - :span (cst:source form) - :message "when parsing declare"))))) + (parse-error "Duplicate monomorphize attribute" + (note source attribute-form + "monomorphize attribute here") + (note source monomorphize-form + "previous attribute here") + (note source form "when parsing declare"))) (setf monomorphize attribute) (setf monomorphize-form attribute-form)))) @@ -904,39 +848,21 @@ If the outermost form matches (eval-when (compile-toplevel) ..), evaluate the en :do (etypecase attribute (attribute-repr (when repr - (error 'parse-error - :err (se:source-error - :span (cst:source attribute-form) - :source source - :message "Duplicate repr atttribute" - :primary-note "repr attribute here" - :notes - (list - (se:make-source-error-note - :type ':secondary - :span (cst:source repr-form) - :message "previous attribute here") - (se:make-source-error-note - :type ':secondary - :span (source:location-span (source:location type)) - :message "when parsing define-type"))))) + (parse-error "Duplicate repr atttribute" + (note source attribute-form + "repr attribute here") + (note source repr-form + "previous attribute here") + (source:note type "when parsing define-type"))) (setf repr attribute) (setf repr-form attribute-form)) (attribute-monomorphize - (error 'parse-error - :err (se:source-error - :span (cst:source attribute-form) - :source source - :message "Invalid target for monomorphize attribute" - :primary-note "monomorphize must be attached to a define or declare form" - :notes - (list - (se:make-source-error-note - :type ':secondary - :span (source:location-span (source:location type)) - :message "when parsing define-type"))))))) + (parse-error "Invalid target for monomorphize attribute" + (note source attribute-form + "monomorphize must be attached to a define or declare form") + (source:note type "when parsing define-type"))))) (setf (fill-pointer attributes) 0) (setf (toplevel-define-type-repr type) repr) @@ -953,53 +879,28 @@ If the outermost form matches (eval-when (compile-toplevel) ..), evaluate the en :do (etypecase attribute (attribute-repr (when repr - (error 'parse-error - :err (se:source-error - :span (cst:source attribute-form) - :source source - :message "Duplicate repr attribute" - :primary-note "repr attribute here" - :notes - (list - (se:make-source-error-note - :type ':secondary - :span (cst:source repr-form) - :message "previous attribute here") - (se:make-source-error-note - :type ':secondary - :span (source:location-span (toplevel-define-struct-head-location struct) ) - :message "when parsing define-struct"))))) + (parse-error "Duplicate repr attribute" + (note source attribute-form "repr attribute here") + (note source repr-form "previous attribute here") + (note source (toplevel-define-struct-head-location struct) + "when parsing define-struct"))) (unless (eq :transparent (keyword-src-name (attribute-repr-type attribute))) - (error 'parse-error - :err (se:source-error - :span (cst:source attribute-form) - :source source - :message "Invalid repr attribute" - :primary-note "structs can only be repr transparent" - :notes - (list - (se:make-source-error-note - :type ':secondary - :span (source:location-span (toplevel-define-struct-head-location struct)) - :message "when parsing define-struct"))))) + (parse-error "Invalid repr attribute" + (note source attribute-form + "structs can only be repr transparent") + (note source (toplevel-define-struct-head-location struct) + "when parsing define-struct"))) (setf repr attribute) (setf repr-form attribute-form)) (attribute-monomorphize - (error 'parse-error - :err (se:source-error - :span (cst:source attribute-form) - :source source - :message "Invalid target for monomorphize attribute" - :primary-note "monomorphize must be attached to a define or declare form" - :notes - (list - (se:make-source-error-note - :type ':secondary - :span (source:location-span (source:location (toplevel-define-struct-name struct))) - :message "when parsing define-type"))))))) + (parse-error "Invalid target for monomorphize attribute" + (note source attribute-form + "monomorphize must be attached to a define or declare form") + (note source (toplevel-define-struct-name struct) + "when parsing define-type"))))) (setf (fill-pointer attributes) 0) (setf (toplevel-define-struct-repr struct) repr) @@ -1010,18 +911,11 @@ If the outermost form matches (eval-when (compile-toplevel) ..), evaluate the en (let ((class (parse-define-class form source))) (unless (zerop (length attributes)) - (error 'parse-error - :err (se:source-error - :span (cst:source (cdr (aref attributes 0))) - :source source - :message "Invalid attribute for define-class" - :primary-note "define-class cannot have attributes" - :notes - (list - (se:make-source-error-note - :type ':secondary - :span (source:location-span (toplevel-define-class-head-location class)) - :message "while parsing define-class"))))) + (parse-error "Invalid attribute for define-class" + (note source (cdr (aref attributes 0)) + "define-class cannot have attributes") + (source:note (toplevel-define-class-head-location class) + "while parsing define-class"))) (push class (program-classes program)) t)) @@ -1030,19 +924,11 @@ If the outermost form matches (eval-when (compile-toplevel) ..), evaluate the en (let ((instance (parse-define-instance form source))) (unless (zerop (length attributes)) - (error 'parse-error - :err (se:source-error - :span (cst:source (cdr (aref attributes 0))) - :source source - :message "Invalid attribute for define-instance" - :primary-note "define-instance cannot have attributes" - :notes - (list - (se:make-source-error-note - :type ':secondary - :span (source:location-span (toplevel-define-instance-head-location instance)) - :message "while parsing define-instance"))))) - + (parse-error "Invalid attribute for define-instance" + (note source (cdr (aref attributes 0)) + "define-instance cannot have attributes") + (source:note (toplevel-define-instance-head-location instance) + "while parsing define-instance"))) (push instance (program-instances program)) t)) @@ -1050,14 +936,14 @@ If the outermost form matches (eval-when (compile-toplevel) ..), evaluate the en ((coalton:lisp-toplevel) (unless (alexandria:featurep ':coalton-lisp-toplevel) (parse-error "Invalid lisp-toplevel form" - (source-note source form - "lisp-toplevel is only allowed in library source code. To enable elsewhere, (pushnew :coalton-lisp-toplevel *features*)"))) + (note source form + "lisp-toplevel is only allowed in library source code. To enable elsewhere, (pushnew :coalton-lisp-toplevel *features*)"))) (unless (zerop (length attributes)) (parse-error "Invalid lisp-toplevel form" - (source-note source (cdr (aref attributes 0)) - "lisp-toplevel cannot have attributes") - (source-note source form - "when parsing lisp-toplevel"))) + (note source (cdr (aref attributes 0)) + "lisp-toplevel cannot have attributes") + (note source form + "when parsing lisp-toplevel"))) (parse-lisp-toplevel-form form program source) t) @@ -1065,36 +951,20 @@ If the outermost form matches (eval-when (compile-toplevel) ..), evaluate the en (let ((spec (parse-specialize form source))) (unless (zerop (length attributes)) - (error 'parse-error - :err (se:source-error - :span (cst:source (cdr (aref attributes 0))) - :source source - :message "Invalid attribute for specialize" - :primary-note "specialize cannot have attributes" - :notes - (list - (se:make-source-error-note - :type ':secondary - :span (cst:source form) - :message "when parsing specialize"))))) + (source:error "Invalid attribute for specialize" + (note source (cdr (aref attributes 0)) "specialize cannot have attributes") + (note source form "when parsing specialize"))) (push spec (program-specializations program)) t)) ((coalton:progn) (unless (zerop (length attributes)) - (error 'parse-error - :err (se:source-error - :span (cst:source (cdr (aref attributes 0))) - :source source - :message "Invalid attribute for progn" - :primary-note "progn cannot have attributes" - :notes - (list - (se:make-source-error-note - :type ':secondary - :span (cst:source form) - :message "when parsing progn"))))) + (parse-error "Invalid attribute for progn" + (note source (cdr (aref attributes 0)) + "progn cannot have attributes") + (note source form + "when parsing progn"))) (loop :for inner-form := (cst:rest form) :then (cst:rest inner-form) :while (not (cst:null inner-form)) :do @@ -1104,18 +974,11 @@ If the outermost form matches (eval-when (compile-toplevel) ..), evaluate the en consume all attributes"))) (unless (zerop (length attributes)) - (error 'parse-error - :err (se:source-error - :span (cst:source (cdr (aref attributes 0))) - :source source - :message "Trailing attributes in progn" - :primary-note "progn cannot have trailing attributes" - :notes - (list - (se:make-source-error-note - :type ':secondary - :span (cst:source form) - :message "when parsing progn"))))) + (parse-error "Trailing attributes in progn" + (note source (cdr (aref attributes 0)) + "progn cannot have trailing attributes") + (note source form + "when parsing progn"))) t) (t @@ -1130,12 +993,8 @@ consume all attributes"))) :test #'equalp))) (parse-toplevel-form (expand-macro form source) program attributes source))) - ((error 'parse-error - :err (se:source-error - :span (cst:source (cst:first form)) - :source source - :message "Invalid toplevel form" - :primary-note "unknown toplevel form"))))))) + ((parse-error "Invalid toplevel form" + (note source (cst:first form) "unknown toplevel form"))))))) (defun parse-define (form source) @@ -1146,21 +1005,13 @@ consume all attributes"))) ;; (define) (unless (cst:consp (cst:rest form)) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Malformed definition" - :primary-note "expected define body"))) + (parse-error "Malformed definition" + (note source form "expected define body"))) ;; (define x) (unless (cst:consp (cst:rest (cst:rest form))) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Malformed definition" - :primary-note "expected value"))) + (parse-error "Malformed definition" + (note source form "expected value"))) (multiple-value-bind (name params) (parse-argument-list (cst:second form) source) @@ -1175,7 +1026,7 @@ consume all attributes"))) :docstring docstring :body body :monomorphize nil - :location (source:make-location source form))))) + :location (form-location source form))))) (defun parse-declare (form source) (declare (type cst:cst form) @@ -1185,47 +1036,33 @@ consume all attributes"))) ;; (declare) (unless (cst:consp (cst:rest form)) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Malformed declaration" - :primary-note "expected body"))) + (parse-error "Malformed declaration" + (note source form "expected body"))) ;; (declare x) (unless (cst:consp (cst:rest (cst:rest form))) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Malformed declaration" - :primary-note "expected declared type"))) + (parse-error "Malformed declaration" + (note source form "expected declared type"))) ;; (declare x y z) (when (cst:consp (cst:rest (cst:rest (cst:rest form)))) - (error 'parse-error - :err (se:source-error - :span (cst:source (cst:first (cst:rest (cst:rest (cst:rest form))))) - :source source - :message "Malformed declaration" - :primary-note "unexpected trailing form"))) + (parse-error "Malformed declaration" + (note source (cst:first (cst:rest (cst:rest (cst:rest form)))) + "unexpected trailing form"))) ;; (declare 0.5 x) (unless (identifierp (cst:raw (cst:second form))) - (error 'parse-error - :err (se:source-error - :span (cst:source (cst:second form)) - :source source - :message "Malformed declaration" - :primary-note "expected symbol"))) + (parse-error "Malformed declaration" + (note source (cst:second form) + "expected symbol"))) (make-toplevel-declare :name (make-identifier-src :name (cst:raw (cst:second form)) - :location (source:make-location source (cst:second form))) + :location (form-location source (cst:second form))) :type (parse-qualified-type (cst:third form) source) :monomorphize nil - :location (source:make-location source form))) + :location (form-location source form))) (defun parse-define-type (form source) (declare (type cst:cst form) @@ -1241,72 +1078,47 @@ consume all attributes"))) ;; (define-type) (unless (cst:consp (cst:rest form)) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Malformed type definition" - :primary-note "expected body"))) + (parse-error "Malformed type definition" + (note source form "expected body"))) (cond ((cst:atom (cst:second form)) (unless (identifierp (cst:raw (cst:second form))) - (error 'parse-error - :err (se:source-error - :span (cst:source (cst:second form)) - :source source - :message "Malformed type definition" - :primary-note "expected symbol"))) + (parse-error "Malformed type definition" + (note source (cst:second form) "expected symbol"))) (setf name (make-identifier-src :name (cst:raw (cst:second form)) - :location (source:make-location source form)))) + :location (form-location source form)))) (t ; (define-type (T ...) ...) ;; (define-type ((T) ...) ...) (unless (cst:atom (cst:first (cst:second form))) - (error 'parse-error - :err (se:source-error - :span (cst:source (cst:first (cst:second form))) - :source source - :message "Malformed type definition" - :primary-note "expected symbol" - :help-notes - (list - (se:make-source-error-help - :span (cst:source (cst:second form)) - :replacement - (lambda (existing) - (subseq existing 1 (1- (length existing)))) - :message "remove parentheses"))))) + (parse-error "Malformed type definition" + (note source (cst:first (cst:second form)) + "expected symbol") + (help source (cst:second form) + (lambda (existing) + (subseq existing 1 (1- (length existing)))) + "remove parentheses"))) ;; (define-type (1 ...) ...) (unless (identifierp (cst:raw (cst:first (cst:second form)))) - (error 'parse-error - :err (se:source-error - :span (cst:source (cst:first (cst:second form))) - :source source - :message "Malformed type definition" - :primary-note "expected symbol"))) + (parse-error "Malformed type definition" + (note source (cst:first (cst:second form)) + "expected symbol"))) (setf name (make-identifier-src :name (cst:raw (cst:first (cst:second form))) - :location (source:make-location source (cst:first (cst:second form))))) + :location (form-location source (cst:first (cst:second form))))) ;; (define-type (T) ...) (when (cst:atom (cst:rest (cst:second form))) - (error 'parse-error - :err (se:source-error - :span (cst:source (cst:second form)) - :source source - :message "Malformed type definition" - :primary-note "nullary types should not have parentheses" - :help-notes - (list - (se:make-source-error-help - :span (cst:source (cst:second form)) - :replacement - (lambda (existing) - (subseq existing 1 (1- (length existing)))) - :message "remove unnecessary parentheses"))))) + (parse-error "Malformed type definition" + (note source (cst:second form) + "nullary types should not have parentheses") + (help source (cst:second form) + (lambda (existing) + (subseq existing 1 (1- (length existing)))) + "remove unnecessary parentheses"))) (loop :for vars := (cst:rest (cst:second form)) :then (cst:rest vars) :while (cst:consp vars) @@ -1325,8 +1137,8 @@ consume all attributes"))) :while (cst:consp constructors_) :collect (parse-constructor (cst:first constructors_) form source)) :repr nil - :location (source:make-location source form) - :head-location (source:make-location source (cst:second form))))) + :location (form-location source form) + :head-location (form-location source (cst:second form))))) (defun parse-define-struct (form source) (declare (type cst:cst form)) @@ -1339,13 +1151,8 @@ consume all attributes"))) ;; (define-struct) (unless (cst:consp (cst:rest form)) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Malformed struct definition" - :primary-note "expected body" - :highlight :end))) + (parse-error "Malformed struct definition" + (note source form "expected body"))) (if (cst:atom (cst:second form)) ;; (define-struct S ...) @@ -1365,15 +1172,15 @@ consume all attributes"))) (make-toplevel-define-struct :name (parse-identifier unparsed-name source) :vars (when unparsed-variables - (parse-list #'parse-type-variable unparsed-variables source)) + (parse-list #'parse-type-variable unparsed-variables source)) :docstring docstring :fields (parse-list #'parse-struct-field (cst:nthrest (if docstring 3 2) form) source) - :location (source:make-location source form) + :location (form-location source form) :repr nil - :head-location (source:make-location source (cst:second form))))) + :head-location (form-location source (cst:second form))))) (defun parse-define-class (form source) (declare (type cst:cst form) @@ -1392,37 +1199,22 @@ consume all attributes"))) ;; (define-class) (unless (cst:consp (cst:rest form)) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Malformed class definition" - :primary-note "expected body"))) + (parse-error "Malformed class definition" + (note source form "expected body"))) ;; (define-class C) (unless (cst:consp (cst:second form)) - (error 'parse-error - :err (se:source-error - :span (cst:source (cst:second form)) - :source source - :message "Malformed class definition" - :primary-note "expected class type variable(s)" - :help-notes - (list - (se:make-source-error-help - :span (cst:source (cst:second form)) - :replacement - (lambda (existing) - (concatenate 'string "(" existing " :a)")) - :message "add class type variable `:a`"))))) + (parse-error "Malformed class definition" + (note source (cst:second form) + "expected class type variable(s)") + (help source (cst:second form) + (lambda (existing) + (concatenate 'string "(" existing " :a)")) + "add class type variable `:a`"))) (unless (cst:proper-list-p (cst:second form)) - (error 'parse-error - :err (se:source-error - :span (cst:source (cst:second form)) - :source source - :message "Malformed class definition" - :primary-note "unexpected dotted list"))) + (parse-error "Malformed class definition" + (note source (cst:second form) "unexpected dotted list"))) (multiple-value-bind (left right) (util:take-until (lambda (cst) @@ -1432,45 +1224,31 @@ consume all attributes"))) ;; (=> C ...) (when (and (null left) right) - (error 'parse-error - :err (se:source-error - :span (cst:source (cst:first (cst:second form))) - :source source - :message "Malformed class definition" - :primary-note "unnecessary `=>`" - :help-notes + (apply #'parse-error "Malformed class definition" + (cons (note source (cst:first (cst:second form)) + "unnecessary `=>`") (cond ;; If this is the only thing in the list then don't suggest anything ((cst:atom (cst:rest (cst:second form))) nil) ;; If there is nothing to the right of C then emit without list ((cst:atom (cst:rest (cst:rest (cst:second form)))) - (list - (se:make-source-error-help - :span (cst:source (cst:second form)) - :replacement - (lambda (existing) - (subseq existing 4 (1- (length existing)))) - :message "remove `=>`"))) + (list (help source (cst:second form) + (lambda (existing) + (subseq existing 4 (1- (length existing)))) + "remove `=>`"))) (t - (list - (se:make-source-error-help - :span (cst:source (cst:second form)) - :replacement - (lambda (existing) - (concatenate 'string - (subseq existing 0 1) - (subseq existing 4))) - :message "remove `=>`"))))))) + (list (help source (cst:second form) + (lambda (existing) + (concatenate 'string + (subseq existing 0 1) + (subseq existing 4))) + "remove `=>`"))))))) ;; (... =>) (when (and left right (null (cdr right))) - (error 'parse-error - :err (se:source-error - :span (cst:source (cst:second form)) - :source source - :message "Malformed class definition" - :primary-note "missing class name"))) + (parse-error "Malformed class definition" + (note source (cst:second form) "missing class name"))) (cond ;; No predicates @@ -1481,12 +1259,8 @@ consume all attributes"))) ;; (... => (...) ...) ((and (cst:consp (second right)) (consp (cdr (cdr right)))) - (error 'parse-error - :err (se:source-error - :span (cst:source (third right)) - :source source - :message "Malformed class definition" - :primary-note "unexpected form"))) + (parse-error "Malformed class definition" + (note source (third right) "unexpected form"))) ;; (... => (...)) ((cst:consp (second right)) @@ -1501,48 +1275,29 @@ consume all attributes"))) ;; (define-class ((C) ...)) (unless (cst:atom unparsed-name) - (error 'parse-error - :err (se:source-error - :span (cst:source unparsed-name) - :source source - :message "Malformed class definition" - :primary-note "unnecessary parentheses" - :help-notes - (list - (se:make-source-error-help - :span (cst:source unparsed-name) - :replacement - (lambda (existing) - (subseq existing 1 (1- (length existing)))) - :message "remove unnecessary parentheses"))))) + (parse-error "Malformed class definition" + (note source unparsed-name "unnecessary parentheses") + (help source unparsed-name + (lambda (existing) + (subseq existing 1 (1- (length existing)))) + "remove unnecessary parentheses"))) (unless (identifierp (cst:raw unparsed-name)) - (error 'parse-error - :err (se:source-error - :span (cst:source unparsed-name) - :source source - :message "Malformed class definition" - :primary-note "expected symbol"))) + (parse-error "Malformed class definition" + (note source unparsed-name "expected symbol"))) (setf name (cst:raw unparsed-name)) (when (null unparsed-variables) - (error 'parse-error - :err (se:source-error - :span (cst:source unparsed-name) - :source source - :message "Malformed class definition" - :primary-note "expected class type variable(s)" - :help-notes - (list - (se:make-source-error-help - :span (cst:source unparsed-name) - :replacement - (lambda (existing) - (if (cst:consp (cst:second form)) - (concatenate 'string existing " :a") - (concatenate 'string "(" existing " :a)"))) - :message "add class type variable `:a`"))))) + (parse-error "Malformed class definition" + (note source unparsed-name + "expected class type variable(s)") + (help source unparsed-name + (lambda (existing) + (if (cst:consp (cst:second form)) + (concatenate 'string existing " :a") + (concatenate 'string "(" existing " :a)"))) + "add class type variable `:a`"))) (multiple-value-bind (left right) @@ -1560,14 +1315,15 @@ consume all attributes"))) (when right (if (cst:atom (first left)) ;; (C1 ... => C2 ...) - (setf predicates (list (parse-predicate left - (source:make-location source - (util:cst-source-range left))))) + (setf predicates + (list (parse-predicate left + (source:make-location source + (util:cst-source-range left))))) ;; ((C1 ...) (C2 ...) ... => C3 ...) (setf predicates (loop :for pred :in left - :collect (parse-predicate (cst:listify pred) (source:make-location source pred)))))) + :collect (parse-predicate (cst:listify pred) (form-location source pred)))))) (when (and (cst:consp (cst:rest (cst:rest form))) (cst:atom (cst:third form)) @@ -1582,14 +1338,14 @@ consume all attributes"))) (make-toplevel-define-class :name (make-identifier-src :name name - :location (source:make-location source unparsed-name)) + :location (form-location source unparsed-name)) :vars variables :preds predicates :fundeps fundeps :docstring docstring :methods methods - :location (source:make-location source form) - :head-location (source:make-location source (cst:second form)))))) + :location (form-location source form) + :head-location (form-location source (cst:second form)))))) (defun parse-define-instance (form source) (declare (type cst:cst form) @@ -1604,30 +1360,17 @@ consume all attributes"))) ;; (define-instance) (unless (cst:consp (cst:rest form)) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :highlight :end - :message "Malformed instance definition" - :primary-note "expected an instance head"))) + (parse-error "Malformed instance definition" + (note-end source form "expected an instance head"))) ;; (define-instance 5) (unless (cst:consp (cst:second form)) - (error 'parse-error - :err (se:source-error - :span (cst:source (cst:second form)) - :source source - :message "Malformed instance definition" - :primary-note "expected a list"))) + (parse-error "Malformed instance definition" + (note source (cst:second form) "expected a list"))) (unless (cst:proper-list-p (cst:second form)) - (error 'parse-error - :err (se:source-error - :span (cst:source (cst:second form)) - :source source - :message "Malformed instance definition" - :primary-note "unexpected dotted list"))) + (parse-error "Malformed instance definition" + (note source (cst:second form) "unexpected dotted list"))) (multiple-value-bind (left right) (util:take-until @@ -1645,12 +1388,8 @@ consume all attributes"))) ((and (second right) (cst:consp (second right)) (consp (cdr (cdr right)))) - (error 'parse-error - :err (se:source-error - :span (cst:source (third right)) - :source source - :message "Malformed instance definition" - :primary-note "unexpected form"))) + (parse-error "Malformed instance definition" + (note source (third right) "unexpected form"))) ;; (.... => (...)) ((and (second right) @@ -1665,50 +1404,36 @@ consume all attributes"))) ;; (... =>) (when (and left right (null (cdr right))) - (error 'parse-error - :err (se:source-error - :span (cst:source (first right)) - :source source - :message "Malformed instance head" - :primary-note "unexpected `=>`" - :help-notes - (list - (se:make-source-error-help - :span (cst:source (first right)) - :replacement - (lambda (existing) - (declare (ignore existing)) - "") - :message "remove the `=>`"))))) + (parse-error "Malformed instance head" + (note source (first right) + "unexpected `=>`") + (help source (first right) + (lambda (existing) + (declare (ignore existing)) + "") + "remove the `=>`"))) ;; (=> ...) (when (and (null left) right) - (error 'parse-error - :err (se:source-error - :span (cst:source (first right)) - :source source - :message "Malformed instance head" - :primary-note "unexpected `=>`" - :help-notes - (list - (se:make-source-error-help - :span (cst:source (first right)) - :replacement - (lambda (existing) - (declare (ignore existing)) - "") - :message "remove the `=>`"))))) + (parse-error "Malformed instance head" + (note source (first right) + "unexpected `=>`") + (help source (first right) + (lambda (existing) + (declare (ignore existing)) + "") + "remove the `=>`"))) (when unparsed-context (if (cst:atom (first unparsed-context)) (setf context (list (parse-predicate unparsed-context (source:make-location source - (util:cst-source-range unparsed-context))))) + (util:cst-source-range unparsed-context))))) (setf context (loop :for unparsed :in unparsed-context - :collect (parse-predicate (cst:listify unparsed) (source:make-location source unparsed)))))) + :collect (parse-predicate (cst:listify unparsed) (form-location source unparsed)))))) (when (and (cst:consp (cst:rest (cst:rest form))) (cst:atom (cst:third form)) @@ -1719,14 +1444,14 @@ consume all attributes"))) :context context :pred (parse-predicate unparsed-predicate (source:make-location source - (util:cst-source-range unparsed-predicate))) + (util:cst-source-range unparsed-predicate))) :docstring docstring :methods (loop :for methods := (cst:nthrest (if docstring 3 2) form) :then (cst:rest methods) :while (cst:consp methods) :for method := (cst:first methods) :collect (parse-instance-method-definition method (cst:second form) source)) - :location (source:make-location source form) - :head-location (source:make-location source (cst:second form)) + :location (form-location source form) + :head-location (form-location source (cst:second form)) :compiler-generated nil)))) (defun parse-specialize (form source) @@ -1737,48 +1462,31 @@ consume all attributes"))) ;; (specialize) (unless (cst:consp (cst:rest form)) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :highlight :end - :message "Malformed specialize declaration" - :primary-note "missing from name"))) + (parse-error "Malformed specialize declaration" + (source:note (source:end-location (form-location source form)) + "missing from name"))) ;; (specialize f) (unless (cst:consp (cst:rest (cst:rest form))) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :highlight :end - :message "Malformed specialize declaration" - :primary-note "missing to name"))) + (parse-error "Malformed specialize declaration" + (note-end source form "missing to name"))) ;; (specialize f f2) (unless (cst:consp (cst:rest (cst:rest (cst:rest form)))) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :highlight :end - :message "Malformed specialize declaration" - :primary-note "missing type"))) + (parse-error "Malformed specialize declaration" + (note-end source form "missing type"))) ;; (specialize f f2 t ....) (when (cst:consp (cst:rest (cst:rest (cst:rest (cst:rest form))))) - (error 'parse-error - :err (se:source-error - :span (cst:source (cst:first (cst:rest (cst:rest (cst:rest (cst:rest form)))))) - :source source - :message "Malformed specialize declaration" - :primary-note "unexpected form"))) + (parse-error "Malformed specialize declaration" + (note source (cst:first (cst:rest (cst:rest (cst:rest (cst:rest form))))) + "unexpected form"))) (make-toplevel-specialize :from (parse-variable (cst:second form) source) :to (parse-variable (cst:third form) source) :type (parse-type (cst:fourth form) source) - :location (source:make-location source form))) + :location (form-location source form))) (defun parse-method (method-form form source) (declare (type cst:cst method-form) @@ -1787,67 +1495,37 @@ consume all attributes"))) ;; m or (m) (unless (and (cst:consp method-form) (cst:consp (cst:rest method-form))) - (error 'parse-error - :err (se:source-error - :span (cst:source method-form) - :source source - :message "Malformed method definition" - :primary-note "missing method type" - :notes - (list - (se:make-source-error-note - :type ':secondary - :span (cst:source (cst:second form)) - :message "in this class definition"))))) + (parse-error "Malformed method definition" + (note source method-form "missing method type") + (note source (cst:second form) "in this class definition"))) ;; (m d t ...) (unless (or (cst:null (cst:rest (cst:rest method-form))) (cst:null (cst:rest (cst:rest (cst:rest method-form))))) - (error 'parse-error - :err (se:source-error - :span (cst:source (cst:first (cst:rest (cst:rest (cst:rest method-form))))) - :source source - :message "Malformed method definition" - :primary-note "unexpected trailing form" - :notes - (list - (se:make-source-error-note - :type ':secondary - :span (cst:source (cst:second form)) - :message "in this class definition"))))) + (parse-error "Malformed method definition" + (note source (cst:first (cst:rest (cst:rest (cst:rest method-form)))) + "unexpected trailing form") + (note source (cst:second form) + "in this class definition"))) ;; (0.5 t ...) (unless (and (cst:atom (cst:first method-form)) (identifierp (cst:raw (cst:first method-form)))) - (error 'parse-error - :err (se:source-error - :span (cst:source (cst:first method-form)) - :source source - :message "Malformed method definition" - :primary-note "expected symbol" - :notes - (list - (se:make-source-error-note - :type ':secondary - :span (cst:source (cst:second form)) - :message "in this class definition"))))) + (parse-error "Malformed method definition" + (note source (cst:first method-form) + "expected symbol") + (note source (cst:second form) + "in this class definition"))) ;; (m "docstring") (when (and (cst:atom (cst:second method-form)) (stringp (cst:raw (cst:second method-form))) (cst:null (cst:rest (cst:rest method-form)))) - (error 'parse-error - :err (se:source-error - :span (cst:source (cst:second method-form)) - :source source - :message "Malformed method definition" - :primary-note "missing method type" - :notes - (list - (se:make-source-error-note - :type ':secondary - :span (cst:source (cst:second form)) - :message "in this class definition"))))) + (parse-error "Malformed method definition" + (note source (cst:second method-form) + "missing method type") + (note source (cst:second form) + "in this class definition"))) (let (docstring) (when (and (cst:atom (cst:second method-form)) @@ -1858,63 +1536,44 @@ consume all attributes"))) (unless (or (cst:null (cst:rest (cst:rest method-form))) (and (cst:atom (cst:second method-form)) (stringp (cst:raw (cst:second method-form))))) - (error 'parse-error - :err (se:source-error - :span (cst:source (if docstring - (cst:fourth method-form) - (cst:third method-form))) - :source source - :message "Malformed method definition" - :primary-note "unexpected trailing form" - :notes - (list - (se:make-source-error-note - :type ':secondary - :span (cst:source (cst:second form)) - :message "in this class definition"))))) + (parse-error "Malformed method definition" + (note source (if docstring + (cst:fourth method-form) + (cst:third method-form)) + "unexpected trailing form") + (note source (cst:second form) + "in this class definition"))) (make-method-definition :name (make-identifier-src :name (node-variable-name (parse-variable (cst:first method-form) source)) - :location (source:make-location source (cst:first method-form))) + :location (form-location source (cst:first method-form))) :docstring docstring :type (parse-qualified-type (if docstring (cst:third method-form) (cst:second method-form)) source) - :location (source:make-location source method-form)))) + :location (form-location source method-form)))) (defun parse-type-variable (form source) (declare (type cst:cst form) (values keyword-src &optional)) (when (cst:consp form) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Invalid type variable" - :primary-note "expected keyword symbol"))) + (parse-error "Invalid type variable" + (note source form "expected keyword symbol"))) (unless (keywordp (cst:raw form)) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Invalid type variable" - :primary-note "expected keyword symbol" - :help-notes - (list - (se:make-source-error-help - :span (cst:source form) - :replacement - (lambda (existing) - (concatenate 'string ":" existing)) - :message "add `:` to symbol"))))) + (parse-error "Invalid type variable" + (note source form "expected keyword symbol") + (help source form + (lambda (existing) + (concatenate 'string ":" existing)) + "add `:` to symbol"))) (make-keyword-src :name (cst:raw form) - :location (source:make-location source form))) + :location (form-location source form))) (defun parse-constructor (form enclosing-form source) (declare (type cst:cst form enclosing-form) @@ -1930,40 +1589,22 @@ consume all attributes"))) (setf unparsed-fields (cst:listify (cst:rest form))))) (unless (cst:atom unparsed-name) - (error 'parse-error - :err (se:source-error - :span (cst:source unparsed-name) - :source source - :message "Malformed constructor" - :primary-note "expected symbol" - :notes - (list - (se:make-source-error-note - :type ':secondary - :span (cst:source (cst:second enclosing-form)) - :message "in this type definition"))))) + (parse-error "Malformed constructor" + (note source unparsed-name "expected symbol") + (note source (cst:second enclosing-form) "in this type definition"))) (unless (identifierp (cst:raw unparsed-name)) - (error 'parse-error - :err (se:source-error - :span (cst:source unparsed-name) - :source source - :message "Malformed constructor" - :primary-note "expected symbol" - :notes - (list - (se:make-source-error-note - :type ':secondary - :span (cst:source (cst:second enclosing-form)) - :message "in this type definition"))))) + (parse-error "Malformed constructor" + (note source unparsed-name "expected symbol") + (note source (cst:second enclosing-form) "in this type definition"))) (make-constructor :name (make-identifier-src :name (cst:raw unparsed-name) - :location (source:make-location source unparsed-name)) + :location (form-location source unparsed-name)) :fields (loop :for field :in unparsed-fields :collect (parse-type field source)) - :location (source:make-location source form)))) + :location (form-location source form)))) (defun parse-argument-list (form source) (declare (type cst:cst form) @@ -1975,19 +1616,15 @@ consume all attributes"))) ;; (define (0.5 x y) ...) (unless (identifierp (cst:raw (cst:first form))) - (error 'parse-error - :err (se:source-error - :span (cst:source (cst:first form)) - :source source - :message "Malformed function definition" - :primary-note "expected symbol"))) + (parse-error "Malformed function definition" + (note source (cst:first form) "expected symbol"))) (values (parse-variable (cst:first form) source) (if (cst:null (cst:rest form)) (list (make-pattern-wildcard - :location (source:make-location source form))) + :location (form-location source form))) (loop :for vars := (cst:rest form) :then (cst:rest vars) :while (cst:consp vars) :collect (parse-pattern (cst:first vars) source))))) @@ -1997,40 +1634,24 @@ consume all attributes"))) (values identifier-src)) (unless (cst:atom form) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Unexpected list" - :primary-note "expected an identifier"))) + (parse-error "Unexpected list" + (note source form "expected an identifier"))) (unless (identifierp (cst:raw form)) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Unexpected form" - :primary-note "expected an identifier"))) + (parse-error "Unexpected form" + (note source form "expected an identifier"))) (when (string= "_" (cst:raw form)) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Invalid identifier" - :primary-note "invalid identifier '_'"))) + (parse-error "Invalid identifier" + (note source form "invalid identifier '_'"))) (when (char= #\. (aref (symbol-name (cst:raw form)) 0)) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Invalid identifier" - :primary-note "identifiers cannot start with '.'"))) + (parse-error "Invalid identifier" + (note source form "identifiers cannot start with '.'"))) (make-identifier-src :name (cst:raw form) - :location (source:make-location source form))) + :location (form-location source form))) (defun parse-definition-body (form enclosing-form source) (declare (type cst:cst form) @@ -2059,48 +1680,28 @@ consume all attributes"))) (type cst:cst parent-form) (values instance-method-definition)) - (let ((context-note - (se:make-source-error-note - :type ':secondary - :span (cst:source parent-form) - :message "when parsing instance"))) + (let ((context-note (note source parent-form "when parsing instance"))) (unless (cst:consp form) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Malformed method definition" - :primary-note "expected list" - :notes (list context-note)))) + (parse-error "Malformed method definition" + (note source form "expected list") + context-note)) (unless (cst:proper-list-p form) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Malformed method definition" - :primary-note "unexpected dotted list" - :notes (list context-note)))) + (parse-error "Malformed method definition" + (note source form "unexpected dotted list") + context-note)) (unless (and (cst:atom (cst:first form)) (eq (cst:raw (cst:first form)) 'coalton:define)) - (error 'parse-error - :err (se:source-error - :span (cst:source (cst:first form)) - :source source - :message "Malformed method definition" - :primary-note "expected method definition" - :notes (list context-note)))) + (parse-error "Malformed method definition" + (note source (cst:first form) "expected method definition") + context-note)) (unless (cst:consp (cst:rest form)) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Malformed method definition" - :primary-note "expected definition name" - :notes (list context-note)))) + (parse-error "Malformed method definition" + (note source form "expected definition name") + context-note)) (multiple-value-bind (name params) (parse-argument-list (cst:second form) source) @@ -2109,27 +1710,19 @@ consume all attributes"))) :name name :params params :body (parse-body (cst:rest (cst:rest form)) form source) - :location (source:make-location source form))))) + :location (form-location source form))))) (defun parse-fundep (form source) (declare (type cst:cst form) (values fundep)) (unless (cst:consp form) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Malformed functional dependency" - :primary-note "expected a list"))) + (parse-error "Malformed functional dependency" + (note source form "expected a list"))) (unless (cst:proper-list-p form) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Malformed functional dependency" - :primary-note "unexpected dotted list"))) + (parse-error "Malformed functional dependency" + (note source form "unexpected dotted list"))) (multiple-value-bind (left right) (util:take-until @@ -2139,28 +1732,19 @@ consume all attributes"))) (cst:listify form)) (unless left - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Malformed functional dependency" - :primary-note "expected one or more type variables"))) + (parse-error "Malformed functional dependency" + (note source form "expected one or more type variables"))) (unless (rest right) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :highlight :end - :message "Malformed functional dependency" - :primary-note "expected one or more type variables"))) + (parse-error "Malformed functional dependency" + (note-end source form "expected one or more type variables"))) (make-fundep :left (loop :for var :in left :collect (parse-type-variable var source)) :right (loop :for var :in (cdr right) :collect (parse-type-variable var source)) - :location (source:make-location source form)))) + :location (form-location source form)))) (defun parse-monomorphize (form source) @@ -2170,15 +1754,11 @@ consume all attributes"))) (assert (cst:consp form)) (when (cst:consp (cst:rest form)) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Malformed monomophize attribute" - :primary-note "unexpected form"))) + (parse-error "Malformed monomophize attribute" + (note source form "unexpected form"))) (make-attribute-monomorphize - :location (source:make-location source form))) + :location (form-location source form))) (defun parse-repr (form source) (declare (type cst:cst form) @@ -2187,65 +1767,46 @@ consume all attributes"))) (assert (cst:consp form)) (unless (cst:consp (cst:rest form)) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :highlight :end - :message "Malformed repr attribute" - :primary-note "expected keyword symbol"))) + (parse-error "Malformed repr attribute" + (note source form "expected keyword symbol"))) (let ((type (parse-type-variable (cst:second form) source))) (if (eq (keyword-src-name type) :native) (progn ;; :native reprs must have an argument (unless (cst:consp (cst:rest (cst:rest form))) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :highlight :end - :message "Malformed repr :native attribute" - :primary-note "expected a lisp type"))) + (parse-error "Malformed repr :native attribute" + (note-end source form "expected a lisp type"))) (when (cst:consp (cst:rest (cst:rest (cst:rest form)))) - (error 'parse-error - :err (se:source-error - :span (cst:source (cst:first (cst:rest (cst:rest (cst:rest form))))) - :source source - :message "Malformed repr :native attribute" - :primary-note "unexpected form"))) + (parse-error "Malformed repr :native attribute" + (note source (cst:first (cst:rest (cst:rest (cst:rest form)))) + "unexpected form"))) (make-attribute-repr :type type :arg (cst:third form) - :location (source:make-location source form))) + :location (form-location source form))) (progn ;; other reprs do not have an argument (when (cst:consp (cst:rest (cst:rest form))) - (error 'parse-error - :err (se:source-error - :span (cst:source (cst:first (cst:rest (cst:rest form)))) - :source source - :message "Malformed repr attribute" - :primary-note "unexpected form"))) + (parse-error "Malformed repr attribute" + (note source (cst:first (cst:rest (cst:rest form))) + "unexpected form"))) (case (keyword-src-name type) (:lisp nil) (:transparent nil) (:enum nil) (t - (error 'parse-error - :err (se:source-error - :span (cst:source (cst:second form)) - :source source - :message "Unknown repr attribute" - :primary-note "expected one of :lisp, :transparent, :enum, or :native")))) + (parse-error "Unknown repr attribute" + (note source (cst:second form) + "expected one of :lisp, :transparent, :enum, or :native")))) (make-attribute-repr :type type :arg nil - :location (source:make-location source form)))))) + :location (form-location source form)))))) (defun parse-struct-field (form source) (declare (type cst:cst form) @@ -2253,32 +1814,19 @@ consume all attributes"))) ;; 5 (unless (cst:consp form) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Malformed struct field" - :primary-note "unexpected form"))) + (parse-error "Malformed struct field" + (note source form "unexpected form"))) ;; (5 ...) (unless (and (cst:atom (cst:first form)) (symbolp (cst:raw (cst:first form)))) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Malformed struct field" - :primary-note "invalid field name (must be a symbol)" - :highlight :end))) + (parse-error "Malformed struct field" + (note-end source form "invalid field name (must be a symbol)"))) ;; (name) (unless (cst:consp (cst:rest form)) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Malformed struct field" - :primary-note "expected field type"))) + (parse-error "Malformed struct field" + (note source form "expected field type"))) (multiple-value-bind (docstring rest-field) (if (stringp (cst:raw (cst:second form))) @@ -2287,27 +1835,17 @@ consume all attributes"))) ;; (name docstring) (when (cst:null rest-field) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Malformed struct field" - :primary-note "expected field type" - :highlight :end))) + (parse-error "Malformed struct field" + (note-end source form "expected field type"))) ;; (name ty ...) or (name "docstring" ty ...) (unless (cst:null (cst:rest rest-field)) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Malformed struct field" - :primary-note "unexpected trailing form" - :highlight :end))) + (parse-error "Malformed struct field" + (note-end source form "unexpected trailing form"))) (make-struct-field :name (symbol-name (cst:raw (cst:first form))) :type (parse-type (cst:first rest-field) source) :docstring docstring - :location (source:make-location source form)))) + :location (form-location source form)))) diff --git a/src/parser/types.lisp b/src/parser/types.lisp index e822cd92..0dd047a8 100644 --- a/src/parser/types.lisp +++ b/src/parser/types.lisp @@ -7,7 +7,6 @@ #:parse-error) (:local-nicknames (#:cst #:concrete-syntax-tree) - (#:se #:source-error) (#:source #:coalton-impl/source) (#:util #:coalton-impl/util)) (:export @@ -146,7 +145,7 @@ (make-qualified-ty :predicates nil :type (parse-type form source) - :location (source:make-location source form)) + :location (form-location source form)) (multiple-value-bind (left right) (util:take-until (lambda (cst) @@ -158,50 +157,36 @@ ((null right) (make-qualified-ty :predicates nil - :type (parse-type-list left (source:make-location source form)) - :location (source:make-location source form))) + :type (parse-type-list left (form-location source form)) + :location (form-location source form))) ;; (=> T -> T) ((and (null left) right) - (error 'parse-error - :err (se:source-error - :span (cst:source (cst:first form)) - :source source - :message "Malformed type" - :primary-note "unnecessary `=>`" - :help-notes + (apply #'parse-error "Malformed type" + (cons (note source (cst:first form) "unnecessary `=>`") (cond ;; If this is the only thing in the list then don't suggest anything ((cst:atom (cst:rest form)) nil) ;; If there is nothing to the right of C then emit without list ((cst:atom (cst:rest (cst:rest form))) - (list - (se:make-source-error-help - :span (cst:source form) - :replacement - (lambda (existing) - (subseq existing 4 (1- (length existing)))) - :message "remove `=>`"))) + (list (help source form + (lambda (existing) + (subseq existing 4 (1- (length existing)))) + "remove `=>`"))) (t - (list - (se:make-source-error-help - :span (cst:source form) - :replacement - (lambda (existing) - (concatenate 'string - (subseq existing 0 1) - (subseq existing 4))) - :message "remove `=>`"))))))) + (list (help source form + (lambda (existing) + (concatenate 'string + (subseq existing 0 1) + (subseq existing 4))) + "remove `=>`"))))))) ;; (... =>) ((null (rest right)) - (error 'parse-error - :err (se:source-error - :span (cst:source (cst:second form)) - :source source - :message "Malformed type" - :primary-note "missing type after `=>`"))) + (parse-error "Malformed type" + (note source (cst:source (cst:second form)) + "missing type after `=>`"))) (t (let (predicates) @@ -214,15 +199,11 @@ (loop :for pred :in left :unless (cst:consp pred) - :do (error 'parse-error - :err (se:source-error - :span (cst:source (cst:second form)) - :source source - :message "Malformed type predicate" - :primary-note "expected predicate")) + :do (parse-error "Malformed type predicate" + (note source (cst:second form) + "expected predicate")) :do (push (parse-predicate (cst:listify pred) - (source:make-location source - (cst:source form))) + (form-location source form)) predicates))) (make-qualified-ty @@ -232,7 +213,7 @@ (source:make-location source (cons (car (cst:source (second right))) (cdr (cst:source (car (last right))))))) - :location (source:make-location source form)))))))) + :location (form-location source form)))))))) (defun parse-predicate (forms location) (declare (type util:cst-list forms) @@ -244,44 +225,30 @@ (cond ;; (T) ... => .... ((not (cst:atom (first forms))) - (error 'parse-error - :err (se:source-error - :span (cst:source (first forms)) - :source source - :message "Malformed type predicate" - :primary-note "expected class name" - :help-notes - (list - (se:make-source-error-help - :span (cst:source (first forms)) - :replacement - (lambda (existing) - (subseq existing 1 (1- (length existing)))) - :message "remove parentheses"))))) + (parse-error "Malformed type predicate" + (note source (first forms) + "expected class name") + (help source (first forms) + (lambda (existing) + (subseq existing 1 (1- (length existing)))) + "remove parentheses"))) ;; "T" ... => ... ((not (identifierp (cst:raw (first forms)))) - (error 'parse-error - :err (se:source-error - :span (cst:source (first forms)) - :source source - :message "Malformed type predicate" - :primary-note "expected identifier"))) + (parse-error "Malformed type predicate" + (note source (first forms) "expected identifier"))) (t (let ((name (cst:raw (first forms)))) (when (= 1 (length forms)) - (error 'parse-error - :err (se:source-error - :span (cst:source (first forms)) - :source source - :message "Malformed type predicate" - :primary-note "expected predicate"))) + (parse-error "Malformed type predicate" + (note source (first forms) + "expected predicate"))) (make-ty-predicate :class (make-identifier-src :name name - :location (source:make-location source (first forms))) + :location (form-location source (first forms))) :types (loop :for form :in (cdr forms) :collect (parse-type form source)) :location location)))))) @@ -296,28 +263,20 @@ (cst:raw form)) (if (equalp (symbol-package (cst:raw form)) util:+keyword-package+) - (make-tyvar :name (cst:raw form) :location (source:make-location source form)) - (make-tycon :name (cst:raw form) :location (source:make-location source form)))) + (make-tyvar :name (cst:raw form) :location (form-location source form)) + (make-tycon :name (cst:raw form) :location (form-location source form)))) ((cst:atom form) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Malformed type" - :primary-note "expected identifier"))) + (parse-error "Malformed type" + (note source form "expected identifier"))) ;; (T) ((cst:atom (cst:rest form)) - (error 'parse-error - :err (se:source-error - :span (cst:source form) - :source source - :message "Malformed type" - :primary-note "unexpected nullary type"))) + (parse-error "Malformed type" + (note source form "unexpected nullary type"))) (t - (parse-type-list (cst:listify form) (source:make-location source form))))) + (parse-type-list (cst:listify form) (form-location source form))))) (defun parse-type-list (forms location) (declare (type util:cst-list forms) @@ -337,21 +296,15 @@ ;; (T ... ->) (cond ((and right (null (rest right))) - (error 'parse-error - :err (se:source-error - :span (cst:source (car right)) - :source (source:location-source location) - :message "Malformed function type" - :primary-note "missing return type"))) + (parse-error "Malformed function type" + (note (source:location-source location) (car right) + "missing return type"))) ;; (-> ...) ((and (null left) right) - (error 'parse-error - :err (se:source-error - :span (cst:source (car right)) - :source (source:location-source location) - :message "Malformed function type" - :primary-note "invalid function syntax"))) + (parse-error "Malformed function type" + (note (source:location-source location) (car right) + "invalid function syntax"))) (t (let ((ty (parse-type (car left) (source:location-source location)))) @@ -368,7 +321,7 @@ :from (make-tapp :from (make-tycon :name 'coalton:Arrow - :location (source:make-location (source:location-source location) + :location (form-location (source:location-source location) (first right))) :to ty :location (source:make-location (source:location-source location) diff --git a/src/source.lisp b/src/source.lisp index be5dd813..1b7481d4 100644 --- a/src/source.lisp +++ b/src/source.lisp @@ -14,6 +14,7 @@ #:warn #:help #:note + #:primary-note #:message #:make-source-error #:make-source-file @@ -24,6 +25,7 @@ #:location-source #:location-span #:location< + #:span #:span-start #:span-end #:docstring @@ -233,13 +235,11 @@ If locations appear in different sources, compare the sources by name." (defmethod make-load-form ((self location) &optional env) (make-load-form-saving-slots self :environment env)) -(defun make-location (source form) - "Make a source location structure from a SOURCE and a form, which may be either a cons of start, end or a cst node." - (etypecase form - (cst:cst (%make-location :source source - :span (cst:source form))) - (cons (%make-location :source source - :span form)))) +(defun make-location (source span) + "Make a source location structure from a SOURCE and a SPAN." + (declare (type cons span)) + (%make-location :source source + :span span)) (defgeneric message (object) (:documentation "The primary message associated with an object.")) @@ -265,18 +265,34 @@ If locations appear in different sources, compare the sources by name." (location self) (message self)))) +(defun ensure-location (locatable) + (typecase locatable + (location locatable) + (t (location locatable)))) + (defun note (location format-string &rest format-args) "Return a note that describes a source LOCATION." + (declare (type string format-string)) (make-instance 'note - :location location + :location (ensure-location location) :message (apply #'format nil format-string format-args))) +(defun primary-note (location format-string &rest format-args) + "Return a note that describes a primary source LOCATION." + (declare (type string format-string)) + (make-instance 'note + :location (ensure-location location) + :message (apply #'format nil format-string format-args) + :type ':primary)) + (defun help (location replace format-string &rest format-args) "Return a help note related to a source LOCATION. REPLACE is a 1-argument function that accepts and returns a string to suggest an edit or fix." + (declare (type function replace) + (type string format-string)) (make-instance 'note - :location location + :location (ensure-location location) :message (apply #'format nil format-string format-args) :replace replace :type ':help)) @@ -336,4 +352,4 @@ REPLACE is a 1-argument function that accepts and returns a string to suggest an (defun warn (message note &rest notes) "Signal a warning related to one or more source locations." (cl:warn 'se:source-base-warning - :err (make-source-error ':warning message (cons note notes)))) + :err (make-source-error ':warn message (cons note notes)))) diff --git a/src/typechecker/accessor.lisp b/src/typechecker/accessor.lisp index 075b2e06..b7e1bb14 100644 --- a/src/typechecker/accessor.lisp +++ b/src/typechecker/accessor.lisp @@ -4,7 +4,6 @@ #:coalton-impl/typechecker/base) (:local-nicknames (#:source #:coalton-impl/source) - (#:se #:source-error) (#:tc #:coalton-impl/typechecker/stage-1) (#:util #:coalton-impl/util)) (:export @@ -105,19 +104,17 @@ (struct-entry (tc:lookup-struct env ty-name :no-error t))) (unless struct-entry - (tc-error accessor - "Invalid accessor" - (format nil "type '~S' is not a struct" ty-name))) + (tc-error "Invalid accessor" + (tc-note accessor "type '~S' is not a struct" ty-name))) (let ((subs (tc:match struct-ty (accessor-from accessor))) (field (tc:get-field struct-entry (accessor-field accessor) :no-error t))) (unless field - (tc-error accessor - "Invalid accessor" - (format nil "struct '~S' does not have the field '~A'" - ty-name - (accessor-field accessor)))) + (tc-error "Invalid accessor" + (tc-note accessor "struct '~S' does not have the field '~A'" + ty-name + (accessor-field accessor)))) ;; the order of unification matters here (setf subs (tc:unify subs (accessor-to accessor) diff --git a/src/typechecker/base.lisp b/src/typechecker/base.lisp index 08233953..626c822d 100644 --- a/src/typechecker/base.lisp +++ b/src/typechecker/base.lisp @@ -11,7 +11,10 @@ #:*pprint-variable-symbol-code* #:*pprint-variable-symbol-suffix* #:tc-error ; CONDITION, FUNCTION - #:tc-located-error ; CONDITION, FUNCTION + #:tc-location + #:tc-primary-location + #:tc-note + #:tc-primary-note #:coalton-internal-type-error ; CONDITION #:check-duplicates ; FUNCTION #:check-package ; FUNCTION @@ -62,26 +65,29 @@ This requires a valid PPRINT-VARIABLE-CONTEXT") ;;; Conditions ;;; +(defun tc-location (location format-string &rest format-args) + (source:note location + (with-pprint-variable-context () + (apply #'format nil format-string format-args)))) + +(defun tc-primary-location (location format-string &rest format-args) + (source:primary-note location + (with-pprint-variable-context () + (apply #'format nil format-string format-args)))) + +(defun tc-note (located format-string &rest format-args) + (apply #'tc-location (source:location located) format-string format-args)) + +(defun tc-primary-note (located format-string &rest format-args) + (apply #'tc-primary-location (source:location located) format-string format-args)) + (define-condition tc-error (se:source-base-error) - () - (:report - (lambda (c s) - (with-pprint-variable-context () - (se:display-source-error s (se:source-condition-err c)))))) - -(defun tc-located-error (location message note &optional notes) - "Signal a typechecker error with a NOTE about a LOCATION." - (declare (type source:location location) - (type string message note)) - (error 'tc-error - :err (source:source-error :location location - :message message - :primary-note note - :notes notes))) - -(defun tc-error (object message note &optional notes) - "Signal a typechecker error with a NOTE about an OBJECT that implements SOURCE:LOCATION." - (tc-located-error (source:location object) message note notes)) + ()) + +(defun tc-error (message &rest notes) + "Signal a typechecker error with MESSAGE, and optional NOTES that label source locations." + (declare (type string message)) + (error 'tc-error :err (source:make-source-error ':error message notes))) (define-condition coalton-internal-type-error (error) () diff --git a/src/typechecker/define-class.lisp b/src/typechecker/define-class.lisp index 32bc6c94..e9ec88e3 100644 --- a/src/typechecker/define-class.lisp +++ b/src/typechecker/define-class.lisp @@ -9,7 +9,6 @@ #:check-package #:check-duplicates) (:local-nicknames - (#:se #:source-error) (#:util #:coalton-impl/util) (#:algo #:coalton-impl/algorithm) (#:parser #:coalton-impl/parser) @@ -65,17 +64,11 @@ (alexandria:compose #'parser:identifier-src-name #'parser:toplevel-define-class-name) #'source:location (lambda (first second) - (error 'tc:tc-error - :err (source:source-error - :location (parser:toplevel-define-class-head-location first) - :message "Duplicate class definition" - :primary-note "first definition here" - :notes - (list - (se:make-source-error-note - :type :primary - :span (source:location-span (parser:toplevel-define-class-head-location second)) - :message "second definition here")))))) + (tc:tc-error "Duplicate class definition" + (tc:tc-location (parser:toplevel-define-class-head-location first) + "first definition here") + (tc:tc-primary-location (parser:toplevel-define-class-head-location second) + "second definition here")))) ;; Check for duplicate method definitions (check-duplicates @@ -83,17 +76,9 @@ (alexandria:compose #'parser:identifier-src-name #'parser:method-definition-name) #'source:location (lambda (first second) - (error 'tc:tc-error - :err (source:source-error - :location (source:location first) - :message "Duplicate method definition" - :primary-note "first definition here" - :notes - (list - (se:make-source-error-note - :type :primary - :span (source:location-span (source:location second)) - :message "second definition here")))))) + (tc:tc-error "Duplicate method definition" + (tc:tc-note first "first definition here") + (tc:tc-primary-note second "second definition here")))) (loop :for class :in classes :do ;; Classes cannot have duplicate variables @@ -102,17 +87,9 @@ #'parser:keyword-src-name #'source:location (lambda (first second) - (error 'tc:tc-error - :err (source:source-error - :location (source:location first) - :message "Duplicate class variable" - :primary-note "first usage here" - :notes - (list - (se:make-source-error-note - :type :primary - :span (source:location-span (source:location second)) - :message "second usage here"))))))) + (tc:tc-error "Duplicate class variable" + (tc:tc-note first "first usage here") + (tc:tc-primary-note second "second usage here"))))) (let* ((class-table (loop :with table := (make-hash-table :test #'eq) @@ -163,16 +140,12 @@ ;; Classes cannot have cyclic superclasses :when (intersection superclass-names scc-names :test #'eq) :do (let ((scc (sort (copy-list scc) #'source:location< :key #'source:location))) - (error 'tc:tc-error - :err (source:source-error - :location (parser:toplevel-define-class-head-location (first scc)) - :message "Cyclic superclasses" - :primary-note "in class defined here" - :notes (loop :for class :in (rest scc) - :collect (se:make-source-error-note - :type :primary - :span (source:location-span (parser:toplevel-define-class-head-location class)) - :message "in class defined here"))))) + (apply #'tc:tc-error "Cyclic superclasses" + (cons (tc:tc-location (parser:toplevel-define-class-head-location (first scc)) + "in class defined here") + (loop :for class :in (rest scc) + :collect (tc:tc-primary-location (parser:toplevel-define-class-head-location class) + "in class defined here"))))) :append (multiple-value-bind (classes env_) (infer-class-scc-kinds scc env) @@ -194,7 +167,7 @@ (loop :for class :in renamed-classes :for class-name := (parser:identifier-src-name (parser:toplevel-define-class-name class)) - + :for vars := (mapcar #'parser:keyword-src-name (parser:toplevel-define-class-vars class)) @@ -316,9 +289,9 @@ ;; Fundeps cannot be redefined :when (and prev-class (not (equalp (tc:ty-class-fundeps prev-class) fundeps))) - :do (tc-located-error (parser:toplevel-define-class-head-location class) - "Invalid fundep redefinition" - (format nil "unable to redefine the fundeps of class ~S." class-name)) + :do (tc-error "Invalid fundep redefinition" + (tc-location (parser:toplevel-define-class-head-location class) + "unable to redefine the fundeps of class ~S." class-name)) :when fundeps :do (setf env (tc:initialize-fundep-environment env class-name)) @@ -379,17 +352,9 @@ #'parser:keyword-src-name #'source:location (lambda (first second) - (error 'tc:tc-error - :err (source:source-error - :location (source:location first) - :message "Duplicate variable in function dependency" - :primary-note "first usage here" - :notes - (list - (se:make-source-error-note - :type :primary - :span (source:location-span (source:location second)) - :message "second usage here")))))))) + (tc:tc-error "Duplicate variable in function dependency" + (tc:tc-note first "first usage here") + (tc:tc-note second "second usage here")))))) (loop :for fundep :in (parser:toplevel-define-class-fundeps class) :do (check-duplicate-fundep-variables (parser:fundep-left fundep)) :do (check-duplicate-fundep-variables (parser:fundep-right fundep)))) @@ -398,10 +363,9 @@ (labels ((check-fundep-variables (vars) (loop :for var :in vars :unless (find (parser:keyword-src-name var) var-names :test #'eq) - :do (tc-error var - "Unknown type variable" - (format nil "unknown type variable ~S" - (parser:keyword-src-name var)))))) + :do (tc-error "Unknown type variable" + (tc-note var "unknown type variable ~S" + (parser:keyword-src-name var)))))) (loop :for fundep :in (parser:toplevel-define-class-fundeps class) :do (check-fundep-variables (parser:fundep-left fundep)) :do (check-fundep-variables (parser:fundep-right fundep)))) @@ -438,9 +402,9 @@ ;; Ensure that methods are not ambiguous :unless (subsetp var-names (tc:closure tyvars fundeps) :test #'eq) - :do (tc-error method - "Ambiguous method" - "the method is ambiguous") + :do (tc-error "Ambiguous method" + (tc-note method + "the method is ambiguous")) ;; Ensure that the type variables in each ;; pred are not a subset of the class @@ -451,9 +415,9 @@ :test #'eq) :when (subsetp tyvars var-names) - :do (tc-error pred - "Invalid method predicate" - "method predicate contains only class variables")) + :do (tc-error "Invalid method predicate" + (tc-note pred + "method predicate contains only class variables"))) :do (loop :for tyvar :in new-tyvars :do (partial-type-env-add-var env tyvar)) diff --git a/src/typechecker/define-instance.lisp b/src/typechecker/define-instance.lisp index 7da9606f..f120a691 100644 --- a/src/typechecker/define-instance.lisp +++ b/src/typechecker/define-instance.lisp @@ -16,7 +16,6 @@ #:make-tc-env #:infer-expl-binding-type) (:local-nicknames - (#:se #:source-error) (#:settings #:coalton-impl/settings) (#:source #:coalton-impl/source) (#:util #:coalton-impl/util) @@ -134,18 +133,18 @@ (handler-case (setf env (tc:update-instance-fundeps env pred)) (tc:fundep-conflict (e) - (tc-located-error (parser:toplevel-define-instance-head-location instance) - "Instance fundep conflict" - (let ((*print-escape* nil)) - (with-output-to-string (s) - (print-object e s))))))) + (tc-error "Instance fundep conflict" + (tc-location (parser:toplevel-define-instance-head-location instance) + (let ((*print-escape* nil)) + (with-output-to-string (s) + (print-object e s)))))))) (handler-case (setf env (tc:add-instance env class-name instance-entry)) (tc:overlapping-instance-error (e) - (tc-located-error (parser:toplevel-define-instance-head-location instance) - "Overlapping instance" - (format nil "instance overlaps with ~S" (tc:overlapping-instance-error-inst2 e))))) + (tc-error "Overlapping instance" + (tc-location (parser:toplevel-define-instance-head-location instance) + "instance overlaps with ~S" (tc:overlapping-instance-error-inst2 e))))) (loop :for method-name :in method-names :for method-codegen-sym := (tc:get-value method-codegen-syms method-name) :do @@ -189,9 +188,9 @@ env superclass :no-error t) - (tc-located-error (parser:toplevel-define-instance-head-location unparsed-instance) - "Instance missing context" - (format nil "No instance for ~S" superclass))) + (tc-error "Instance missing context" + (tc-location (parser:toplevel-define-instance-head-location unparsed-instance) + "No instance for ~S" superclass))) :for additional-context := (tc:apply-substitution @@ -202,38 +201,32 @@ :do (loop :for pred :in additional-context :do (unless (tc:entail env context pred) - (tc-located-error (parser:toplevel-define-instance-head-location unparsed-instance) - "Instance missing context" - (format nil - "No instance for ~S arising from constraints of superclasses ~S" - pred - superclass))))) + (tc-error "Instance missing context" + (tc-location (parser:toplevel-define-instance-head-location unparsed-instance) + "No instance for ~S arising from constraints of superclasses ~S" + pred + superclass))))) (check-duplicates (parser:toplevel-define-instance-methods unparsed-instance) (alexandria:compose #'parser:node-variable-name #'parser:instance-method-definition-name) #'source:location (lambda (first second) - (tc-error first - "Duplicate method definition" - "first definition here" - (list - (se:make-source-error-note - :type :primary - :span (source:location-span (source:location second)) - :message "second definition here"))))) + (tc-error "Duplicate method definition" + (tc-note first "first definition here") + (tc-primary-note second "second definition here")))) ;; Ensure each method is part for the class (loop :for method :in (parser:toplevel-define-instance-methods unparsed-instance) :for name := (parser:node-variable-name (parser:instance-method-definition-name method)) :unless (gethash name method-table) - :do (tc-error method - "Unknown method" - (let ((*package* util:+keyword-package+)) - (format nil "The method ~S is not part of class ~S" - name - class-name)))) + :do (tc-error "Unknown method" + (tc-note method + (let ((*package* util:+keyword-package+)) + (format nil "The method ~S is not part of class ~S" + name + class-name))))) ;; Ensure each method is defined (loop :for name :being :the :hash-keys :of method-table @@ -241,9 +234,8 @@ :key (alexandria:compose #'parser:node-variable-name #'parser:instance-method-definition-name)) :unless method - :do (tc-error unparsed-instance - "Missing method" - (format nil "The method ~S is not defined" name))) + :do (tc-error "Missing method" + (tc-note unparsed-instance "The method ~S is not defined" name))) (let* ((methods (loop :with table := (make-hash-table :test #'eq) @@ -313,9 +305,9 @@ (when (eq (parser:identifier-src-name (parser:ty-predicate-class (parser:toplevel-define-instance-pred instance))) runtime-repr) - (tc-located-error (parser:toplevel-define-instance-head-location instance) - "Invalid instance" - "RuntimeRepr instances cannot be written manually")))) + (tc-error "Invalid instance" + (tc-location (parser:toplevel-define-instance-head-location instance) + "RuntimeRepr instances cannot be written manually"))))) (defun check-for-orphan-instance (instance) (declare (type parser:toplevel-define-instance instance) @@ -355,6 +347,6 @@ :append (mapcar #'parser:tycon-name (parser:collect-referenced-types type)))))) (unless (find *package* instance-syms :key #'symbol-package) - (tc-located-error (parser:toplevel-define-instance-head-location instance) - "Invalid orphan instance" - "instances must be defined in the same package as their class or reference one or more types in their defining package")))) + (tc-error "Invalid orphan instance" + (tc-location (parser:toplevel-define-instance-head-location instance) + "instances must be defined in the same package as their class or reference one or more types in their defining package"))))) diff --git a/src/typechecker/define-type.lisp b/src/typechecker/define-type.lisp index 20d70c6c..77030494 100644 --- a/src/typechecker/define-type.lisp +++ b/src/typechecker/define-type.lisp @@ -15,11 +15,11 @@ #:check-package #:check-duplicates) (:local-nicknames - (#:se #:source-error) (#:source #:coalton-impl/source) (#:util #:coalton-impl/util) (#:algo #:coalton-impl/algorithm) (#:parser #:coalton-impl/parser) + (#:source #:coalton-impl/source) (#:tc #:coalton-impl/typechecker/stage-1)) (:export #:toplevel-define-type ; FUNCTION @@ -103,16 +103,9 @@ (alexandria:compose #'parser:identifier-src-name #'parser:type-definition-name) #'source:location (lambda (first second) - (error 'tc:tc-error - :err (source:source-error - :location (source:location first) - :message "Duplicate type definitions" - :primary-note "first definition here" - :notes (list (se:make-source-error-note - :type :primary - :span (source:location-span - (source:location second)) - :message "second definition here")))))) + (tc:tc-error "Duplicate type definitions" + (tc:tc-note first "first definition here") + (tc:tc-primary-note second "second definition here")))) ;; Ensure that there are no duplicate constructors ;; NOTE: structs define a constructor with the same name @@ -122,15 +115,9 @@ (alexandria:compose #'parser:identifier-src-name #'parser:type-definition-ctor-name) #'source:location (lambda (first second) - (error 'tc:tc-error - :err (source:source-error - :location (source:location first) - :message "Duplicate constructor definitions" - :primary-note "first definition here" - :notes (list (se:make-source-error-note - :type :primary - :span (source:location-span (source:location second)) - :message "second definition here")))))) + (tc:tc-error "Duplicate constructor definitions" + (tc:tc-note first "first definition here") + (tc:tc-primary-note second "second definition here")))) ;; Ensure that no type has duplicate type variables (loop :for type :in (append types structs) @@ -139,16 +126,9 @@ #'parser:keyword-src-name #'source:location (lambda (first second) - (error 'tc:tc-error - :err (source:source-error - :location (source:location first) - :message "Duplicate type variable definitions" - :primary-note "first definition here" - :notes - (list (se:make-source-error-note - :type :primary - :span (source:location-span (source:location second)) - :message "second definition here"))))))) + (tc:tc-error "Duplicate type variable definitions" + (tc:tc-note first "first definition here") + (tc:tc-primary-note second "second definition here"))))) (let* ((type-names (mapcar (alexandria:compose #'parser:identifier-src-name #'parser:type-definition-name) @@ -384,23 +364,23 @@ :when (eq repr-type :enum) :do (loop :for ctor :in (parser:toplevel-define-type-ctors type) :unless (endp (parser:constructor-fields ctor)) - :do (tc-error (first (parser:constructor-fields ctor)) - "Invalid repr :enum attribute" - "constructors of repr :enum types cannot have fields")) + :do (tc-error "Invalid repr :enum attribute" + (tc-note (first (parser:constructor-fields ctor)) + "constructors of repr :enum types cannot have fields"))) ;; Check that repr :transparent types have a single constructor :when (eq repr-type :transparent) :do (unless (= 1 (length (parser:type-definition-ctors type))) - (tc-error type - "Invalid repr :transparent attribute" - "repr :transparent types must have a single constructor")) + (tc-error "Invalid repr :transparent attribute" + (tc-note type + "repr :transparent types must have a single constructor"))) ;; Check that the single constructor of a repr :transparent type has a single field :when (eq repr-type :transparent) :do (unless (= 1 (length (parser:type-definition-ctor-field-types (first (parser:type-definition-ctors type))))) - (tc-error (first (parser:type-definition-ctors type)) - "Invalid repr :transparent attribute" - "constructors of repr :transparent types must have a single field")) + (tc-error "Invalid repr :transparent attribute" + (tc-note (first (parser:type-definition-ctors type)) + "constructors of repr :transparent types must have a single field"))) :collect (let* ((ctors (loop :for ctor :in (parser:type-definition-ctors type) diff --git a/src/typechecker/define.lisp b/src/typechecker/define.lisp index b0e2908d..9e781d66 100644 --- a/src/typechecker/define.lisp +++ b/src/typechecker/define.lisp @@ -25,11 +25,11 @@ #:coalton-impl/typechecker/accessor #:coalton-impl/typechecker/tc-env) (:local-nicknames - (#:se #:source-error) (#:source #:coalton-impl/source) (#:util #:coalton-impl/util) (#:algo #:coalton-impl/algorithm) (#:parser #:coalton-impl/parser) + (#:source #:coalton-impl/source) (#:tc #:coalton-impl/typechecker/stage-1) (#:types #:coalton-impl/typechecker/types)) (:export @@ -65,10 +65,7 @@ (unless (source:location pred) (util:coalton-bug "Predicate ~S does not have source information" pred)) - (tc-error pred - "Ambiguous predicate" - (with-pprint-variable-context () - (format nil "Ambiguous predicate ~S" pred)))) + (tc-error "Ambiguous predicate" (tc-note pred "Ambiguous predicate ~S" pred))) (defun error-unknown-pred (pred) (declare (type tc:ty-predicate pred)) @@ -76,17 +73,14 @@ (unless (source:location pred) (util:coalton-bug "Predicate ~S does not have source information" pred)) - (tc-error pred - "Unknown instance" - (format nil "Unknown instance ~S" pred))) + (tc-error "Unknown instance" (tc-note pred "Unknown instance ~S" pred))) (defun standard-expression-type-mismatch-error (node subs expected-type ty) "Utility for signalling a type-mismatch error in INFER-EXPRESSION-TYPE" - (tc-error node - "Type mismatch" - (format nil "Expected type '~S' but got '~S'" - (tc:apply-substitution subs expected-type) - (tc:apply-substitution subs ty)))) + (tc-error "Type mismatch" + (tc-note node "Expected type '~S' but got '~S'" + (tc:apply-substitution subs expected-type) + (tc:apply-substitution subs ty)))) ;;; ;;; Entrypoint ;;; @@ -111,14 +105,11 @@ (alexandria:compose #'parser:node-variable-name #'parser:toplevel-define-name) #'source:location (lambda (first second) - (tc-error (parser:toplevel-define-name first) - "Duplicate definition" - "first definition here" - (list - (se:make-source-error-note - :type :primary - :span (source:location-span (source:location (parser:toplevel-define-name second))) - :message "second definition here"))))) + (tc-error "Duplicate definition" + (tc-note (parser:toplevel-define-name first) + "first definition here") + (tc-note (parser:toplevel-define-name second) + "second definition here")))) ;; Ensure that there are no duplicate declarations (check-duplicates @@ -126,14 +117,11 @@ (alexandria:compose #'parser:identifier-src-name #'parser:toplevel-declare-name) #'source:location (lambda (first second) - (tc-error (parser:toplevel-declare-name first) - "Duplicate declaration" - "first declaration here" - (list - (se:make-source-error-note - :type :primary - :span (source:location-span (source:location (parser:toplevel-declare-name second))) - :message "second declaration here"))))) + (tc-error "Duplicate declaration" + (tc-note (parser:toplevel-declare-name first) + "first declaration here") + (tc-note (parser:toplevel-declare-name second) + "second declaration here")))) ;; Ensure that each declaration has an associated definition (loop :with def-table @@ -151,9 +139,9 @@ :for name := (parser:identifier-src-name (parser:toplevel-declare-name declare)) :unless (gethash name def-table) - :do (tc-error (parser:toplevel-declare-name declare) - "Orphan declaration" - "declaration does not have an associated definition")) + :do (tc-error "Orphan declaration" + (tc-note (parser:toplevel-declare-name declare) + "declaration does not have an associated definition"))) (let ((dec-table (make-hash-table :test #'eq)) @@ -283,7 +271,7 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)") (type tc:substitution-list subs) (type tc-env env) (values tc:ty tc:ty-predicate-list accessor-list node-integer-literal tc:substitution-list &optional)) - + (let* ((num (util:find-symbol "NUM" "COALTON-LIBRARY/CLASSES")) (tvar @@ -395,15 +383,14 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)") ;; Otherwise signal an error (t (setf fun-ty (tc:apply-substitution subs fun-ty)) - (tc-error node - "Argument error" + (tc-error "Argument error" (if (null (tc:function-type-arguments fun-ty)) - (format nil "Unable to call '~S': it is not a function" - fun-ty) - (format nil "Function call has ~D arguments but inferred type '~S' only takes ~D" - (length rands) - fun-ty - (length (tc:function-type-arguments fun-ty)))))))))) + (tc-note node "Unable to call '~S': it is not a function" + fun-ty) + (tc-note node "Function call has ~D arguments but inferred type '~S' only takes ~D" + (length rands) + fun-ty + (length (tc:function-type-arguments fun-ty)))))))))) (handler-case (progn @@ -448,7 +435,7 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)") :location (source:location node) :pattern pat-node :expr expr-node) - subs)))) + subs)))) (:method ((node parser:node-body) expected-type subs env) (declare (type tc:ty expected-type) @@ -495,13 +482,9 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)") #'parser:pattern-var-name #'source:location (lambda (first second) - (tc-error first - "Duplicate parameters name" - "first parameter here" - (list (se:make-source-error-note - :type :primary - :span (source:location-span (source:location second)) - :message "second parameter here"))))) + (tc-error "Duplicate parameters name" + (tc-note first "first parameter here") + (tc-note second "second parameter here")))) (let* (;; Setup return environment (*return-status* :lambda) @@ -539,34 +522,26 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)") :do (handler-case (setf subs (tc:unify subs ty1 ty2)) (tc:coalton-internal-type-error () - (tc-error s1 - "Return type mismatch" - (format nil "First return is of type '~S'" - (tc:apply-substitution subs ty1)) - (list - (se:make-source-error-note - :type :primary - :span (source:location-span s2) - :message (format nil "Second return is of type '~S'" - (tc:apply-substitution subs ty2)))))))) + (tc-error "Return type mismatch" + (tc-primary-note s1 + "First return is of type '~S'" + (tc:apply-substitution subs ty1)) + (tc-primary-note s2 + "Second return is of type '~S'" + (tc:apply-substitution subs ty2)))))) ;; Unify the function's inferred type with one of the early returns. (when *returns* (handler-case (setf subs (tc:unify subs (cdr (first *returns*)) body-ty)) (tc:coalton-internal-type-error () - (tc-error (car (first *returns*)) - "Return type mismatch" - (format nil "First return is of type '~S'" - (tc:apply-substitution subs (cdr (first *returns*)))) - (list - (se:make-source-error-note - :type :primary - :span (source:location-span - (source:location - (parser:node-body-last-node (parser:node-abstraction-body node)))) - :message (format nil "Second return is of type '~S'" - (tc:apply-substitution subs body-ty)))))))) + (tc-error "Return type mismatch" + (tc-primary-note (car (first *returns*)) + "First return is of type '~S'" + (tc:apply-substitution subs (cdr (first *returns*)))) + (tc-primary-note (parser:node-body-last-node (parser:node-abstraction-body node)) + "Second return is of type '~S'" + (tc:apply-substitution subs body-ty)))))) (let ((ty (tc:make-function-type* arg-tys body-ty))) (handler-case @@ -598,13 +573,9 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)") (alexandria:compose #'parser:node-variable-name #'parser:node-let-binding-name) #'source:location (lambda (first second) - (tc-error first - "Duplicate definition in let" - "first definition here" - (list (se:make-source-error-note - :type :primary - :span (source:location-span (source:location second)) - :message "second definition here"))))) + (tc-error "Duplicate definition in let" + (tc-note first "first definition here") + (tc-primary-note second "second definition here")))) (multiple-value-bind (preds accessors binding-nodes subs) (infer-let-bindings (parser:node-let-bindings node) (parser:node-let-declares node) subs env) @@ -767,21 +738,19 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)") (handler-case (setf subs (tc:unify subs declared-ty expr-ty)) (tc:coalton-internal-type-error () - (tc-error node - "Type mismatch" - (format nil "Declared type '~S' does not match inferred type '~S'" - (tc:apply-substitution subs declared-ty) - (tc:apply-substitution subs expr-ty))))) + (tc-error "Type mismatch" + (tc-note node "Declared type '~S' does not match inferred type '~S'" + (tc:apply-substitution subs declared-ty) + (tc:apply-substitution subs expr-ty))))) ;; Check that declared-ty is not more specific than expr-ty (handler-case (tc:match expr-ty declared-ty) (tc:coalton-internal-type-error () - (tc-error node - "Declared type too general" - (format nil "Declared type '~S' is more general than inferred type '~S'" - (tc:apply-substitution subs declared-ty) - (tc:apply-substitution subs expr-ty))))) + (tc-error "Declared type too general" + (tc-note node "Declared type '~S' is more general than inferred type '~S'" + (tc:apply-substitution subs declared-ty) + (tc:apply-substitution subs expr-ty))))) ;; SAFETY: If declared-ty and expr-ty unify, and expr-ty is ;; more general than declared-ty then matching should be @@ -808,15 +777,13 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)") ;; Returns must be inside a lambda (when (eq *return-status* :toplevel) - (tc-error node - "Unexpected return" - "returns must be inside a lambda")) + (tc-error "Unexpected return" + (tc-note node "returns must be inside a lambda"))) ;; Returns cannot be in a do expression (when (eq *return-status* :do) - (tc-error node - "Invalid return" - "returns cannot be in a do expression")) + (tc-error "Invalid return" + (tc-note node "returns cannot be in a do expression"))) (multiple-value-bind (ty preds accessors expr-node subs) (infer-expression-type (or (parser:node-return-expr node) @@ -876,12 +843,11 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)") :nodes body-nodes) subs)) (tc:coalton-internal-type-error () - (tc-error node - "Type mismatch" - (format nil "Expected type '~S' but 'or' evaluates to '~S'" - (tc:apply-substitution subs expected-type) - tc:*boolean-type*)))))) - + (tc-error "Type mismatch" + (tc-note node "Expected type '~S' but 'or' evaluates to '~S'" + (tc:apply-substitution subs expected-type) + tc:*boolean-type*)))))) + (:method ((node parser:node-and) expected-type subs env) (declare (type tc:ty expected-type) (type tc:substitution-list subs) @@ -917,11 +883,10 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)") :nodes body-nodes) subs)) (tc:coalton-internal-type-error () - (tc-error node - "Type mismatch" - (format nil "Expected type '~S' but 'and' evaluates to '~S'" - (tc:apply-substitution subs expected-type) - tc:*boolean-type*)))))) + (tc-error "Type mismatch" + (tc-note node "Expected type '~S' but 'and' evaluates to '~S'" + (tc:apply-substitution subs expected-type) + tc:*boolean-type*)))))) (:method ((node parser:node-if) expected-type subs env) (declare (type tc:ty expected-type) @@ -1348,11 +1313,10 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)") :location (source:location node)) subs)) (tc:coalton-internal-type-error () - (tc-error node - "Type mismatch" - (format nil "Expected type '~S' but got '~S'" - (tc:apply-substitution subs expected-type) - (tc:apply-substitution subs expr-ty))))))))) + (tc-error "Type mismatch" + (tc-note node "Expected type '~S' but got '~S'" + (tc:apply-substitution subs expected-type) + (tc:apply-substitution subs expr-ty))))))))) (:method ((node parser:node-do) expected-type subs env) (declare (type tc:ty expected-type) @@ -1445,17 +1409,16 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)") :last-node last-node) subs)) (tc:coalton-internal-type-error () - (tc-error node - "Type mismatch" - (format nil "Expected type '~S' but do expression has type '~S'" - (tc:apply-substitution subs expected-type) - (tc:apply-substitution subs ty))))))))) + (tc-error "Type mismatch" + (tc-note node "Expected type '~S' but do expression has type '~S'" + (tc:apply-substitution subs expected-type) + (tc:apply-substitution subs ty))))))))) ;;; ;;; Pattern Type Inference ;;; -(defgeneric infer-pattern-type (pat expected-type subs env) +(defgeneric infer-pattern-type (pat expected-typ subs env) (:documentation "Infer the type of pattern PAT and then unify against EXPECTED-TYPE. Returns (VALUES INFERRED-TYPE NODE SUBSTITUTIONS)") @@ -1506,11 +1469,10 @@ Returns (VALUES INFERRED-TYPE NODE SUBSTITUTIONS)") :value (parser:pattern-literal-value pat)) subs))) (tc:coalton-internal-type-error () - (tc-error pat - "Type mismatch" - (format nil "Expected type '~S' but pattern literal has type '~S'" - (tc:apply-substitution subs expected-type) - (tc:apply-substitution subs ty))))))) + (tc-error "Type mismatch" + (tc-note pat "Expected type '~S' but pattern literal has type '~S'" + (tc:apply-substitution subs expected-type) + (tc:apply-substitution subs ty))))))) (:method ((pat parser:pattern-wildcard) expected-type subs env) (declare (type tc:ty expected-type) @@ -1537,31 +1499,24 @@ Returns (VALUES INFERRED-TYPE NODE SUBSTITUTIONS)") #'parser:pattern-var-name #'source:location (lambda (first second) - (tc-error first - "Duplicate pattern variable" - "first definition here" - (list - (se:make-source-error-note - :type :primary - :span (source:location-span (source:location second)) - :message "second definition here"))))) + (tc-error "Duplicate pattern variable" + (tc-note first "first definition here") + (tc-primary-note second "second definition here")))) (unless ctor - (tc-error pat - "Unknown constructor" - "constructor is not known")) + (tc-error "Unknown constructor" + (tc-note pat "constructor is not known"))) (let ((arity (tc:constructor-entry-arity ctor)) (num-args (length (parser:pattern-constructor-patterns pat)))) (unless (= arity num-args) - (tc-error pat - "Argument mismatch" - (format nil "Constructor ~A takes ~D arguments but is given ~D" - (parser:pattern-constructor-name pat) - arity - num-args))) + (tc-error "Argument mismatch" + (tc-note pat "Constructor ~A takes ~D arguments but is given ~D" + (parser:pattern-constructor-name pat) + arity + num-args))) (let* ((ctor-ty (tc:qualified-ty-type ;; NOTE: Constructors cannot have predicates (tc:fresh-inst @@ -1591,11 +1546,10 @@ Returns (VALUES INFERRED-TYPE NODE SUBSTITUTIONS)") :patterns pattern-nodes) subs))) (tc:coalton-internal-type-error () - (tc-error pat - "Type mismatch" - (format nil "Expected type '~S' but pattern has type '~S'" - (tc:apply-substitution subs expected-type) - (tc:apply-substitution subs pat-ty)))))))))) + (tc-error "Type mismatch" + (tc-note pat "Expected type '~S' but pattern has type '~S'" + (tc:apply-substitution subs expected-type) + (tc:apply-substitution subs pat-ty)))))))))) ;;; ;;; Binding Group Type Inference @@ -1617,17 +1571,12 @@ Returns (VALUES INFERRED-TYPE NODE SUBSTITUTIONS)") :for name := (parser:node-variable-name (parser:node-let-binding-name binding)) :if (gethash name def-table) - :do (tc-error (parser:node-let-binding-name binding) - "Duplicate binding in let" - "second definition here" - (list - (se:make-source-error-note - :type :primary - :span (source:location-span - (source:location - (parser:node-let-binding-name - (gethash name def-table)))) - :message "first definition here"))) + :do (tc-error "Duplicate binding in let" + (tc-note (parser:node-let-binding-name binding) + "second definition here") + (tc-note (parser:node-let-binding-name + (gethash name def-table)) + "first definition here")) :else :do (setf (gethash name def-table) binding)) @@ -1636,17 +1585,12 @@ Returns (VALUES INFERRED-TYPE NODE SUBSTITUTIONS)") :for name := (parser:node-variable-name (parser:node-let-declare-name declare)) :if (gethash name dec-table) - :do (tc-error (parser:node-let-declare-name declare) - "Duplicate declaration in let" - "second declaration here" - (list - (se:make-source-error-note - :type :primary - :span (source:location-span - (source:location - (parser:node-let-declare-name - (gethash name dec-table)))) - :message "first declaration here"))) + :do (tc-error "Duplicate declaration in let" + (tc-note (parser:node-let-declare-name declare) + "second declaration here") + (tc-note (parser:node-let-declare-name + (gethash name dec-table)) + "first declaration here")) :else :do (setf (gethash name dec-table) declare)) @@ -1655,9 +1599,9 @@ Returns (VALUES INFERRED-TYPE NODE SUBSTITUTIONS)") :for name := (parser:node-variable-name (parser:node-let-declare-name declare)) :unless (gethash name def-table) - :do (tc-error (parser:node-let-declare-name declare) - "Orphan declare in let" - "declaration does not have an associated definition")) + :do (tc-error "Orphan declare in let" + (tc-note (parser:node-let-declare-name declare) + "declaration does not have an associated definition"))) (let ((dec-table (loop :with table := (make-hash-table :test #'eq) @@ -1796,9 +1740,9 @@ Returns (VALUES INFERRED-TYPE NODE SUBSTITUTIONS)") (setf subs (tc:compose-substitution-lists subs subs_)) (when accessors - (tc-error (first accessors) - "Ambiguous accessor" - "accessor is ambiguous")) + (tc-error "Ambiguous accessor" + (tc-note (first accessors) + "accessor is ambiguous"))) (let* ((expr-type (tc:apply-substitution subs fresh-type)) (expr-preds (tc:apply-substitution subs fresh-preds)) @@ -1878,20 +1822,19 @@ Returns (VALUES INFERRED-TYPE NODE SUBSTITUTIONS)") ;; Check that the declared and inferred schemes match (unless (equalp declared-ty output-scheme) - (tc-located-error location - "Declared type is too general" - (format nil "Declared type ~S is more general than inferred type ~S." - declared-ty - output-scheme))) + (tc-error "Declared type is too general" + (tc-location location + "Declared type ~S is more general than inferred type ~S." + declared-ty + output-scheme))) ;; Check for undeclared predicates (when (not (null retained-preds)) - (tc-located-error location - "Explicit type is missing inferred predicate" - (with-pprint-variable-context () - (format nil "Declared type ~S is missing inferred predicate ~S" - output-qual-type - (first retained-preds))))) + (tc-error "Explicit type is missing inferred predicate" + (tc-location location + "Declared type ~S is missing inferred predicate ~S" + output-qual-type + (first retained-preds)))) (values deferred-preds (attach-explicit-binding-type (tc:apply-substitution subs binding-node) @@ -1918,14 +1861,12 @@ Returns (VALUES INFERRED-TYPE NODE SUBSTITUTIONS)") (let ((first-fn (find-if #'parser:binding-function-p bindings))) (assert first-fn) - (tc-error (parser:binding-name first-fn) - "Invalid recursive bindings" - "function can not be defined recursively with variables" - (loop :for binding :in (remove first-fn bindings :test #'eq) - :collect (se:make-source-error-note - :type :secondary - :span (source:location-span (source:location (parser:binding-name binding))) - :message "with definition"))))) + (apply #'tc-error + "Invalid recursive bindings" + (tc-note (parser:binding-name first-fn) + "function can not be defined recursively with variables") + (loop :for binding :in (remove first-fn bindings :test #'eq) + :collect (tc-note (parser:binding-name binding) "with definition"))))) ;; If there is a single non-recursive binding then it is valid (when (and (= 1 (length bindings)) @@ -1937,14 +1878,13 @@ Returns (VALUES INFERRED-TYPE NODE SUBSTITUTIONS)") ;; Toplevel bindings cannot be recursive values (when (parser:binding-toplevel-p (first bindings)) - (tc-error (parser:binding-name (first bindings)) - "Invalid recursive bindings" - "invalid recursive variable bindings" - (loop :for binding :in (rest bindings) - :collect (se:make-source-error-note - :type :secondary - :span (source:location-span (source:location (parser:binding-name binding))) - :message "with definition")))) + (apply #'tc-error + "Invalid recursive bindings" + (tc-note (parser:binding-name (first bindings)) + "invalid recursive variable bindings") + (loop :for binding :in (rest bindings) + :collect (tc-note (parser:binding-name binding) + "with definition")))) (let ((binding-names (mapcar (alexandria:compose #'parser:node-variable-name #'parser:binding-name) @@ -2002,14 +1942,11 @@ Returns (VALUES INFERRED-TYPE NODE SUBSTITUTIONS)") (when (every (alexandria:compose #'valid-recursive-constructor-call-p #'parser:binding-value) bindings) (return-from check-for-invalid-recursive-scc)) - (tc-error (parser:binding-name (first bindings)) - "Invalid recursive bindings" - "invalid recursive variable bindings" - (loop :for binding :in (rest bindings) - :collect (se:make-source-error-note - :type :secondary - :span (source:location-span (source:location (parser:binding-name binding))) - :message "with definition")))))) + (apply #'tc-error "Invalid recursive bindings" + (tc-note (parser:binding-name (first bindings)) + "invalid recursive variable bindings") + (loop :for binding :in (rest bindings) + :collect (tc-note (parser:binding-name binding) "with definition")))))) (defun infer-impls-binding-type (bindings subs env) "Infer the type's of BINDINGS and then qualify those types into schemes." @@ -2055,9 +1992,8 @@ Returns (VALUES INFERRED-TYPE NODE SUBSTITUTIONS)") (setf subs (tc:compose-substitution-lists subs subs_)) (when accessors - (tc-error (first accessors) - "Ambiguous accessor" - "accessor is ambiguous")) + (tc-error "Ambiguous accessor" + (tc-note (first accessors) "accessor is ambiguous"))) (let* ((expr-tys (tc:apply-substitution subs expr-tys)) @@ -2190,14 +2126,9 @@ Returns (VALUES INFERRED-TYPE NODE SUBSTITUTIONS)") #'parser:pattern-var-name #'source:location (lambda (first second) - (tc-error first - "Duplicate parameters name" - "first parameter here" - (list (se:make-source-error-note - :type :primary - :span (source:location-span - (source:location second)) - :message "second parameter here"))))) + (tc-error "Duplicate parameters name" + (tc-note first "first parameter here") + (tc-note second "second parameter here")))) (let* ((param-tys (loop :with args := (tc:function-type-arguments expected-type) :for pattern :in (parser:binding-parameters binding) @@ -2245,33 +2176,26 @@ Returns (VALUES INFERRED-TYPE NODE SUBSTITUTIONS)") :do (handler-case (setf subs (tc:unify subs ty1 ty2)) (tc:coalton-internal-type-error () - (tc-located-error s1 - "Return type mismatch" - (format nil "First return is of type '~S'" - (tc:apply-substitution subs ty1)) - (list - (se:make-source-error-note - :type :primary - :span (source:location-span s2) - :message (format nil "Second return is of type '~S'" - (tc:apply-substitution subs ty2)))))))) + (tc-error "Return type mismatch" + (tc-location s1 + "First return is of type '~S'" + (tc:apply-substitution subs ty1)) + (tc-primary-location s2 + "Second return is of type '~S'" + (tc:apply-substitution subs ty2)))))) ;; Unify the function's inferred type with one of the early returns. (when *returns* (handler-case (setf subs (tc:unify subs (cdr (first *returns*)) ret-ty)) (tc:coalton-internal-type-error () - (tc-located-error (car (first *returns*)) - "Return type mismatch" - (format nil "First return is of type '~S'" - (tc:apply-substitution subs (cdr (first *returns*)))) - (list - (se:make-source-error-note - :type :primary - :span (source:location-span - (source:location (parser:binding-last-node binding))) - :message (format nil "Second return is of type '~S'" - (tc:apply-substitution subs ret-ty)))))))) + (tc-error "Return type mismatch" + (tc-location (car (first *returns*)) + "First return is of type '~S'" + (tc:apply-substitution subs (cdr (first *returns*)))) + (tc-primary-note (parser:binding-last-node binding) + "Second return is of type '~S'" + (tc:apply-substitution subs ret-ty)))))) value-node)) @@ -2307,11 +2231,10 @@ Returns (VALUES INFERRED-TYPE NODE SUBSTITUTIONS)") typed-binding subs))) (tc:coalton-internal-type-error () - (tc-error binding - "Type mismatch" - (format nil "Expected type '~S' but got type '~S'" - (tc:apply-substitution subs expected-type) - (tc:apply-substitution subs ty)))))))) + (tc-error "Type mismatch" + (tc-note binding "Expected type '~S' but got type '~S'" + (tc:apply-substitution subs expected-type) + (tc:apply-substitution subs ty)))))))) ;;; ;;; Helpers diff --git a/src/typechecker/parse-type.lisp b/src/typechecker/parse-type.lisp index a037f74f..31250110 100644 --- a/src/typechecker/parse-type.lisp +++ b/src/typechecker/parse-type.lisp @@ -12,7 +12,6 @@ #:coalton-impl/typechecker/base #:coalton-impl/typechecker/partial-type-env) (:local-nicknames - (#:se #:source-error) (#:util #:coalton-impl/util) (#:parser #:coalton-impl/parser) (#:source #:coalton-impl/source) @@ -126,15 +125,14 @@ (unless (subsetp (tc:type-variables preds) unambiguous-vars :test #'equalp) (let* ((ambiguous-vars (set-difference (tc:type-variables preds) unambiguous-vars :test #'equalp)) (single-variable (= 1 (length ambiguous-vars)))) - (tc-error qual-ty - "Invalid qualified type" - (format nil "The type ~A ~{~S ~}ambiguous in the type ~S" - (if single-variable - "variable is" - "variables are") - ambiguous-vars - (tc:make-qualified-ty :predicates preds - :type type))))))) + (tc-error "Invalid qualified type" + (tc-note qual-ty "The type ~A ~{~S ~}ambiguous in the type ~S" + (if single-variable + "variable is" + "variables are") + ambiguous-vars + (tc:make-qualified-ty :predicates preds + :type type))))))) (defun check-for-reducible-context (preds qual-ty env) (declare (type tc:ty-predicate-list preds) @@ -142,12 +140,9 @@ (type tc:environment env)) (let ((reduced-preds (tc:reduce-context env preds nil))) (unless (null (set-exclusive-or preds reduced-preds :test #'tc:type-predicate=)) - (warn 'se:source-base-warning - :err (source:source-error - :type :warn - :location (parser:qualified-ty-location qual-ty) - :message "Declared context can be reduced" - :primary-note (if (null reduced-preds) + (source:warn "Declared context can be reduced" + (source:note (source:location qual-ty) + (if (null reduced-preds) "declared predicates are redundant" (format nil "context can be reduced to ~{ ~S~}" reduced-preds))))))) @@ -173,11 +168,10 @@ (setf ksubs (tc:kunify kvar expected-kind ksubs)) (values (tc:apply-ksubstitution ksubs tvar) ksubs)) (tc:coalton-internal-type-error () - (tc-error type - "Kind mismatch" - (format nil "Expected kind '~S' but variable is of kind '~S'" - expected-kind - kvar)))))) + (tc-error "Kind mismatch" + (tc-note type "Expected kind '~S' but variable is of kind '~S'" + expected-kind + kvar)))))) (:method ((type parser:tycon) expected-kind ksubs env) (declare (type tc:kind expected-kind) @@ -191,11 +185,10 @@ (setf ksubs (tc:kunify (tc:kind-of type_) expected-kind ksubs)) (values (tc:apply-ksubstitution ksubs type_) ksubs)) (tc:coalton-internal-type-error () - (tc-error type - "Kind mismatch" - (format nil "Expected kind '~S' but got kind '~S'" - expected-kind - (tc:kind-of type_))))))) + (tc-error "Kind mismatch" + (tc-note type "Expected kind '~S' but got kind '~S'" + expected-kind + (tc:kind-of type_))))))) (:method ((type parser:tapp) expected-kind ksubs env) (declare (type tc:kind expected-kind) @@ -228,13 +221,12 @@ (tc:apply-type-argument fun-ty arg-ty :ksubs ksubs) ksubs)) (tc:coalton-internal-type-error () - (tc-error (parser:tapp-from type) - "Kind mismatch" - (format nil "Expected kind '~S' but got kind '~S'" - (tc:make-kfun - :from (tc:apply-ksubstitution ksubs arg-kind) - :to (tc:apply-ksubstitution ksubs expected-kind)) - (tc:apply-ksubstitution ksubs fun-kind))))))))) + (tc-error "Kind mismatch" + (tc-note (parser:tapp-from type) "Expected kind '~S' but got kind '~S'" + (tc:make-kfun + :from (tc:apply-ksubstitution ksubs arg-kind) + :to (tc:apply-ksubstitution ksubs expected-kind)) + (tc:apply-ksubstitution ksubs fun-kind))))))))) (:method ((type parser:qualified-ty) expected-kind ksubs env) (declare (type tc:kind expected-kind) @@ -273,11 +265,10 @@ ;; Check that pred has the correct number of arguments (unless (= class-arity (length (parser:ty-predicate-types pred))) - (tc-error pred - "Predicate arity mismatch" - (format nil "Expected ~D arguments but received ~D" - class-arity - (length (parser:ty-predicate-types pred))))) + (tc-error "Predicate arity mismatch" + (tc-note pred "Expected ~D arguments but received ~D" + class-arity + (length (parser:ty-predicate-types pred))))) (let ((types (loop :for ty :in (parser:ty-predicate-types pred) :for class-ty :in (tc:ty-predicate-types class-pred) @@ -289,4 +280,4 @@ ty)))) (values (tc:make-ty-predicate :class class-name :types types) - ksubs)))) + ksubs)))) diff --git a/src/typechecker/partial-type-env.lisp b/src/typechecker/partial-type-env.lisp index 36435e58..eb93274e 100644 --- a/src/typechecker/partial-type-env.lisp +++ b/src/typechecker/partial-type-env.lisp @@ -3,7 +3,6 @@ #:cl #:coalton-impl/typechecker/base) (:local-nicknames - (#:se #:source-error) (#:util #:coalton-impl/util) (#:parser #:coalton-impl/parser) (#:source #:coalton-impl/source) @@ -48,9 +47,8 @@ (values tc:tyvar)) (let ((ty (gethash var (partial-type-env-ty-table env)))) (unless ty - (tc-error source - "Unknown type variable" - (format nil "Unknown type variable ~S" var))) + (tc-error "Unknown type variable" + (tc-note source "Unknown type variable ~S" var))) ty)) (defun partial-type-env-add-type (env name type) @@ -92,9 +90,8 @@ (let ((type-entry (tc:lookup-type (partial-type-env-env env) name :no-error t))) (unless type-entry - (tc-error tycon - "Unknown type" - (format nil "unknown type ~S" (parser:tycon-name tycon)))) + (tc-error "Unknown type" + (tc-note tycon "unknown type ~S" (parser:tycon-name tycon)))) (tc:type-entry-type type-entry)))) @@ -124,10 +121,8 @@ (let ((class-entry (tc:lookup-class (partial-type-env-env env) name :no-error t))) (unless class-entry - (tc-error pred - "Unknown class" - (format nil "unknown class ~S" - (parser:identifier-src-name - (parser:ty-predicate-class pred))))) + (tc-error "Unknown class" + (tc-note pred "unknown class ~S" + (parser:identifier-src-name (parser:ty-predicate-class pred))))) (tc:ty-class-predicate class-entry)))) diff --git a/src/typechecker/specialize.lisp b/src/typechecker/specialize.lisp index b021f2c8..1cfb70fd 100644 --- a/src/typechecker/specialize.lisp +++ b/src/typechecker/specialize.lisp @@ -4,7 +4,6 @@ #:coalton-impl/typechecker/base #:coalton-impl/typechecker/parse-type) (:local-nicknames - (#:se #:source-error) (#:parser #:coalton-impl/parser) (#:tc #:coalton-impl/typechecker/stage-1)) (:export @@ -43,47 +42,44 @@ (tc:qualify nil type)))) (unless from-ty - (tc-error (parser:toplevel-specialize-from specialize) - "Invalid specialization" - "unknown function or variable")) + (tc-error "Invalid specialization" + (tc-note (parser:toplevel-specialize-from specialize) + "unknown function or variable"))) (unless to-ty - (tc-error (parser:toplevel-specialize-to specialize) - "Invalid specialization" - "unknown function or variable")) + (tc-error "Invalid specialization" + (tc-note (parser:toplevel-specialize-to specialize) + "unknown function or variable"))) (unless (eq :value (tc:name-entry-type from-name-entry)) - (tc-error (parser:toplevel-specialize-from specialize) - "Invalid specialization" - (format nil "must be a function or variable, not a ~A" (tc:name-entry-type from-name-entry)))) + (tc-error "Invalid specialization" + (tc-note (parser:toplevel-specialize-from specialize) + "must be a function or variable, not a ~A" (tc:name-entry-type from-name-entry)))) (unless (eq :value (tc:name-entry-type to-name-entry)) - (tc-error (parser:toplevel-specialize-to specialize) - "Invalid specialization" - (format nil "must be a function or variable, not a ~A" (tc:name-entry-type from-name-entry)))) + (tc-error "Invalid specialization" + (tc-note (parser:toplevel-specialize-to specialize) + "must be a function or variable, not a ~A" (tc:name-entry-type from-name-entry)))) (let ((from-qual-ty (tc:fresh-inst from-ty)) (to-qual-ty (tc:fresh-inst to-ty))) (when (null (tc:qualified-ty-predicates from-qual-ty)) - (tc-error (parser:toplevel-specialize-from specialize) - "Invalid specialization" - "must be a function or variable with class constraints")) + (tc-error "Invalid specialization" + (tc-note (parser:toplevel-specialize-from specialize) + "must be a function or variable with class constraints"))) (unless (equalp to-ty scheme) - (tc-error specialize - "Invalid specialization" - (format nil "function ~S does not match declared type" to-name))) + (tc-error "Invalid specialization" + (tc-note specialize "function ~S does not match declared type" to-name))) (when (equalp from-ty to-ty) - (tc-error specialize - "Invalid specialization" - "specialize must result in a more specific type")) + (tc-error "Invalid specialization" + (tc-note specialize "specialize must result in a more specific type"))) (handler-case (tc:match (tc:qualified-ty-type from-qual-ty) (tc:qualified-ty-type to-qual-ty)) (tc:coalton-internal-type-error () - (tc-error specialize - "Invalid specialization" - "cannot specialize to declared type"))) + (tc-error "Invalid specialization" + (tc-note specialize "cannot specialize to declared type")))) (let ((entry (tc:make-specialization-entry :from from-name :to to-name @@ -91,7 +87,6 @@ (handler-case (tc:add-specialization env entry) (tc:overlapping-specialization-error (c) - (tc-error specialize - "Overlapping specialization" - (format nil "overlaps with specialization ~S" + (tc-error "Overlapping specialization" + (tc-note specialize "overlaps with specialization ~S" (tc:overlapping-specialization-error-existing c))))))))) diff --git a/src/typechecker/tc-env.lisp b/src/typechecker/tc-env.lisp index 19be1037..0689a183 100644 --- a/src/typechecker/tc-env.lisp +++ b/src/typechecker/tc-env.lisp @@ -3,7 +3,6 @@ #:cl #:coalton-impl/typechecker/parse-type) (:local-nicknames - (#:se #:source-error) (#:util #:coalton-impl/util) (#:parser #:coalton-impl/parser) (#:source #:coalton-impl/source) @@ -71,16 +70,11 @@ (tc:lookup-value-type (tc-env-env env) var-name :no-error t)))) (unless scheme ;; Variable is unbound: create an error - (error 'tc:tc-error - :err (source:source-error - :location (source:location var) - :message (format nil "Unknown variable ~a" var-name) - :primary-note (format nil "unknown variable ~a" var-name) - :help-notes (loop :for suggestion :in (tc-env-suggest-value env var-name) - :collect (se:make-source-error-help - :span (source:location-span (source:location var)) - :replacement #'identity - :message suggestion))))) + (apply #'tc:tc-error (format nil "Unknown variable ~a" var-name) + (cons (source:note (source:location var) + (format nil "unknown variable ~a" var-name)) + (loop :for suggestion :in (tc-env-suggest-value env var-name) + :collect (source:help (source:location var) #'identity suggestion))))) (let ((qualified-type (tc:fresh-inst scheme))) (values (tc:qualified-ty-type qualified-type) (loop :for pred :in (tc:qualified-ty-predicates qualified-type) diff --git a/tests/parser-test-files/define-class.txt b/tests/parser-test-files/define-class.txt new file mode 100644 index 00000000..697bd6f5 --- /dev/null +++ b/tests/parser-test-files/define-class.txt @@ -0,0 +1,15 @@ +================================================================================ +1 Class name must be a symbol +================================================================================ + +(package test-package) + +(define-class ("C" :a :b)) + +-------------------------------------------------------------------------------- + +error: Malformed class definition + --> test:3:15 + | + 3 | (define-class ("C" :a :b)) + | ^^^ expected symbol diff --git a/tests/parser-tests.lisp b/tests/parser-tests.lisp index f9a7aa41..64d57bc8 100644 --- a/tests/parser-tests.lisp +++ b/tests/parser-tests.lisp @@ -48,4 +48,5 @@ (run-test-file "tests/parser-test-files/struct.txt") (run-test-file "tests/parser-test-files/type-inference.txt") (run-test-file "tests/parser-test-files/unused-variables.txt") - (run-test-file "tests/parser-test-files/define.txt")) + (run-test-file "tests/parser-test-files/define.txt") + (run-test-file "tests/parser-test-files/define-class.txt"))