Skip to content

Commit

Permalink
Use parse-error and tc-error helpers consistently
Browse files Browse the repository at this point in the history 
Use condition helper functions to simplify signaling during parsing
and typechecking

- (form-location source cst) replaces (source:make-location source form) in coalton-impl/parser
- (tc-located-error) becomes (tc-error (tc-location))
  • Loading branch information
@jbouwman
jbouwman committed Sep 27, 2024
1 parent a2ddda1 commit 185c052
Show file tree
Hide file tree
Showing 24 changed files with 1,104 additions and 2,091 deletions.
60 changes: 15 additions & 45 deletions src/analysis/analysis.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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))
Expand All @@ -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."
Expand All @@ -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))
Expand Down Expand Up @@ -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)))
Expand Down
14 changes: 3 additions & 11 deletions src/analysis/underapplied-values.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand All @@ -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))))
27 changes: 7 additions & 20 deletions src/analysis/unused-variables.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)))
Expand Down Expand Up @@ -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"))))))
40 changes: 18 additions & 22 deletions src/entry.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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."
Expand Down
46 changes: 35 additions & 11 deletions src/parser/base.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)

Expand Down Expand Up @@ -89,22 +91,44 @@
;;; 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)
()
(: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)))
Loading

0 comments on commit 185c052

Please sign in to comment.