Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

tc-env-lookup-value: suggest type constructors #1097

Merged
merged 1 commit into from
Jun 3, 2024
+56 −48
Merged

tc-env-lookup-value: suggest type constructors #1097

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Jump to
Jump to file
Failed to load files.
Diff view
Diff view
84 changes: 37 additions & 47 deletions src/typechecker/tc-env.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -30,10 +30,10 @@
(defstruct (tc-env
(:predicate nil))

;; The main copiler env
;; The main compiler env
(env (util:required 'env) :type tc:environment :read-only t)

;; Hash table mappinig variables bound in the current translation unit to types
;; Hash table mapping variables bound in the current translation unit to types
(ty-table (make-hash-table :test #'eq) :type hash-table :read-only t))

(defun tc-env-add-variable (env name)
Expand All @@ -47,57 +47,47 @@

(tc:qualified-ty-type (tc:fresh-inst (setf (gethash name (tc-env-ty-table env)) (tc:to-scheme (tc:make-variable))))))

(defun tc-env-suggest-value (env name)
"If value lookup failed, generate suggestions for what to do, if anything."
(declare (type tc-env env)
(type symbol name)
(values util:string-list &optional))
(let ((suggestions nil))
;; If the symbol names a type, user may have intended to use a type constructor
(let ((type (tc:lookup-type (tc-env-env env) name :no-error t)))
(when type
(push (format nil "Did you mean a constructor of type ~A?" (tc:type-entry-name type))
suggestions)))
(nreverse suggestions)))

(defun tc-env-lookup-value (env var file)
"Lookup a variable named VAR in ENV."
"Lookup the type of a variable named VAR in ENV."
(declare (type tc-env env)
(type parser:node-variable var)
(type coalton-file file)
(values tc:ty tc:ty-predicate-list))


(let* ((scheme (or (gethash (parser:node-variable-name var) (tc-env-ty-table env))

(tc:lookup-value-type (tc-env-env env) (parser:node-variable-name var) :no-error t)

;; Binding is unknown. Create an error.
(let* ((sym-name (symbol-name (parser:node-variable-name var)))
(matches (append
(remove-if-not
(lambda (s) (string= (symbol-name s) sym-name))
(alexandria:hash-table-keys (tc-env-ty-table env)))
(remove-if-not
(lambda (s) (string= (symbol-name s) sym-name))
(coalton-impl/algorithm::immutable-map-keys
(tc:environment-value-environment (tc-env-env env)))))))
(error 'tc-error
:err (coalton-error
:span (parser:node-source var)
:file file
:message "Unknown variable"
:primary-note "unknown variable"
:help-notes (mapcar
(lambda (symbol)
(error:make-coalton-error-help
:span (parser:node-source var)
:replacement (lambda (s)
(declare (ignore s))
(format nil "~S" symbol))
:message (format nil "Did you mean ~S?" symbol)))
matches))))))

(qual-ty (tc:fresh-inst scheme))

(ty (tc:qualified-ty-type qual-ty))

(preds (tc:qualified-ty-predicates qual-ty)))

(values
ty
(loop :for pred :in preds
:collect (tc:make-ty-predicate
:class (tc:ty-predicate-class pred)
:types (tc:ty-predicate-types pred)
:source (parser:node-source var))))))
(let* ((var-name (parser:node-variable-name var))
(scheme (or (gethash var-name (tc-env-ty-table env))
(tc:lookup-value-type (tc-env-env env) var-name :no-error t))))
(unless scheme
;; Variable is unbound: create an error
(error 'tc-error
:err (coalton-error
:span (parser:node-source var)
:file file
:message "Unknown variable"
:primary-note "unknown variable"
:help-notes (loop :for suggestion :in (tc-env-suggest-value env var-name)
:collect (error:make-coalton-error-help :span (parser:node-source var)
:replacement #'identity
:message 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)
:collect (tc:make-ty-predicate :class (tc:ty-predicate-class pred)
:types (tc:ty-predicate-types pred)
:source (parser:node-source var)))))))

(defun tc-env-add-definition (env name scheme)
"Add a type named NAME to ENV."
Expand Down
8 changes: 8 additions & 0 deletions tests/parser-test-files/bad-files/define.8.bad.coalton
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,8 @@
;; BAD: Reference to type instead of constructor
(package test-package)

(define-type DataType
(Data1 Integer))

(define (return-data int)
(DataType int))
8 changes: 8 additions & 0 deletions tests/parser-test-files/bad-files/define.8.bad.error
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,8 @@
error: Unknown variable
--> test:8:3
|
8 | (DataType int))
| ^^^^^^^^ unknown variable
help: Did you mean a constructor of type DATATYPE?
8 | (DataType int))
| --------
4 changes: 3 additions & 1 deletion tests/parser-tests.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -17,7 +17,9 @@
:element-type 'character)
(handler-case
(parser:with-reader-context stream
(parser:read-program stream (error:make-coalton-file :stream stream :name "test") :mode :file))
(entry:entry-point
(parser:read-program stream (error:make-coalton-file :stream stream :name "test") :mode :file))
"no errors")
(error:coalton-base-error (c)
(princ-to-string c))))))
(dolist (file (test-files "tests/parser-test-files/bad/*.coal"))
Expand Down