From 758cf3dd45e1e850a1cd80abf36243ec798740cb Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Mon, 7 Oct 2024 16:39:00 -0700 Subject: [PATCH 01/19] added basic define-alias toplevel form --- src/entry.lisp | 1 + src/faux-macros.lisp | 5 +- src/package.lisp | 1 + src/parser/collect.lisp | 4 ++ src/parser/renamer.lisp | 7 +++ src/parser/toplevel.lisp | 93 ++++++++++++++++++++++++++++++++ src/parser/type-definition.lisp | 26 +++++++-- src/typechecker/define-type.lisp | 40 +++++++++----- src/typechecker/environment.lisp | 74 +++++++++++++++++++++++++ src/typechecker/parse-type.lisp | 33 ++++++++++++ 10 files changed, 265 insertions(+), 19 deletions(-) diff --git a/src/entry.lisp b/src/entry.lisp index 61349d675..fbb30f587 100644 --- a/src/entry.lisp +++ b/src/entry.lisp @@ -38,6 +38,7 @@ (multiple-value-bind (type-definitions instances env) (tc:toplevel-define-type (parser:program-types program) (parser:program-structs program) + (parser:program-aliases program) env) (let ((all-instances (append instances (parser:program-instances program)))) diff --git a/src/faux-macros.lisp b/src/faux-macros.lisp index a2ff9a79d..d10a65ab2 100644 --- a/src/faux-macros.lisp +++ b/src/faux-macros.lisp @@ -33,8 +33,11 @@ (define-coalton-editor-macro coalton:define-type (name &body definition) "Create a new algebraic data type named NAME. (Coalton top-level operator.)") +(define-coalton-editor-macro coalton:define-alias (name &body definition) + "Create a new alias named NAME. (Coalton top-level operator.)") + (define-coalton-editor-macro coalton:define-struct (name &body definition) - "Create a new sruct named NAME. (Coalton top-level operator.)") + "Create a new sruct named NAME. (Coalton top-level operator.)") (define-coalton-editor-macro coalton:declare (var type) "Declare the type of a variable. (Coalton top-level operator.)") diff --git a/src/package.lisp b/src/package.lisp index 8e88261ed..bd65a0ae0 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -23,6 +23,7 @@ #:declare #:define #:define-type + #:define-alias #:define-struct #:define-class #:define-instance diff --git a/src/parser/collect.lisp b/src/parser/collect.lisp index 75a820bb3..010be8777 100644 --- a/src/parser/collect.lisp +++ b/src/parser/collect.lisp @@ -60,6 +60,10 @@ (declare (values tycon-list)) (mapcan #'collect-referenced-types-generic% (toplevel-define-type-ctors type))) + (:method ((alias toplevel-define-alias)) + (declare (values (tycon-list))) + (collect-referenced-types-generic% (toplevel-define-alias-type alias))) + (:method ((field struct-field)) (declare (values tycon-list &optional)) (collect-referenced-types-generic% (struct-field-type field))) diff --git a/src/parser/renamer.lisp b/src/parser/renamer.lisp index 5656e8bbb..09a5ca31b 100644 --- a/src/parser/renamer.lisp +++ b/src/parser/renamer.lisp @@ -516,6 +516,7 @@ (make-program :package (program-package program) :types (rename-type-variables (program-types program)) + :aliases (rename-type-variables (program-aliases program)) :structs (rename-type-variables (program-structs program)) :declares (program-declares program) :defines (rename-variables-generic% (program-defines program) ctx) @@ -627,6 +628,12 @@ :repr (toplevel-define-type-repr toplevel) :head-location (toplevel-define-type-head-location toplevel)))) + (:method ((toplevel toplevel-define-alias) ctx) + (declare (type algo:immutable-map ctx) + (values toplevel-define-alias)) + + toplevel) + (:method ((field struct-field) ctx) (declare (type algo:immutable-map ctx) (values struct-field)) diff --git a/src/parser/toplevel.lisp b/src/parser/toplevel.lisp index 9d817457c..402f89a11 100644 --- a/src/parser/toplevel.lisp +++ b/src/parser/toplevel.lisp @@ -38,6 +38,12 @@ #:toplevel-define-type-repr ; ACCESSOR #:toplevel-define-type-head-location ; ACCESSOR #:toplevel-define-type-list ; TYPE + #:toplevel-define-alias ; STRUCT + #:toplevel-make-toplevel-define-alias ; CONSTRUCTOR + #:toplevel-define-alias-name ; ACCESSOR + #:toplevel-define-alias-type ; ACCESSOR + #:toplevel-define-alias-head-location ; ACCESSOR + #:toplevel-define-alias-list ; TYPE #:struct-field ; STRUCT #:make-struct-field ; CONSTRUCTOR #:struct-field-name ; ACCESSOR @@ -114,6 +120,7 @@ #:program-package ; ACCESSOR #:program-lisp-forms ; ACCESSOR #:program-types ; ACCESSOR + #:program-aliases ; ACCESSOR #:program-structs ; ACCESSOR #:program-declares ; ACCESSOR #:program-defines ; ACCESSOR @@ -171,6 +178,8 @@ ;;;; toplevel-define-type := "(" "define-type" identifier docstring? constructor* ")" ;;;; | "(" "define-type" "(" identifier keyword+ ")" docstring? constructor* ")" ;;;; +;;;; toplevel-define-alias := "(" "define-alias" identifier type docstring? ")" +;;;; ;;;; struct-field := "(" identifier docstring? type ")" ;;;; ;;;; toplevel-define-struct := "(" "define-struct" identifier docstring? struct-field* ")" @@ -267,6 +276,21 @@ (deftype toplevel-define-type-list () '(satisfies toplevel-define-type-list-p)) +(defstruct (toplevel-define-alias + (:include toplevel-definition) + (:copier :nil)) + (name (util:required 'name) :type identifier-src :read-only t) + (type (util:required 'type) :type ty :read-only t) + (head-location (util:required 'head-location) :type source:location :read-only t)) + +(eval-when (:load-toplevel :compile-toplevel :execute) + (defun toplevel-define-alias-list-p (x) + (and (alexandria:proper-list-p x) + (every #'toplevel-define-alias-p x)))) + +(deftype toplevel-define-alias-list () + '(satisfies toplevel-define-alias-list-p)) + (defstruct (struct-field (:include toplevel-definition) (:copier nil)) @@ -468,6 +492,7 @@ (defstruct program (package nil :type (or null toplevel-package) :read-only t) (types nil :type toplevel-define-type-list :read-only nil) + (aliases nil :type toplevel-define-alias-list :read-only nil) (structs nil :type toplevel-define-struct-list :read-only nil) (declares nil :type toplevel-declare-list :read-only nil) (defines nil :type toplevel-define-list :read-only nil) @@ -522,6 +547,7 @@ If MODE is :macro, a package form is forbidden, and an explicit check is made fo "attribute must be attached to another form"))) (setf (program-types program) (nreverse (program-types program))) + (setf (program-aliases program) (nreverse (program-aliases program))) (setf (program-structs program) (nreverse (program-structs program))) (setf (program-declares program) (nreverse (program-declares program))) (setf (program-defines program) (nreverse (program-defines program))) @@ -874,6 +900,27 @@ If the outermost form matches (eval-when (compile-toplevel) ..), evaluate the en (push type (program-types program)) t)) + ((coalton:define-alias) + (let* ((alias (parse-define-alias form source))) + + (loop :for (attribute . attribute-form) :across attributes + :do (etypecase attribute + (attribute-repr + (parse-error "Invalid target for repr attribute" + (note source attribute-form + "repr must be attached to a define-type") + (source:note alias "when parsing define-alias"))) + + (attribute-monomorphize + (parse-error "Invalid target for monomorphize attribute" + (note source attribute-form + "monomorphize must be attached to a define or declare form") + (source:note alias "when parsing define-alias"))))) + + (setf (fill-pointer attributes) 0) + (push alias (program-aliases program)) + t)) + ((coalton:define-struct) (let ((struct (parse-define-struct form source)) @@ -1188,6 +1235,52 @@ consume all attributes"))) :location (form-location source form) :head-location (form-location source (cst:second form))))) +(defun parse-define-alias (form source) + (declare (type cst:cst form) + (values toplevel-define-alias)) + + (assert (cst:consp form)) + + (let ((docstring)) + + ;; (define-alias) + (unless (cst:consp (cst:rest form)) + (parse-error "Malformed alias definition" + (note source form "expected body"))) + + ;; (define-alias alias) + (unless (cst:consp (cst:rest (cst:rest form))) + (parse-error "Malformed alias definition" + (note source form "expected type"))) + + ;; (define-alias alias type docstring) + (when (and (cst:consp (cst:nthrest 3 form)) + (cst:atom (cst:fourth form)) + (stringp (cst:raw (cst:fourth form)))) + (setf docstring (cst:raw (cst:fourth form)))) + + ;; (define-alias alias type docstring ...) + (when (and docstring + (cst:consp (cst:nthrest 4 form))) + (parse-error "Malformed alias definition" + (note source (cst:fifth form) + "unexpected trailing form"))) + + ;; (define-alias 0.5 type) + (unless (identifierp (cst:raw (cst:second form))) + (parse-error "Malformed define-alias" + (note source (cst:second form) + "expected symbol"))) + + (make-toplevel-define-alias + :name (make-identifier-src + :name (cst:raw (cst:second form)) + :location (form-location source (cst:second form))) + :type (parse-type (cst:third form) source) + :docstring docstring + :location (form-location source form) + :head-location (form-location source (cst:second form))))) + (defun parse-define-struct (form source) (declare (type cst:cst form)) diff --git a/src/parser/type-definition.lisp b/src/parser/type-definition.lisp index e4076cc94..93c0bf0ea 100644 --- a/src/parser/type-definition.lisp +++ b/src/parser/type-definition.lisp @@ -29,7 +29,7 @@ (in-package #:coalton-impl/parser/type-definition) (deftype type-definition () - '(or toplevel-define-type toplevel-define-struct)) + '(or toplevel-define-type toplevel-define-struct toplevel-define-alias)) (defun type-definition-p (x) (typep x 'type-definition)) @@ -48,7 +48,11 @@ (:method ((def toplevel-define-struct)) (declare (values identifier-src)) - (toplevel-define-struct-name def))) + (toplevel-define-struct-name def)) + + (:method ((def toplevel-define-alias)) + (declare (values identifier-src)) + (toplevel-define-alias-name def))) (defgeneric type-definition-vars (def) (:method ((def toplevel-define-type)) @@ -57,7 +61,11 @@ (:method ((def toplevel-define-struct)) (declare (values keyword-src-list)) - (toplevel-define-struct-vars def))) + (toplevel-define-struct-vars def)) + + (:method ((def toplevel-define-alias)) + (declare (values keyword-src-list)) + (list))) (defgeneric type-definition-repr (def) (:method ((def toplevel-define-type)) @@ -66,7 +74,11 @@ (:method ((def toplevel-define-struct)) (declare (values (or null attribute-repr))) - (toplevel-define-struct-repr def))) + (toplevel-define-struct-repr def)) + + (:method ((def toplevel-define-alias)) + (declare (values (or null attribute-repr))) + nil)) (defgeneric type-definition-ctors (def) (:method ((def toplevel-define-type)) @@ -75,7 +87,11 @@ (:method ((def toplevel-define-struct)) (declare (values toplevel-define-struct-list)) - (list def))) + (list def)) + + (:method ((def toplevel-define-alias)) + (declare (values null)) + nil)) (defgeneric type-definition-ctor-name (ctor) (:method ((ctor constructor)) diff --git a/src/typechecker/define-type.lisp b/src/typechecker/define-type.lisp index 35d08adaf..14dbf3d2f 100644 --- a/src/typechecker/define-type.lisp +++ b/src/typechecker/define-type.lisp @@ -76,14 +76,15 @@ (deftype type-definition-list () '(satisfies type-definition-list-p)) -(defun toplevel-define-type (types structs env) +(defun toplevel-define-type (types structs aliases env) (declare (type parser:toplevel-define-type-list types) (type parser:toplevel-define-struct-list structs) + (type parser:toplevel-define-alias-list aliases) (type tc:environment env) (values type-definition-list parser:toplevel-define-instance-list tc:environment)) ;; Ensure that all types are defined in the current package - (check-package (append types structs) + (check-package (append types structs aliases) (alexandria:compose #'parser:identifier-src-name #'parser:type-definition-name) (alexandria:compose #'source:location @@ -99,7 +100,7 @@ ;; Ensure that there are no duplicate type definitions (check-duplicates - (append types structs) + (append types structs aliases) (alexandria:compose #'parser:identifier-src-name #'parser:type-definition-name) #'source:location (lambda (first second) @@ -111,7 +112,7 @@ ;; NOTE: structs define a constructor with the same name (check-duplicates (mapcan (alexandria:compose #'copy-list #'parser:type-definition-ctors) - (append types structs)) + (append types structs aliases)) (alexandria:compose #'parser:identifier-src-name #'parser:type-definition-ctor-name) #'source:location (lambda (first second) @@ -120,7 +121,7 @@ (tc:tc-primary-note second "second definition here")))) ;; Ensure that no type has duplicate type variables - (loop :for type :in (append types structs) + (loop :for type :in (append types structs aliases) :do (check-duplicates (parser:type-definition-vars type) #'parser:keyword-src-name @@ -132,10 +133,10 @@ (let* ((type-names (mapcar (alexandria:compose #'parser:identifier-src-name #'parser:type-definition-name) - (append types structs))) + (append types structs aliases))) (type-dependencies - (loop :for type :in (append types structs) + (loop :for type :in (append types structs aliases) :for referenced-types := (parser:collect-referenced-types type) :collect (list* (parser:identifier-src-name (parser:type-definition-name type)) @@ -145,7 +146,7 @@ (type-table (loop :with table := (make-hash-table :test #'eq) - :for type :in (append types structs) + :for type :in (append types structs aliases) :for type-name := (parser:identifier-src-name (parser:type-definition-name type)) :do (setf (gethash type-name table) type) :finally (return table))) @@ -174,7 +175,9 @@ :collect (tc:kind-of (partial-type-env-add-var partial-env var))) :for kind := (tc:make-kind-function* kvars tc:+kstar+) - :for ty := (tc:make-tycon :name name :kind kind) + :for ty := (if (not (typep type 'parser:toplevel-define-alias)) + (tc:make-tycon :name name :kind kind) + (parse-type (parser:toplevel-define-alias-type type) env)) :do (partial-type-env-add-type partial-env name ty)) :append (multiple-value-bind (type-definitions instances_ ksubs) @@ -216,6 +219,17 @@ (when (plusp (tc:constructor-entry-arity ctor-entry)) (setf env (tc:unset-function env constructor)))))) + (cond ((typep parsed-type 'parser:toplevel-define-alias) + (setf env (tc:set-alias + env + (type-definition-name type) + (tc:make-alias-entry + :name (type-definition-name type) + :type (parse-type (parser:toplevel-define-alias-type parsed-type) env) + :docstring nil)))) + ((tc:lookup-alias env (type-definition-name type) :no-error t) + (setf env (tc:unset-alias env (type-definition-name type))))) + (cond ((typep parsed-type 'parser:toplevel-define-struct) (let ((fields (loop :for field :in (parser:toplevel-define-struct-fields parsed-type) @@ -319,7 +333,7 @@ (loop :for type :in types :for name := (parser:identifier-src-name (parser:type-definition-name type)) :for ty := (gethash name (partial-type-env-ty-table env)) - :for kind := (tc:apply-ksubstitution ksubs (tc:tycon-kind ty)) + :for kind := (tc:apply-ksubstitution ksubs (tc:kind-of ty)) :do (setf ksubs (tc:kind-monomorphize-subs (tc:kind-variables kind) ksubs)) :do (partial-type-env-replace-type env name (tc:make-tycon :name name @@ -356,9 +370,9 @@ :collect (tc:quantify-using-tvar-order tvars (tc:qualify nil ty))) :for constructor-args - := (loop :for ctor :in (parser:type-definition-ctors type) - :for ctor-name := (parser:identifier-src-name (parser:type-definition-ctor-name ctor)) - :collect (tc:apply-ksubstitution ksubs (gethash ctor-name ctor-table))) + := (loop :for ctor :in (parser:type-definition-ctors type) + :for ctor-name := (parser:identifier-src-name (parser:type-definition-ctor-name ctor)) + :collect (tc:apply-ksubstitution ksubs (gethash ctor-name ctor-table))) ;; Check that repr :enum types do not have any constructors with fields :when (eq repr-type :enum) diff --git a/src/typechecker/environment.lisp b/src/typechecker/environment.lisp index 30df42067..d0bfbb5e5 100644 --- a/src/typechecker/environment.lisp +++ b/src/typechecker/environment.lisp @@ -49,6 +49,12 @@ #:constructor-entry-compressed-repr ; ACCESSOR #:constructor-entry-list ; TYPE #:constructor-environment ; STRUCT + #:alias-entry + #:make-alias-entry + #:alias-entry-name + #:alias-entry-type + #:alias-entry-list + #:alias-environment #:struct-field ; STRUCT #:make-struct-field ; CONSTRUCTOR #:struct-field-name ; ACCESSOR @@ -112,6 +118,7 @@ #:make-default-environment ; FUNCTION #:environment-value-environment ; ACCESSOR #:environment-type-environment ; ACCESSOR + #:environment-alias-environment ; ACCESSOR #:environment-constructor-environment ; ACCESSOR #:environment-class-environment ; ACCESSOR #:environment-fundep-environment ; ACCESSOR @@ -129,6 +136,9 @@ #:lookup-constructor ; FUNCTION #:set-constructor ; FUNCTION #:unset-constructor ; FUNCTION + #:lookup-alias ; FUNCTION + #:set-alias ; FUNCTION + #:unset-alias ; FUNCTION #:lookup-struct ; FUNCTION #:set-struct ; FUNCTION #:unset-struct ; FUNCTION @@ -498,6 +508,36 @@ #+(and sbcl coalton-release) (declaim (sb-ext:freeze-type constructor-environment)) +;;; +;;; Alias environment +;;; + +(defstruct alias-entry + (name (util:required 'name) :type symbol) + (type (util:required 'type) :type ty) + (docstring (util:required 'docstring) :type (or null string))) + +(defmethod source:docstring ((self alias-entry)) + (alias-entry-docstring self)) + +(defmethod make-load-form ((self alias-entry) &optional env) + (make-load-form-saving-slots self :environment env)) + +#+(and sbcl coalton-release) +(declaim sb-ext:freeze-type alias-entry) + +(defun alias-entry-list-p (x) + (and (alexandria:proper-list-p x) + (every #'alias-entry-p x))) + +(deftype alias-entry-list () + '(satisfies alias-entry-list-p)) + +(defstruct (alias-environment (:include immutable-map))) + +#+(and sbcl coalton-release) +(declaim (sb-ext:freeze-type alias-environment)) + ;;; ;;; Struct environment ;;; @@ -802,6 +842,7 @@ (value-environment (util:required 'value-environment) :type value-environment :read-only t) (type-environment (util:required 'type-environment) :type type-environment :read-only t) (constructor-environment (util:required 'constructor-environment) :type constructor-environment :read-only t) + (alias-environment (util:required 'alias-environment) :type alias-environment :read-only t) (struct-environment (util:required 'struct-environment) :type struct-environment :read-only t) (class-environment (util:required 'class-environment) :type class-environment :read-only t) (fundep-environment (util:required 'fundep-environment) :type fundep-environment :read-only t) @@ -830,6 +871,7 @@ (make-environment :value-environment (make-value-environment) :type-environment (make-default-type-environment) + :alias-environment (make-alias-environment) :struct-environment (make-struct-environment) :constructor-environment (make-default-constructor-environment) :class-environment (make-class-environment) @@ -846,6 +888,7 @@ &key (value-environment (environment-value-environment env)) (type-environment (environment-type-environment env)) + (alias-environment (environment-alias-environment env)) (constructor-environment (environment-constructor-environment env)) (struct-environment (environment-struct-environment env)) (class-environment (environment-class-environment env)) @@ -860,6 +903,7 @@ (declare (type environment env) (type value-environment value-environment) (type constructor-environment constructor-environment) + (type alias-environment alias-environment) (type struct-environment struct-environment) (type class-environment class-environment) (type fundep-environment fundep-environment) @@ -875,6 +919,7 @@ :value-environment value-environment :type-environment type-environment :constructor-environment constructor-environment + :alias-environment alias-environment :struct-environment struct-environment :class-environment class-environment :fundep-environment fundep-environment @@ -990,6 +1035,35 @@ symbol #'make-constructor-environment))) +(defun lookup-alias (env symbol &key no-error) + (declare (type environment env) + (type symbol symbol)) + (or (immutable-map-lookup (environment-alias-environment env) symbol) + (unless no-error + (util:coalton-bug "Unknown alias ~S" symbol)))) + +(define-env-updater set-alias (env symbol value) + (declare (type environment env) + (type symbol symbol) + (type alias-entry value)) + (update-environment + env + :alias-environment (immutable-map-set + (environment-alias-environment env) + symbol + value + #'make-alias-environment))) + +(define-env-updater unset-alias (env symbol) + (declare (type environment env) + (type symbol symbol)) + (update-environment + env + :alias-environment (immutable-map-remove + (environment-alias-environment env) + symbol + #'make-alias-environment))) + (defun lookup-struct (env symbol &key no-error) (declare (type environment env) (type symbol symbol)) diff --git a/src/typechecker/parse-type.lisp b/src/typechecker/parse-type.lisp index 270fcde43..6f63d2872 100644 --- a/src/typechecker/parse-type.lisp +++ b/src/typechecker/parse-type.lisp @@ -30,6 +30,35 @@ ;;; Entrypoints ;;; +(defgeneric apply-alias-substitutions (ty env) + (:documentation "Replace aliases in TY with their underlying types.") + + (:method ((ty tc:tyvar) env) + (declare (ignore env) + (values tc:tyvar)) + ty) + + (:method ((ty tc:tycon) env) + (declare (type tc:environment env) + (values tc:ty)) + + (let ((alias (tc:lookup-alias env (tc:tycon-name ty) :no-error t))) + (when alias + (setf ty (tc:alias-entry-type alias))) + ty)) + + (:method ((ty tc:tapp) env) + (declare (type tc:environment env) + (values tc:tapp)) + (tc:make-tapp + :from (apply-alias-substitutions (tc:tapp-from ty) env) + :to (apply-alias-substitutions (tc:tapp-to ty) env))) + + (:method ((ty tc:tgen) env) + (declare (ignore env) + (values tc:tgen)) + ty)) + (defun parse-type (ty env) (declare (type parser:ty ty) (type tc:environment env) @@ -50,6 +79,7 @@ partial-env) (setf ty (tc:apply-ksubstitution ksubs ty)) + (setf ty (apply-alias-substitutions ty env)) (setf ksubs (tc:kind-monomorphize-subs (tc:kind-variables ty) ksubs)) (tc:apply-ksubstitution ksubs ty)))) @@ -70,6 +100,9 @@ (infer-type-kinds unparsed-ty tc:+kstar+ nil partial-env) (setf qual-ty (tc:apply-ksubstitution ksubs qual-ty)) + (setf qual-ty (tc:make-qualified-ty + :predicates (tc:qualified-ty-predicates qual-ty) + :type (apply-alias-substitutions (tc:qualified-ty-type qual-ty) env))) (setf ksubs (tc:kind-monomorphize-subs (tc:kind-variables qual-ty) ksubs)) (let* ((qual-ty (tc:apply-ksubstitution ksubs qual-ty)) From a125e4adaf45aa2430bd6d32d7e39ac91f03f726 Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Tue, 8 Oct 2024 09:51:35 -0700 Subject: [PATCH 02/19] fixed alias substitution for constructors and struct-fields --- src/typechecker/define-type.lisp | 2 +- src/typechecker/parse-type.lisp | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/src/typechecker/define-type.lisp b/src/typechecker/define-type.lisp index 14dbf3d2f..9757ec2ae 100644 --- a/src/typechecker/define-type.lisp +++ b/src/typechecker/define-type.lisp @@ -326,7 +326,7 @@ :collect (multiple-value-bind (type ksubs_) (infer-type-kinds field tc:+kstar+ ksubs env) (setf ksubs ksubs_) - type)) + (apply-alias-substitutions type (partial-type-env-env env)))) :do (setf (gethash ctor-name ctor-table) fields))) ;; Redefine types with final inferred kinds in the environment diff --git a/src/typechecker/parse-type.lisp b/src/typechecker/parse-type.lisp index 6f63d2872..ee1553d4b 100644 --- a/src/typechecker/parse-type.lisp +++ b/src/typechecker/parse-type.lisp @@ -17,6 +17,7 @@ (#:source #:coalton-impl/source) (#:tc #:coalton-impl/typechecker/stage-1)) (:export + #:apply-alias-substitutions ; FUNCTION #:parse-type ; FUNCTION #:parse-qualified-type ; FUNCTION #:parse-ty-scheme ; FUNCTION From 074488b4800a51948a388fb35bcc4ef31cd758f1 Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Tue, 8 Oct 2024 10:27:56 -0700 Subject: [PATCH 03/19] added alias tests --- coalton.asd | 1 + tests/alias-tests.lisp | 75 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 76 insertions(+) create mode 100644 tests/alias-tests.lisp diff --git a/coalton.asd b/coalton.asd index 625e80bdb..53163f63f 100644 --- a/coalton.asd +++ b/coalton.asd @@ -255,6 +255,7 @@ (:file "recursive-let-tests") (:file "class-tests") (:file "struct-tests") + (:file "alias-tests") (:file "list-tests") (:file "red-black-tests") (:file "seq-tests") diff --git a/tests/alias-tests.lisp b/tests/alias-tests.lisp new file mode 100644 index 000000000..ae9ed500e --- /dev/null +++ b/tests/alias-tests.lisp @@ -0,0 +1,75 @@ +;;;; alias-tests.lisp + +(in-package #:coalton-tests) + +(deftest test-alias-definition () + (check-coalton-types + "(define-alias UnaryIntegerOperator (Integer -> Integer))") + + (check-coalton-types + "(define-alias UnaryIntegerOperator (Integer -> Integer) + \"An alias for functions mapping integers to integers.\")")) + +(deftest test-alias-the () + (check-coalton-types + "(define-alias Index UFix) + + (define i (the Index 5))" + + '("i" . "UFix")) + + (check-coalton-types + "(define-alias Index UFix) + (define-alias IndexList (List Index)) + + (define indices (the IndexList (make-list 0 1 2 3 4 5)))" + + '("indices" . "(List UFix)"))) + +(deftest test-alias-declare () + (check-coalton-types + "(define-alias Index UFix) + + (declare i Index) + (define i 5)" + + '("i" . "UFix")) + + (check-coalton-types + "(define-alias Index UFix) + (define-alias IndexList (List Index)) + + (declare indices IndexList) + (define indices (make-list 0 1 2 3 4 5))" + + '("indices" . "(List UFix)"))) + +(deftest test-alias-constructors () + (check-coalton-types + "(define-alias Coordinate IFix) + + (define-type Point + (Point Coordinate Coordinate)) + + (declare get-x-coordinate (Point -> Coordinate)) + (define (get-x-coordinate (Point x _)) x) + + (define p (Point 2 5)) + (define x (get-x-coordinate p))" + + '("get-x-coordinate" . "(Point -> IFix)") + '("p" . "Point") + '("x" . "IFix")) + + (check-coalton-types + "(define-alias Coordinate IFix) + + (define-struct Point + (x Coordinate) + (y Coordinate)) + + (define p (Point 2 5)) + (define x (.x p))" + + '("p" . "Point") + '("x" . "IFix"))) From 688322ced0abafb1a8b1a2c019915ea8cb38414a Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Tue, 8 Oct 2024 16:10:43 -0700 Subject: [PATCH 04/19] improved alias error messages --- src/faux-macros.lisp | 2 +- src/typechecker/define-type.lisp | 13 +++--- src/typechecker/define.lisp | 3 +- src/typechecker/parse-type.lisp | 1 + src/typechecker/predicate.lisp | 7 +++ src/typechecker/scheme.lisp | 7 +++ src/typechecker/substitutions.lisp | 1 + src/typechecker/types.lisp | 72 +++++++++++++++++++++++++++++- src/typechecker/unify.lisp | 7 ++- tests/utilities.lisp | 2 +- 10 files changed, 102 insertions(+), 13 deletions(-) diff --git a/src/faux-macros.lisp b/src/faux-macros.lisp index d10a65ab2..b14b0a656 100644 --- a/src/faux-macros.lisp +++ b/src/faux-macros.lisp @@ -37,7 +37,7 @@ "Create a new alias named NAME. (Coalton top-level operator.)") (define-coalton-editor-macro coalton:define-struct (name &body definition) - "Create a new sruct named NAME. (Coalton top-level operator.)") + "Create a new sruct named NAME. (Coalton top-level operator.)") (define-coalton-editor-macro coalton:declare (var type) "Declare the type of a variable. (Coalton top-level operator.)") diff --git a/src/typechecker/define-type.lisp b/src/typechecker/define-type.lisp index 9757ec2ae..15985e91a 100644 --- a/src/typechecker/define-type.lisp +++ b/src/typechecker/define-type.lisp @@ -220,13 +220,16 @@ (setf env (tc:unset-function env constructor)))))) (cond ((typep parsed-type 'parser:toplevel-define-alias) - (setf env (tc:set-alias + (let ((name (type-definition-name type)) + (alias-type (parse-type (parser:toplevel-define-alias-type parsed-type) env))) + (setf (tc:ty-alias alias-type) name) + (setf env (tc:set-alias env - (type-definition-name type) + name (tc:make-alias-entry - :name (type-definition-name type) - :type (parse-type (parser:toplevel-define-alias-type parsed-type) env) - :docstring nil)))) + :name name + :type alias-type + :docstring nil))))) ((tc:lookup-alias env (type-definition-name type) :no-error t) (setf env (tc:unset-alias env (type-definition-name type))))) diff --git a/src/typechecker/define.lisp b/src/typechecker/define.lisp index 9e781d667..08e7b036a 100644 --- a/src/typechecker/define.lisp +++ b/src/typechecker/define.lisp @@ -761,7 +761,8 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)") (progn (setf subs (tc:unify subs expr-ty expected-type)) (values - (tc:apply-substitution subs expr-ty) + (tc:with-aliases-from declared-ty + (tc:apply-substitution subs expr-ty)) preds accessors expr-node diff --git a/src/typechecker/parse-type.lisp b/src/typechecker/parse-type.lisp index ee1553d4b..303641895 100644 --- a/src/typechecker/parse-type.lisp +++ b/src/typechecker/parse-type.lisp @@ -52,6 +52,7 @@ (declare (type tc:environment env) (values tc:tapp)) (tc:make-tapp + :alias (tc:ty-alias ty) :from (apply-alias-substitutions (tc:tapp-from ty) env) :to (apply-alias-substitutions (tc:tapp-to ty) env))) diff --git a/src/typechecker/predicate.lisp b/src/typechecker/predicate.lisp index 72a1defb5..a61d46fa9 100644 --- a/src/typechecker/predicate.lisp +++ b/src/typechecker/predicate.lisp @@ -19,6 +19,7 @@ #:make-qualified-ty ; CONSTRUCTOR #:qualified-ty-predicates ; ACCESSOR #:qualified-ty-type ; ACCESSOR + #:qualified-ty= ; FUNCTION #:qualified-ty-list ; TYPE #:remove-source-info ; FUNCTION #:static-predicate-p ; FUNCTION @@ -69,6 +70,12 @@ (predicates (util:required 'predicates) :type ty-predicate-list :read-only t) (type (util:required 'type) :type ty :read-only t)) +(defun qualified-ty= (qualified-ty1 qualified-ty2) + (and (equalp (qualified-ty-predicates qualified-ty1) + (qualified-ty-predicates qualified-ty2)) + (ty= (qualified-ty-type qualified-ty1) + (qualified-ty-type qualified-ty2)))) + (defmethod make-load-form ((self qualified-ty) &optional env) (make-load-form-saving-slots self :environment env)) diff --git a/src/typechecker/scheme.lisp b/src/typechecker/scheme.lisp index 1fab6775f..de5fbf34e 100644 --- a/src/typechecker/scheme.lisp +++ b/src/typechecker/scheme.lisp @@ -14,6 +14,7 @@ #:make-ty-scheme ; CONSTRUCTOR #:ty-scheme-kinds ; ACCESSOR #:ty-scheme-type ; ACCESSOR + #:ty-scheme= ; FUNCTION #:ty-scheme-p ; FUNCTION #:scheme-list ; TYPE #:scheme-binding-list ; TYPE @@ -36,6 +37,12 @@ (kinds (util:required 'kinds) :type list :read-only t) (type (util:required 'type) :type qualified-ty :read-only t)) +(defun ty-scheme= (ty-scheme1 ty-scheme2) + (and (equalp (ty-scheme-kinds ty-scheme1) + (ty-scheme-kinds ty-scheme2)) + (qualified-ty= (ty-scheme-type ty-scheme1) + (ty-scheme-type ty-scheme2)))) + (defmethod make-load-form ((self ty-scheme) &optional env) (make-load-form-saving-slots self :environment env)) diff --git a/src/typechecker/substitutions.lisp b/src/typechecker/substitutions.lisp index 455b3f9af..5085503ed 100644 --- a/src/typechecker/substitutions.lisp +++ b/src/typechecker/substitutions.lisp @@ -74,6 +74,7 @@ ;; For a type application, recurse down into all the types (:method (subst-list (type tapp)) (make-tapp + :alias (ty-alias type) :from (apply-substitution subst-list (tapp-from type)) :to (apply-substitution subst-list (tapp-to type)))) ;; Otherwise, do nothing diff --git a/src/typechecker/types.lisp b/src/typechecker/types.lisp index fff5a4797..12517542d 100644 --- a/src/typechecker/types.lisp +++ b/src/typechecker/types.lisp @@ -8,6 +8,8 @@ (#:settings #:coalton-impl/settings)) (:export #:ty ; STRUCT + #:ty-alias ; ACCESSOR + #:ty= ; FUNCTION #:ty-list ; TYPE #:tyvar ; STRUCT #:make-tyvar ; CONSTRUCTOR @@ -34,6 +36,7 @@ #:instantiate ; FUNCTION #:kind-of ; FUNCTION #:type-constructors ; FUNCTION + #:with-aliases-from ; FUNCTION #:*boolean-type* ; VARIABLE #:*unit-type* ; VARIABLE #:*char-type* ; VARIABLE @@ -71,7 +74,8 @@ ;;; Types ;;; -(defstruct (ty (:constructor nil))) +(defstruct (ty (:constructor nil)) + (alias nil :type (or null symbol) :read-only nil)) (defmethod make-load-form ((self ty) &optional env) (make-load-form-saving-slots self :environment env)) @@ -133,6 +137,7 @@ (defgeneric instantiate (types type) (:method (types (type tapp)) (make-tapp + :alias (ty-alias type) :from (instantiate types (tapp-from type)) :to (instantiate types (tapp-to type)))) (:method (types (type tgen)) @@ -156,16 +161,19 @@ (defmethod apply-ksubstitution (subs (type tyvar)) (make-tyvar + :alias (ty-alias type) :id (tyvar-id type) :kind (apply-ksubstitution subs (tyvar-kind type)))) (defmethod apply-ksubstitution (subs (type tycon)) (make-tycon + :alias (ty-alias type) :name (tycon-name type) :kind (apply-ksubstitution subs (tycon-kind type)))) (defmethod apply-ksubstitution (subs (type tapp)) (make-tapp + :alias (ty-alias type) :from (apply-ksubstitution subs (tapp-from type)) :to (apply-ksubstitution subs (tapp-to type)))) @@ -199,6 +207,64 @@ (:method ((lst list)) (mapcan #'type-constructors-generic% lst))) +(defgeneric with-aliases-from (type1 type2) + (:documentation "For equal types, apply the aliases in TYPE1 to TYPE2.") + + (:method ((type1 tyvar) (type2 tyvar)) + (make-tyvar + :alias (ty-alias type1) + :id (tyvar-id type2) + :kind (tyvar-kind type2))) + + (:method ((type1 tycon) (type2 tycon)) + (make-tycon + :alias (ty-alias type1) + :name (tycon-name type2) + :kind (tycon-kind type2))) + + (:method ((type1 tapp) (type2 tapp)) + (make-tapp + :alias (ty-alias type1) + :from (with-aliases-from (tapp-from type1) + (tapp-from type2)) + :to (with-aliases-from (tapp-to type1) + (tapp-to type2)))) + + (:method ((type1 tgen) (type2 tgen)) + (make-tgen + :alias (ty-alias type1) + :id (tgen-id type2)))) + +(defgeneric ty= (type1 type2) + (:documentation "For equal types, apply the aliases in TYPE1 to TYPE2.") + + (:method ((type1 tyvar) (type2 tyvar)) + (and (equalp (tyvar-id type1) + (tyvar-id type2)) + (equalp (tyvar-kind type1) + (tyvar-kind type2)))) + + (:method ((type1 tycon) (type2 tycon)) + (and (equalp (tycon-name type1) + (tycon-name type2)) + (equalp (tycon-kind type1) + (tycon-kind type2)))) + + (:method ((type1 tapp) (type2 tapp)) + (and (ty= (tapp-from type1) + (tapp-from type2)) + (ty= (tapp-to type1) + (tapp-to type2)))) + + (:method ((type1 tgen) (type2 tgen)) + (equalp (tgen-id type1) + (tgen-id type2))) + + (:method (type1 type2) + (declare (ignore type1) + (ignore type2)) + nil)) + ;;; ;;; Early types ;;; @@ -367,6 +433,8 @@ (declare (type stream stream) (type ty ty) (values ty)) + (when (ty-alias ty) + (format stream "[~S := " (ty-alias ty))) (etypecase ty (tyvar (if *coalton-pretty-print-tyvars* @@ -424,6 +492,8 @@ (tgen (write-string "#GEN" stream) (write (tgen-id ty) :stream stream))) + (when (ty-alias ty) + (format stream "]")) ty) (defmethod print-object ((ty ty) stream) diff --git a/src/typechecker/unify.lisp b/src/typechecker/unify.lisp index bcf534d26..8d997eb98 100644 --- a/src/typechecker/unify.lisp +++ b/src/typechecker/unify.lisp @@ -40,8 +40,7 @@ (:method ((type1 ty) (type2 tyvar)) (bind-variable type2 type1)) (:method ((type1 tycon) (type2 tycon)) - (if (equalp type1 - type2) + (if (ty= type1 type2) nil (error 'unification-error :type1 type1 :type2 type2))) (:method ((type1 ty) (type2 ty)) @@ -50,7 +49,7 @@ (defun bind-variable (tyvar type) (cond ((and (tyvar-p type) - (equalp type tyvar)) + (ty= type tyvar)) nil) ((find tyvar (type-variables type)) (error 'infinite-type-unification-error :type type)) @@ -74,7 +73,7 @@ apply s type1 == type2") (list (make-substitution :from type1 :to type2)) (error 'type-kind-mismatch-error :type1 type1 :type2 type2))) (:method ((type1 tycon) (type2 tycon)) - (if (equalp type1 type2) + (if (ty= type1 type2) nil (error 'unification-error :type1 type1 :type2 type2))) (:method ((type1 ty) (type2 ty)) diff --git a/tests/utilities.lisp b/tests/utilities.lisp index fc434b39a..a1196a6c5 100644 --- a/tests/utilities.lisp +++ b/tests/utilities.lisp @@ -54,7 +54,7 @@ (eclector.concrete-syntax-tree:read stream) source)) (parsed-type (tc:parse-ty-scheme ast-type env))) - (is (equalp + (is (tc:ty-scheme= (tc:lookup-value-type env symbol) parsed-type)))))))))) (values)) From 287f0891e3e1089733fd74c111445cb3e34e5724 Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Tue, 8 Oct 2024 16:23:16 -0700 Subject: [PATCH 05/19] removed with-aliases-from --- src/typechecker/define.lisp | 3 +-- src/typechecker/types.lisp | 31 +------------------------------ 2 files changed, 2 insertions(+), 32 deletions(-) diff --git a/src/typechecker/define.lisp b/src/typechecker/define.lisp index 08e7b036a..9e781d667 100644 --- a/src/typechecker/define.lisp +++ b/src/typechecker/define.lisp @@ -761,8 +761,7 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)") (progn (setf subs (tc:unify subs expr-ty expected-type)) (values - (tc:with-aliases-from declared-ty - (tc:apply-substitution subs expr-ty)) + (tc:apply-substitution subs expr-ty) preds accessors expr-node diff --git a/src/typechecker/types.lisp b/src/typechecker/types.lisp index 12517542d..8757aef3c 100644 --- a/src/typechecker/types.lisp +++ b/src/typechecker/types.lisp @@ -9,7 +9,6 @@ (:export #:ty ; STRUCT #:ty-alias ; ACCESSOR - #:ty= ; FUNCTION #:ty-list ; TYPE #:tyvar ; STRUCT #:make-tyvar ; CONSTRUCTOR @@ -36,7 +35,7 @@ #:instantiate ; FUNCTION #:kind-of ; FUNCTION #:type-constructors ; FUNCTION - #:with-aliases-from ; FUNCTION + #:ty= ; FUNCTION #:*boolean-type* ; VARIABLE #:*unit-type* ; VARIABLE #:*char-type* ; VARIABLE @@ -207,34 +206,6 @@ (:method ((lst list)) (mapcan #'type-constructors-generic% lst))) -(defgeneric with-aliases-from (type1 type2) - (:documentation "For equal types, apply the aliases in TYPE1 to TYPE2.") - - (:method ((type1 tyvar) (type2 tyvar)) - (make-tyvar - :alias (ty-alias type1) - :id (tyvar-id type2) - :kind (tyvar-kind type2))) - - (:method ((type1 tycon) (type2 tycon)) - (make-tycon - :alias (ty-alias type1) - :name (tycon-name type2) - :kind (tycon-kind type2))) - - (:method ((type1 tapp) (type2 tapp)) - (make-tapp - :alias (ty-alias type1) - :from (with-aliases-from (tapp-from type1) - (tapp-from type2)) - :to (with-aliases-from (tapp-to type1) - (tapp-to type2)))) - - (:method ((type1 tgen) (type2 tgen)) - (make-tgen - :alias (ty-alias type1) - :id (tgen-id type2)))) - (defgeneric ty= (type1 type2) (:documentation "For equal types, apply the aliases in TYPE1 to TYPE2.") From e05bd8abfa8451c9f101e98dad09c8947f0bf0b3 Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Tue, 8 Oct 2024 16:50:56 -0700 Subject: [PATCH 06/19] alias coalton-release fix --- src/typechecker/environment.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/typechecker/environment.lisp b/src/typechecker/environment.lisp index d0bfbb5e5..36ab4996a 100644 --- a/src/typechecker/environment.lisp +++ b/src/typechecker/environment.lisp @@ -524,7 +524,7 @@ (make-load-form-saving-slots self :environment env)) #+(and sbcl coalton-release) -(declaim sb-ext:freeze-type alias-entry) +(declaim (sb-ext:freeze-type alias-entry)) (defun alias-entry-list-p (x) (and (alexandria:proper-list-p x) From db74f659de13548e858473b7c8b51ac01d55d2c7 Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Wed, 16 Oct 2024 11:38:43 -0700 Subject: [PATCH 07/19] added parametrized type aliases --- src/debug.lisp | 7 ++ src/package.lisp | 1 + src/parser/collect.lisp | 4 + src/parser/renamer.lisp | 14 +++- src/parser/toplevel.lisp | 78 +++++++++++++---- src/parser/type-definition.lisp | 16 +++- src/typechecker/base.lisp | 6 +- src/typechecker/define-type.lisp | 56 ++++++++++--- src/typechecker/environment.lisp | 20 +++-- src/typechecker/parse-type.lisp | 129 ++++++++++++++++++----------- src/typechecker/substitutions.lisp | 2 +- src/typechecker/type-errors.lisp | 24 ++++-- src/typechecker/types.lisp | 22 +++-- 13 files changed, 276 insertions(+), 103 deletions(-) diff --git a/src/debug.lisp b/src/debug.lisp index 379505043..75e71006d 100644 --- a/src/debug.lisp +++ b/src/debug.lisp @@ -173,6 +173,13 @@ "Lookup the type of value SYMBOL in the global environment" (tc:lookup-value-type entry:*global-environment* symbol)) +(defun coalton:describe-type-of (symbol) + "Print the type of value SYMBOL along with its type aliases and return it" + (let ((tc:*pprint-aliases* t) + (type (tc:lookup-value-type entry:*global-environment* symbol))) + (format t "~S~%" type) + type)) + (defun coalton:kind-of (symbol) "Lookup the kind of type SYMBOL in the global environment" (tc:kind-of (coalton-impl/typechecker::type-entry-type (tc:lookup-type entry:*global-environment* symbol)))) diff --git a/src/package.lisp b/src/package.lisp index bd65a0ae0..349452ffa 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -109,6 +109,7 @@ #:lookup-class #:lookup-fundeps #:type-of + #:describe-type-of #:kind-of) (:intern diff --git a/src/parser/collect.lisp b/src/parser/collect.lisp index 010be8777..16191c287 100644 --- a/src/parser/collect.lisp +++ b/src/parser/collect.lisp @@ -110,6 +110,10 @@ (declare (values tyvar-list)) (mapcan #'collect-type-variables-generic% (toplevel-define-type-ctors type))) + (:method ((alias toplevel-define-alias)) + (declare (values tyvar-list)) + (collect-type-variables-generic% (toplevel-define-alias-type alias))) + (:method ((method method-definition)) (declare (values tyvar-list &optional)) (collect-type-variables-generic% (method-definition-type method))) diff --git a/src/parser/renamer.lisp b/src/parser/renamer.lisp index 09a5ca31b..896fe1e2a 100644 --- a/src/parser/renamer.lisp +++ b/src/parser/renamer.lisp @@ -632,7 +632,19 @@ (declare (type algo:immutable-map ctx) (values toplevel-define-alias)) - toplevel) + (let* ((tvars (mapcar #'keyword-src-name (toplevel-define-alias-vars toplevel))) + + (new-bindings (make-local-vars tvars :package util:+keyword-package+)) + + (new-ctx (algo:immutable-map-set-multiple ctx new-bindings))) + + (make-toplevel-define-alias + :name (toplevel-define-alias-name toplevel) + :vars (rename-type-variables-generic% (toplevel-define-alias-vars toplevel) new-ctx) + :docstring (source:docstring toplevel) + :type (rename-type-variables-generic% (toplevel-define-alias-type toplevel) new-ctx) + :location (source:location toplevel) + :head-location (toplevel-define-alias-head-location toplevel)))) (:method ((field struct-field) ctx) (declare (type algo:immutable-map ctx) diff --git a/src/parser/toplevel.lisp b/src/parser/toplevel.lisp index 8b0070939..bd1a8887d 100644 --- a/src/parser/toplevel.lisp +++ b/src/parser/toplevel.lisp @@ -37,8 +37,9 @@ #:toplevel-define-type-head-location ; ACCESSOR #:toplevel-define-type-list ; TYPE #:toplevel-define-alias ; STRUCT - #:toplevel-make-toplevel-define-alias ; CONSTRUCTOR + #:make-toplevel-define-alias ; CONSTRUCTOR #:toplevel-define-alias-name ; ACCESSOR + #:toplevel-define-alias-vars ; ACCESSOR #:toplevel-define-alias-type ; ACCESSOR #:toplevel-define-alias-head-location ; ACCESSOR #:toplevel-define-alias-list ; TYPE @@ -176,7 +177,8 @@ ;;;; toplevel-define-type := "(" "define-type" identifier docstring? constructor* ")" ;;;; | "(" "define-type" "(" identifier keyword+ ")" docstring? constructor* ")" ;;;; -;;;; toplevel-define-alias := "(" "define-alias" identifier type docstring? ")" +;;;; toplevel-define-alias := "(" "define-alias" identifier ty docstring? ")" +;;;; | "(" "define-alias" "(" identifier keyword+ ")" ty docstring? ")" ;;;; ;;;; struct-field := "(" identifier docstring? type ")" ;;;; @@ -278,6 +280,7 @@ (:include toplevel-definition) (:copier :nil)) (name (util:required 'name) :type identifier-src :read-only t) + (vars (util:required 'vars) :type keyword-src-list :read-only t) (type (util:required 'type) :type ty :read-only t) (head-location (util:required 'head-location) :type source:location :read-only t)) @@ -1240,41 +1243,86 @@ consume all attributes"))) (assert (cst:consp form)) - (let ((docstring)) + (let (docstring + name + variables) ;; (define-alias) (unless (cst:consp (cst:rest form)) (parse-error "Malformed alias definition" (note source form "expected body"))) - ;; (define-alias alias) + (cond + ;; (define-alias _ ...) + ((cst:atom (cst:second form)) + ;; (define-alias 0.5 ...) + (unless (identifierp (cst:raw (cst:second form))) + (parse-error "Malformed alias definition" + (note source (cst:second form) "expected symbol"))) + + ;; (define-alias name ...) + (setf name (make-identifier-src :name (cst:raw (cst:second form)) + :location (form-location source form)))) + + ;; (define-alias (_ ...) ...) + (t + ;; (define-alias((name) ...) ...) + (unless (cst:atom (cst:first (cst:second form))) + (parse-error "Malformed alias 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-alias (0.5 ...) ...) + (unless (identifierp (cst:raw (cst:first (cst:second form)))) + (parse-error "Malformed alias definition" + (note source (cst:first (cst:second form)) + "expected symbol"))) + + ;; (define-alias (name ...) ...) + (setf name (make-identifier-src :name (cst:raw (cst:first (cst:second form))) + :location (form-location source + (cst:first (cst:second form))))) + + ;; (define-alias (name) ...) + (when (cst:atom (cst:rest (cst:second form))) + (parse-error "Malformed alias definition" + (note source (cst:second form) + "nullary aliases should not have parentheses") + (help source (cst:second form) + (lambda (existing) + (subseq existing 1 (1- (length existing)))) + "remove unnecessary parentheses"))) + + ;; (define-alias (name type-variables+) ...) + (loop :for vars := (cst:rest (cst:second form)) :then (cst:rest vars) + :while (cst:consp vars) + :do (push (parse-type-variable (cst:first vars) source) variables)))) + + ;; (define-alias name) (unless (cst:consp (cst:rest (cst:rest form))) (parse-error "Malformed alias definition" (note source form "expected type"))) - ;; (define-alias alias type docstring) + ;; (define-alias name type docstring) (when (and (cst:consp (cst:nthrest 3 form)) (cst:atom (cst:fourth form)) (stringp (cst:raw (cst:fourth form)))) (setf docstring (cst:raw (cst:fourth form)))) - ;; (define-alias alias type docstring ...) + ;; (define-alias name type docstring ...) (when (and docstring (cst:consp (cst:nthrest 4 form))) (parse-error "Malformed alias definition" (note source (cst:fifth form) "unexpected trailing form"))) - ;; (define-alias 0.5 type) - (unless (identifierp (cst:raw (cst:second form))) - (parse-error "Malformed define-alias" - (note source (cst:second form) - "expected symbol"))) - (make-toplevel-define-alias - :name (make-identifier-src - :name (cst:raw (cst:second form)) - :location (form-location source (cst:second form))) + :name name + :vars (reverse variables) :type (parse-type (cst:third form) source) :docstring docstring :location (form-location source form) diff --git a/src/parser/type-definition.lisp b/src/parser/type-definition.lisp index 93c0bf0ea..3a1dfe2bf 100644 --- a/src/parser/type-definition.lisp +++ b/src/parser/type-definition.lisp @@ -21,6 +21,7 @@ #:type-definition-name ; FUNCTION #:type-definition-vars ; FUNCTION #:type-definition-repr ; FUNCTION + #:type-definition-aliased-type ; FUNCTION #:type-definition-ctors ; FUNCTION #:type-definition-ctor-name ; FUNCTION #:type-definition-ctor-field-types ; FUNCTION @@ -65,7 +66,7 @@ (:method ((def toplevel-define-alias)) (declare (values keyword-src-list)) - (list))) + (toplevel-define-alias-vars def))) (defgeneric type-definition-repr (def) (:method ((def toplevel-define-type)) @@ -80,6 +81,19 @@ (declare (values (or null attribute-repr))) nil)) +(defgeneric type-definition-aliased-type (def) + (:method ((def toplevel-define-type)) + (declare (values (or null ty))) + nil) + + (:method ((def toplevel-define-struct)) + (declare (values (or null ty))) + nil) + + (:method ((def toplevel-define-alias)) + (declare (values (or null ty))) + (toplevel-define-alias-type def))) + (defgeneric type-definition-ctors (def) (:method ((def toplevel-define-type)) (declare (values constructor-list)) diff --git a/src/typechecker/base.lisp b/src/typechecker/base.lisp index 9313c1a64..701cdca23 100644 --- a/src/typechecker/base.lisp +++ b/src/typechecker/base.lisp @@ -9,6 +9,7 @@ #:*pprint-tyvar-dict* #:*pprint-variable-symbol-code* #:*pprint-variable-symbol-suffix* + #:*pprint-aliases* #:tc-error ; CONDITION, FUNCTION #:tc-location #:tc-secondary-location @@ -60,6 +61,8 @@ This requires a valid PPRINT-VARIABLE-CONTEXT") (with-pprint-variable-scope () ,@body))) +(defvar *pprint-aliases* nil) + ;;; ;;; Conditions ;;; @@ -75,7 +78,8 @@ This requires a valid 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)) + (let ((*pprint-aliases* t)) + (apply #'tc-location (source:location located) format-string format-args))) (defun tc-secondary-note (located format-string &rest format-args) (apply #'tc-secondary-location (source:location located) format-string format-args)) diff --git a/src/typechecker/define-type.lisp b/src/typechecker/define-type.lisp index 2a55060ac..047177695 100644 --- a/src/typechecker/define-type.lisp +++ b/src/typechecker/define-type.lisp @@ -28,6 +28,7 @@ #:type-definition-name ; ACCESSOR #:type-definition-type ; ACCESSOR #:type-definition-runtime-type ; ACCESSOR + #:type-definition-aliased-type ; ACCESSOR #:type-definition-explicit-repr ; ACCESSOR #:type-definition-enum-repr ; ACCESSOR #:type-definition-newtype ; ACCESSOR @@ -43,6 +44,7 @@ (name (util:required 'name) :type symbol :read-only t) (type (util:required 'type) :type tc:ty :read-only t) (runtime-type (util:required 'runtime-type) :type t :read-only t) + (aliased-type (util:required 'runtime-type) :type (or null tc:ty) :read-only t) ;; See the fields with the same name on type-entry (explicit-repr (util:required 'explicit-repr) :type tc:explicit-repr :read-only t) @@ -175,9 +177,7 @@ :collect (tc:kind-of (partial-type-env-add-var partial-env var))) :for kind := (tc:make-kind-function* kvars tc:+kstar+) - :for ty := (if (not (typep type 'parser:toplevel-define-alias)) - (tc:make-tycon :name name :kind kind) - (parse-type (parser:toplevel-define-alias-type type) env)) + :for ty := (tc:make-tycon :name name :kind kind) :do (partial-type-env-add-type partial-env name ty)) :append (multiple-value-bind (type-definitions instances_ ksubs) @@ -220,15 +220,20 @@ (setf env (tc:unset-function env constructor)))))) (cond ((typep parsed-type 'parser:toplevel-define-alias) - (let ((name (type-definition-name type)) - (alias-type (parse-type (parser:toplevel-define-alias-type parsed-type) env))) - (setf (tc:ty-alias alias-type) name) + (let ((alias (tc:apply-type-argument-list (type-definition-type type) tyvars)) + (aliased-type (type-definition-aliased-type type))) + (setf aliased-type + (tc:push-alias aliased-type + (tc:apply-ksubstitution + (tc:kind-monomorphize-subs (tc:kind-variables tyvars) nil) + alias))) (setf env (tc:set-alias env - name + (type-definition-name type) (tc:make-alias-entry - :name name - :type alias-type + :name (type-definition-name type) + :tyvars tyvars + :type aliased-type :docstring nil))))) ((tc:lookup-alias env (type-definition-name type) :no-error t) (setf env (tc:unset-alias env (type-definition-name type))))) @@ -310,6 +315,24 @@ env) +(defun check-for-unused-alias-type-variables (aliased-type parsed-type partial-env) + (declare (type tc:ty aliased-type) + (type parser:type-definition parsed-type) + (type partial-type-env partial-env)) + (let* ((defined-variables (mapcar #'parser:keyword-src-name (parser:type-definition-vars parsed-type))) + (used-variables (mapcar #'tc:tyvar-id (tc:type-variables aliased-type))) + (unused-variables (loop :for tyvar :in defined-variables + :when (not (member (tc:tyvar-id (partial-type-env-lookup-var partial-env tyvar parsed-type)) + used-variables)) + :collect tyvar)) + (number-of-unused-variables (length unused-variables))) + (unless (zerop number-of-unused-variables) + (tc-error (format nil "Alias type variable~P defined but never used" number-of-unused-variables) + (tc-note parsed-type "Alias ~S defines unused type variable~P ~{:~A~^ ~}" + (parser:identifier-src-name (parser:type-definition-name parsed-type)) + number-of-unused-variables + (mapcar (lambda (str) (subseq str 0 (- (length str) 5))) + (mapcar #'string unused-variables))))))) (defun infer-define-type-scc-kinds (types env) (declare (type parser:type-definition-list types) @@ -327,9 +350,9 @@ :for ctor-name := (parser:identifier-src-name (parser:type-definition-ctor-name ctor)) :for fields := (loop :for field :in (parser:type-definition-ctor-field-types ctor) :collect (multiple-value-bind (type ksubs_) - (infer-type-kinds field tc:+kstar+ ksubs env) + (parse-type field env ksubs) (setf ksubs ksubs_) - (apply-alias-substitutions type (partial-type-env-env env)))) + type)) :do (setf (gethash ctor-name ctor-table) fields))) ;; Redefine types with final inferred kinds in the environment @@ -358,7 +381,7 @@ :for repr := (parser:type-definition-repr type) :for repr-type := (and repr (parser:keyword-src-name (parser:attribute-repr-type repr))) - :for repr-arg := (and repr (eq repr-type :native) (cst:raw (parser:attribute-repr-arg repr))) + :for repr-arg := (and repr (eq repr-type :native) (cst:raw (parser:attribute-repr-arg repr))) ;; Apply ksubs to find the type of each constructor :for constructor-types @@ -440,6 +463,12 @@ `(member ,@(mapcar #'tc:constructor-entry-compressed-repr ctors))) (t name)) + :aliased-type (let ((parser-aliased-type + (parser:type-definition-aliased-type type))) + (when parser-aliased-type + (let ((aliased-type (parse-type parser-aliased-type env))) + (check-for-unused-alias-type-variables aliased-type type env) + aliased-type))) :explicit-repr (if (eq repr-type :native) (list repr-type repr-arg) repr-type) @@ -464,7 +493,8 @@ (defun maybe-runtime-repr-instance (type) (declare (type type-definition type)) - (unless (equalp *package* (find-package "COALTON-LIBRARY/TYPES")) + (unless (or (equalp *package* (find-package "COALTON-LIBRARY/TYPES")) + (type-definition-aliased-type type)) (make-runtime-repr-instance type))) (defun make-runtime-repr-instance (type) diff --git a/src/typechecker/environment.lisp b/src/typechecker/environment.lisp index 36ab4996a..e9dab718f 100644 --- a/src/typechecker/environment.lisp +++ b/src/typechecker/environment.lisp @@ -49,12 +49,13 @@ #:constructor-entry-compressed-repr ; ACCESSOR #:constructor-entry-list ; TYPE #:constructor-environment ; STRUCT - #:alias-entry - #:make-alias-entry - #:alias-entry-name - #:alias-entry-type - #:alias-entry-list - #:alias-environment + #:alias-entry ; STRUCT + #:make-alias-entry ; CONSTRUCTOR + #:alias-entry-name ; ACCESSOR + #:alias-entry-tyvars ; ACCESSOR + #:alias-entry-type ; ACCESSOR + #:alias-entry-list ; ACCESSOR + #:alias-environment ; STRUCT #:struct-field ; STRUCT #:make-struct-field ; CONSTRUCTOR #:struct-field-name ; ACCESSOR @@ -513,9 +514,10 @@ ;;; (defstruct alias-entry - (name (util:required 'name) :type symbol) - (type (util:required 'type) :type ty) - (docstring (util:required 'docstring) :type (or null string))) + (name (util:required 'name) :type symbol :read-only t) + (tyvars (util:required 'tyvars) :type tyvar-list :read-only t) + (type (util:required 'type) :type ty :read-only t) + (docstring (util:required 'docstring) :type (or null string) :read-only t)) (defmethod source:docstring ((self alias-entry)) (alias-entry-docstring self)) diff --git a/src/typechecker/parse-type.lisp b/src/typechecker/parse-type.lisp index 303641895..393c7021e 100644 --- a/src/typechecker/parse-type.lisp +++ b/src/typechecker/parse-type.lisp @@ -31,59 +31,93 @@ ;;; Entrypoints ;;; -(defgeneric apply-alias-substitutions (ty env) - (:documentation "Replace aliases in TY with their underlying types.") - - (:method ((ty tc:tyvar) env) - (declare (ignore env) - (values tc:tyvar)) - ty) - - (:method ((ty tc:tycon) env) - (declare (type tc:environment env) +(defgeneric apply-alias-substitutions (type parser-type env) + (:method ((type tc:tycon) parser-type env) + (declare (type parser:ty parser-type) + (type partial-type-env env) (values tc:ty)) - - (let ((alias (tc:lookup-alias env (tc:tycon-name ty) :no-error t))) + (let ((alias (tc:lookup-alias (partial-type-env-env env) (tc:tycon-name type) :no-error t))) (when alias - (setf ty (tc:alias-entry-type alias))) - ty)) - - (:method ((ty tc:tapp) env) - (declare (type tc:environment env) + (handler-case + (let ((substs (tc:match (first (tc:ty-alias (tc:alias-entry-type alias))) type))) + (setf type (tc:apply-substitution substs (tc:alias-entry-type alias)))) + (tc:unification-error () + (tc-error "Incomplete alias application" + (tc-note parser-type + "Type alias ~S is applied to 0 arguments, but ~D argument~:P ~:*~[are~;is~:;are~] required." + (tc:alias-entry-name alias) + (length (tc:alias-entry-tyvars alias))))))) + type)) + + (:method ((type tc:tapp) parser-type env) + (declare (type parser:ty parser-type) + (type partial-type-env env) (values tc:tapp)) + (when (typep (tc:tapp-from type) 'tc:tycon) + (let ((alias (tc:lookup-alias (partial-type-env-env env) (tc:tycon-name (tc:tapp-from type)) :no-error t))) + (when alias + (handler-case + (let ((substs (tc:match (first (tc:ty-alias (tc:alias-entry-type alias))) type))) + (setf type (tc:apply-substitution substs (tc:alias-entry-type alias)))) + (tc:unification-error () + (tc-error "Incomplete alias application" + (tc-note parser-type + "Type alias ~S is applied to ~D argument~:P, but ~D argument~:P ~:*~[are~;is~:;are~] required." + (tc:alias-entry-name alias) + (let ((type_ (copy-structure type))) + (loop :while (tc:tapp-p type_) + :sum 1 + :do (setf type_ (tc:tapp-to type_)))) + (length (tc:alias-entry-tyvars alias))))))))) (tc:make-tapp - :alias (tc:ty-alias ty) - :from (apply-alias-substitutions (tc:tapp-from ty) env) - :to (apply-alias-substitutions (tc:tapp-to ty) env))) - - (:method ((ty tc:tgen) env) - (declare (ignore env) - (values tc:tgen)) - ty)) + :alias (tc:ty-alias type) + :from (apply-alias-substitutions (tc:tapp-from type) parser-type env) + :to (apply-alias-substitutions (tc:tapp-to type) parser-type env))) -(defun parse-type (ty env) - (declare (type parser:ty ty) - (type tc:environment env) - (values tc:ty &optional)) + (:method ((type tc:qualified-ty) parser-type env) + (declare (type parser:qualified-ty parser-type) + (type partial-type-env env) + (values tc:qualified-ty)) + (tc:make-qualified-ty + :predicates (tc:qualified-ty-predicates type) + :type (apply-alias-substitutions (tc:qualified-ty-type type) + (parser:qualified-ty-type parser-type) + env))) + + (:method ((type tc:ty) parser-type env) + (declare (type parser:ty parser-type) + (type partial-type-env env) + (ignore env) + (values tc:ty)) + type)) - (let ((tvars (parser:collect-type-variables ty)) +(defun parse-type (parser-ty env &optional ksubs (kind tc:+kstar+)) + (declare (type parser:ty parser-ty) + (type (or tc:environment partial-type-env) env) + (type tc:ksubstitution-list ksubs) + (type tc:kind kind) + (values tc:ty tc:ksubstitution-list &optional)) - (partial-env (make-partial-type-env :env env))) + (let ((partial-env (if (typep env 'tc:environment) + (make-partial-type-env :env env) + env))) - (loop :for tvar :in tvars - :for tvar-name := (parser:tyvar-name tvar) - :do (partial-type-env-add-var partial-env tvar-name)) + (when (typep env 'tc:environment) + (loop :for tvar :in (parser:collect-type-variables parser-ty) + :for tvar-name := (parser:tyvar-name tvar) + :do (partial-type-env-add-var partial-env tvar-name))) (multiple-value-bind (ty ksubs) - (infer-type-kinds ty - tc:+kstar+ - nil + (infer-type-kinds parser-ty + kind + ksubs partial-env) (setf ty (tc:apply-ksubstitution ksubs ty)) - (setf ty (apply-alias-substitutions ty env)) (setf ksubs (tc:kind-monomorphize-subs (tc:kind-variables ty) ksubs)) - (tc:apply-ksubstitution ksubs ty)))) + (setf ty (tc:apply-ksubstitution ksubs ty)) + (setf ty (apply-alias-substitutions ty parser-ty partial-env)) + (values ty ksubs)))) (defun parse-qualified-type (unparsed-ty env) (declare (type parser:qualified-ty unparsed-ty) @@ -91,7 +125,6 @@ (values tc:qualified-ty &optional)) (let ((tvars (parser:collect-type-variables unparsed-ty)) - (partial-env (make-partial-type-env :env env))) (loop :for tvar :in tvars @@ -104,7 +137,7 @@ (setf qual-ty (tc:apply-ksubstitution ksubs qual-ty)) (setf qual-ty (tc:make-qualified-ty :predicates (tc:qualified-ty-predicates qual-ty) - :type (apply-alias-substitutions (tc:qualified-ty-type qual-ty) env))) + :type (tc:qualified-ty-type qual-ty))) (setf ksubs (tc:kind-monomorphize-subs (tc:kind-variables qual-ty) ksubs)) (let* ((qual-ty (tc:apply-ksubstitution ksubs qual-ty)) @@ -116,7 +149,7 @@ (check-for-ambiguous-variables preds ty unparsed-ty env) (check-for-reducible-context preds unparsed-ty env) - qual-ty)))) + (apply-alias-substitutions qual-ty unparsed-ty partial-env))))) (defun parse-ty-scheme (ty env) (declare (type parser:qualified-ty ty) @@ -189,7 +222,9 @@ (defgeneric infer-type-kinds (type expected-kind ksubs env) (:method ((type parser:tyvar) expected-kind ksubs env) (declare (type tc:kind expected-kind) - (type tc:ksubstitution-list ksubs)) + (type tc:ksubstitution-list ksubs) + (type partial-type-env env) + (values tc:ty tc:ksubstitution-list &optional)) (let* ((tvar (partial-type-env-lookup-var env (parser:tyvar-name type) @@ -212,7 +247,7 @@ (declare (type tc:kind expected-kind) (type tc:ksubstitution-list ksubs) (type partial-type-env env) - (values tc:ty tc:ksubstitution-list)) + (values tc:ty tc:ksubstitution-list &optional)) (let ((type_ (partial-type-env-lookup-type env type))) (handler-case @@ -267,7 +302,7 @@ (declare (type tc:kind expected-kind) (type tc:ksubstitution-list ksubs) (type partial-type-env env) - (values tc:qualified-ty tc:ksubstitution-list)) + (values tc:qualified-ty tc:ksubstitution-list &optional)) ;; CCL >:( (assert (equalp expected-kind tc:+kstar+)) @@ -308,9 +343,7 @@ (let ((types (loop :for ty :in (parser:ty-predicate-types pred) :for class-ty :in (tc:ty-predicate-types class-pred) :collect (multiple-value-bind (ty ksubs_) - (infer-type-kinds ty (tc:kind-of class-ty) - ksubs - env) + (parse-type ty env ksubs (tc:kind-of class-ty)) (setf ksubs ksubs_) ty)))) (values (tc:make-ty-predicate :class class-name diff --git a/src/typechecker/substitutions.lisp b/src/typechecker/substitutions.lisp index 5085503ed..8454e2781 100644 --- a/src/typechecker/substitutions.lisp +++ b/src/typechecker/substitutions.lisp @@ -74,7 +74,7 @@ ;; For a type application, recurse down into all the types (:method (subst-list (type tapp)) (make-tapp - :alias (ty-alias type) + :alias (mapcar (lambda (alias) (apply-substitution subst-list alias)) (ty-alias type)) :from (apply-substitution subst-list (tapp-from type)) :to (apply-substitution subst-list (tapp-to type)))) ;; Otherwise, do nothing diff --git a/src/typechecker/type-errors.lisp b/src/typechecker/type-errors.lisp index da4d1313c..217b4093f 100644 --- a/src/typechecker/type-errors.lisp +++ b/src/typechecker/type-errors.lisp @@ -37,7 +37,8 @@ (:report (lambda (c s) (let ((*print-circle* nil) ; Prevent printing using reader macros - ) + (*print-readably* nil) + (*pprint-aliases* nil)) (format s "Failed to unify types ~S and ~S" (unification-error-type1 c) (unification-error-type2 c)))))) @@ -48,7 +49,8 @@ (:report (lambda (c s) (let ((*print-circle* nil) ; Prevent printing using reader macros - ) + (*print-readably* nil) + (*pprint-aliases* nil)) (format s "Cannot construct infinite type by unifying ~S with internal variable." (infinite-type-unification-error-type c)))))) @@ -61,7 +63,8 @@ (:report (lambda (c s) (let ((*print-circle* nil) ; Prevent printing using reader macros - ) + (*print-readably* nil) + (*pprint-aliases* nil)) (format s "Kind mismatch between type ~S of kind ~S and kind ~S" (kind-mismatch-error-type c) (kind-of (kind-mismatch-error-type c)) @@ -75,7 +78,8 @@ (:report (lambda (c s) (let ((*print-circle* nil) ; Prevent printing using reader macros - ) + (*print-readably* nil) + (*pprint-aliases* nil)) (format s "Kind mismatch between type ~S of kind ~S and type ~S kind ~S" (type-kind-mismatch-error-type1 c) (kind-of (type-kind-mismatch-error-type1 c)) @@ -90,7 +94,8 @@ (:report (lambda (c s) (let ((*print-circle* nil) ; Prevent printing using reader macros - ) + (*print-readably* nil) + (*pprint-aliases* nil)) (format s "Failed to unify types ~S and ~S" (unification-error-pred1 c) (unification-error-pred2 c)))))) @@ -101,7 +106,8 @@ (:report (lambda (c s) (let ((*print-circle* nil) ; Prevent printing using reader macros - ) + (*print-readably* nil) + (*pprint-aliases* nil)) (format s "Ambiguous constraint ~S~%" (ambiguous-constraint-pred c)))))) @@ -113,7 +119,8 @@ (:report (lambda (c s) (let ((*print-circle* nil) ; Prevent printing using reader macros - ) + (*print-readably* nil) + (*pprint-aliases* nil)) (format s "Instance ~S overlaps with instance ~S" (overlapping-instance-error-inst1 c) (overlapping-instance-error-inst2 c)))))) @@ -152,7 +159,8 @@ (:report (lambda (c s) (let ((*print-circle* nil) ; Prevent printing using reader macros - ) + (*print-readably* nil) + (*pprint-aliases* nil)) (with-pprint-variable-context () (format s "instance conflicts previous instance ~S" (fundep-conflict-old-pred c))))))) diff --git a/src/typechecker/types.lisp b/src/typechecker/types.lisp index 8757aef3c..782be626e 100644 --- a/src/typechecker/types.lisp +++ b/src/typechecker/types.lisp @@ -48,6 +48,7 @@ #:*fraction-type* ; VARIABLE #:*arrow-type* ; VARIABLE #:*list-type* ; VARIABLE + #:push-alias ; FUNCTION #:apply-type-argument ; FUNCTION #:apply-type-argument-list ; FUNCTION #:make-function-type ; FUNCTION @@ -74,7 +75,7 @@ ;;; (defstruct (ty (:constructor nil)) - (alias nil :type (or null symbol) :read-only nil)) + (alias nil :type (or null ty-list) :read-only nil)) (defmethod make-load-form ((self ty) &optional env) (make-load-form-saving-slots self :environment env)) @@ -136,7 +137,7 @@ (defgeneric instantiate (types type) (:method (types (type tapp)) (make-tapp - :alias (ty-alias type) + :alias (mapcar (lambda (alias) (instantiate types alias)) (ty-alias type)) :from (instantiate types (tapp-from type)) :to (instantiate types (tapp-to type)))) (:method (types (type tgen)) @@ -257,6 +258,14 @@ ;;; Operations on Types ;;; +(defun push-alias (type alias) + (declare (type ty type) + (type ty alias) + (values ty &optional)) + (let ((new-type (copy-structure type))) + (setf (ty-alias new-type) (cons alias (ty-alias new-type))) + new-type)) + (defun apply-type-argument (tcon arg &key ksubs) (declare (type (or tycon tapp tyvar) tcon) (type ty arg) @@ -404,8 +413,8 @@ (declare (type stream stream) (type ty ty) (values ty)) - (when (ty-alias ty) - (format stream "[~S := " (ty-alias ty))) + (when (and *pprint-aliases* (ty-alias ty)) + (format stream "[~{~S := ~}" (ty-alias ty))) (etypecase ty (tyvar (if *coalton-pretty-print-tyvars* @@ -463,7 +472,7 @@ (tgen (write-string "#GEN" stream) (write (tgen-id ty) :stream stream))) - (when (ty-alias ty) + (when (and *pprint-aliases* (ty-alias ty)) (format stream "]")) ty) @@ -484,7 +493,8 @@ (:report (lambda (c s) (let ((*print-circle* nil) ; Prevent printing using reader macros - ) + (*print-readably* nil) + (*print-aliases* nil)) (format s "Cannot apply ~S of kind ~S to ~S of kind ~S" (type-application-error-argument c) (kind-of (type-application-error-argument c)) From ffbef6e500c9e50cce2690c7ff7bb3aaea90aca2 Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Wed, 16 Oct 2024 11:59:36 -0700 Subject: [PATCH 08/19] added tests for parametrized type aliases --- tests/alias-tests.lisp | 62 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 62 insertions(+) diff --git a/tests/alias-tests.lisp b/tests/alias-tests.lisp index ae9ed500e..c09719c6b 100644 --- a/tests/alias-tests.lisp +++ b/tests/alias-tests.lisp @@ -73,3 +73,65 @@ '("p" . "Point") '("x" . "IFix"))) + +(deftest test-parametric-alias-definition () + + (check-coalton-types + "(define-alias (UnaryOperator :a) (:a -> :a))") + + (check-coalton-types + "(define-alias (Collapse :a :b :c :d) (:d -> :c -> :b -> :a))")) + +(deftest test-parametric-alias-the () + (check-coalton-types + "(define-alias Index UFix) + (define-alias (Collection :a) (List :a)) + + (define l (the (Collection Index) (make-list 1 2 3 4)))" + + '("l" . "(List UFix)"))) + +(deftest test-parametric-alias-declare () + (check-coalton-types + "(define-alias (UnaryOperator :a) (:a -> :a)) + + (declare f (UnaryOperator Integer)) + (define f 1+)" + + '("f" . "(Integer -> Integer)")) + + (check-coalton-types + "(define-alias (UnaryOperator :a) (:a -> :a)) + + (declare f ((Num :a) => (UnaryOperator :a))) + (define f 1+)")) + +(deftest test-parametric-alias-constructors () + (check-coalton-types + "(define-alias (Pair :a) (Tuple :a :a)) + + (define-type (Translation :a) + (Translation (Pair (Pair :a)))) + + (declare get-original-x-coordinate ((Translation :a) -> :a)) + (define (get-original-x-coordinate (Translation (Tuple (Tuple x _) _))) x) + + (define t (Translation (Tuple (Tuple 2 3) (Tuple 5 7)))) + (define x (get-original-x-coordinate t))" + + '("get-original-x-coordinate" . "(Translation :a -> :a)") + '("t" . "(Translation Integer)") + '("x" . "Integer")) + + (check-coalton-types + "(define-alias (Pair :a) (Tuple :a :a)) + + (define-struct (Translation :a) + (from (Pair :a)) + (to (Pair :a))) + + (define t (Translation (Tuple 2 3) (Tuple 5 7))) + (define from (.from t))" + + '("t" . "(Translation Integer)") + '("from" . "(Tuple Integer Integer)"))) From f2524993a71cfcd5710a451670a1f056224a8fba Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Wed, 16 Oct 2024 12:15:58 -0700 Subject: [PATCH 09/19] added describe-alias --- src/debug.lisp | 9 ++++++++- src/package.lisp | 1 + 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/src/debug.lisp b/src/debug.lisp index 75e71006d..0519d3786 100644 --- a/src/debug.lisp +++ b/src/debug.lisp @@ -180,9 +180,16 @@ (format t "~S~%" type) type)) +(defun coalton:describe-alias (symbol) + "Lookup the type represented by the alias SYMBOL in the global environment" + (let ((tc:*pprint-aliases* t) + (type (tc:alias-entry-type (tc:lookup-alias entry:*global-environment* symbol)))) + (format t "~S~%" type) + type)) + (defun coalton:kind-of (symbol) "Lookup the kind of type SYMBOL in the global environment" - (tc:kind-of (coalton-impl/typechecker::type-entry-type (tc:lookup-type entry:*global-environment* symbol)))) + (tc:kind-of (tc:type-entry-type (tc:lookup-type entry:*global-environment* symbol)))) (defun coalton:lookup-code (name) "Lookup the compiled code of a given definition" diff --git a/src/package.lisp b/src/package.lisp index 349452ffa..1a077ca59 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -110,6 +110,7 @@ #:lookup-fundeps #:type-of #:describe-type-of + #:describe-alias #:kind-of) (:intern From 9dda5c2b6a4dd6437a5e1fa6c050c2f19b26ce7b Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Wed, 16 Oct 2024 13:59:29 -0700 Subject: [PATCH 10/19] added define-alias.txt tests --- tests/coalton-tests.lisp | 1 + tests/test-files/define-alias.txt | 142 ++++++++++++++++++++++++++++++ 2 files changed, 143 insertions(+) create mode 100644 tests/test-files/define-alias.txt diff --git a/tests/coalton-tests.lisp b/tests/coalton-tests.lisp index eb6bb3f8a..cf61ebd29 100644 --- a/tests/coalton-tests.lisp +++ b/tests/coalton-tests.lisp @@ -14,6 +14,7 @@ (%run-tests "define-class.txt") (%run-tests "define-instance.txt") (%run-tests "define-type.txt") + (%run-tests "define-alias.txt") (%run-tests "define.txt") (%run-tests "fundeps.txt") (%run-tests "hashtable.txt") diff --git a/tests/test-files/define-alias.txt b/tests/test-files/define-alias.txt new file mode 100644 index 000000000..33b1eab0e --- /dev/null +++ b/tests/test-files/define-alias.txt @@ -0,0 +1,142 @@ +================================================================================ +1 Define alias +================================================================================ + +(package coalton-unit-tests) + +(define-alias Index Integer) + +================================================================================ +2 Define alias +================================================================================ + +(package coalton-unit-tests) + +(define-alias UnaryIntegerOperator (Integer -> Integer)) + +================================================================================ +3 Define alias +================================================================================ + +(package coalton-unit-tests) + +(define-alias (UnaryOperator :a) (:a -> :a)) + +================================================================================ +4 Define alias +================================================================================ + +(package coalton-unit-tests) + +(define-alias (ReverseTranslationRules :a :b) (:b -> :a)) + +================================================================================ +5 Define alias +================================================================================ + +(package coalton-unit-tests) + +(define-alias Index Integer) + +(define-alias MyIndex Index) + +(define-alias (Collection :a) (List :a)) + +(define-alias MyIndices (Collection MyIndex)) + +================================================================================ +100 define-alias, parse-error +================================================================================ + +(package test-package) + +(define-alias "Index" UFix) + +-------------------------------------------------------------------------------- + +error: Malformed alias definition + --> test:3:14 + | + 3 | (define-alias "Index" UFix) + | ^^^^^^^ expected symbol + +================================================================================ +101 define-alias, parse-error +================================================================================ + +(package test-package) + +(define-alias Index UFix + "An index" + "A really good index") + +-------------------------------------------------------------------------------- + +error: Malformed alias definition + --> test:5:2 + | + 5 | "A really good index") + | ^^^^^^^^^^^^^^^^^^^^^ unexpected trailing form + +================================================================================ +102 define-alias, type variables +================================================================================ + +(package test-package) + +(define-alias (Collection :a) (List :b)) + +-------------------------------------------------------------------------------- + +error: Unknown type variable + --> test:3:36 + | + 3 | (define-alias (Collection :a) (List :b)) + | ^^ Unknown type variable :B + +================================================================================ +103 define-alias, type variables +================================================================================ + +(package test-package) + +(define-alias (Collection :a) (List Integer)) + +-------------------------------------------------------------------------------- + +error: Alias type variable defined but never used + --> test:3:0 + | + 3 | (define-alias (Collection :a) (List Integer)) + | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Alias COLLECTION defines unused type variable :A + +================================================================================ +104 define-alias, type errors +================================================================================ + +(package test-package) + +(define-alias Index UFix) + +(define-alias MyIndex Index) + +(define-alias (UnaryOperator :a) (:a -> :a)) + +(declare increment-my-index (UnaryOperator MyIndex)) +(define increment-my-index (+ 1)) + +(declare x Integer) +(define x 5) + +(define new-x (increment-my-index x)) + +-------------------------------------------------------------------------------- + +error: Type mismatch + --> test:15:34 + | + 15 | (define new-x (increment-my-index x)) + | ^ Expected type '[MYINDEX := INDEX := UFIX]' but got 'INTEGER' + + + From 314ff0be3cadde7b2fddf580df2ebae795d2ab12 Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Wed, 16 Oct 2024 14:25:10 -0700 Subject: [PATCH 11/19] add tutorial documentation for type aliases --- docs/intro-to-coalton.md | 35 +++++++++++++++++++++++++++++++++++ src/debug.lisp | 3 ++- 2 files changed, 37 insertions(+), 1 deletion(-) diff --git a/docs/intro-to-coalton.md b/docs/intro-to-coalton.md index f218eb745..7c768f770 100644 --- a/docs/intro-to-coalton.md +++ b/docs/intro-to-coalton.md @@ -272,6 +272,41 @@ Type definitions introduce type constructors. For example, we may construct a so We'll see how to unpack these types using `match` later in this document. +## Type Aliases + +Coalton allows the definition of parametric type aliases. Type aliases can be defined on primitive types and types created with `define-type` or `define-alias`. + +```lisp +(coalton-toplevel + ;; New aliases are created with the DEFINE-ALIAS operator + (define-alias Coordinate Integer) + (define-alias (Pair :a) (Tuple :a :a)) + (define-alias Translation (Pair Coordinate -> Pair Coordinate)) + + (declare shift-right Translation) + (define (shift-right (Tuple x y)) + (Tuple (1+ x) y)) + + (define shifted-coordinate (shift-right (Tuple 0 0)))) +``` + +Outside of a Coalton expression, `describe-type-of` displays the type of a symbol, including its aliases, and returns the type. `describe-alias` displays the alias along with its base type and returns the base type. + +```lisp +COALTON-USER> shifted-coordinate +#.(TUPLE 1 0) + +COALTON-USER> (type-of 'shifted-coordinate) +(TUPLE INTEGER INTEGER) + +COALTON-USER> (describe-type-of 'shifted-coordinate) +[(PAIR COORDINATE) := (TUPLE [COORDINATE := INTEGER] [COORDINATE := INTEGER])] + +COALTON-USER> (describe-alias 'Pair) +[(PAIR :A) := (TUPLE :A :A)] +``` + + ### Structs diff --git a/src/debug.lisp b/src/debug.lisp index 0519d3786..666f6f3ad 100644 --- a/src/debug.lisp +++ b/src/debug.lisp @@ -184,7 +184,8 @@ "Lookup the type represented by the alias SYMBOL in the global environment" (let ((tc:*pprint-aliases* t) (type (tc:alias-entry-type (tc:lookup-alias entry:*global-environment* symbol)))) - (format t "~S~%" type) + (tc:with-pprint-variable-context () + (format t "~S~%" type)) type)) (defun coalton:kind-of (symbol) From fde68b56fae7a9b173badf0a43908e85443430d2 Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Wed, 16 Oct 2024 14:53:30 -0700 Subject: [PATCH 12/19] added type alias documentation guide --- docs/coalton-documentation-guide.md | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/docs/coalton-documentation-guide.md b/docs/coalton-documentation-guide.md index 2e5584d41..bc45007b5 100644 --- a/docs/coalton-documentation-guide.md +++ b/docs/coalton-documentation-guide.md @@ -33,6 +33,16 @@ that contains a filling of various sweet or savoury ingredients." (Meat String) "A meat pie with the type of meat.")) ``` +### `define-alias` + +`define-alias` allows for the same docstring style as `define`. + +```lisp +(coalton-toplevel + + (define-alias Index Integer + "This is an alias for a discrete numeric type: INTEGER")) + ### `define-class` `define-class` allows for documentation both on the main form and in each method. From 5851da61b96726e42b26b0e2fc066d3136ae4456 Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Thu, 17 Oct 2024 09:45:42 -0700 Subject: [PATCH 13/19] removed empty line --- docs/coalton-documentation-guide.md | 1 - 1 file changed, 1 deletion(-) diff --git a/docs/coalton-documentation-guide.md b/docs/coalton-documentation-guide.md index bc45007b5..5ce08a65c 100644 --- a/docs/coalton-documentation-guide.md +++ b/docs/coalton-documentation-guide.md @@ -39,7 +39,6 @@ that contains a filling of various sweet or savoury ingredients." ```lisp (coalton-toplevel - (define-alias Index Integer "This is an alias for a discrete numeric type: INTEGER")) From ff0e7f71131c98c21d973ad71b31bf69b222b51d Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Thu, 17 Oct 2024 09:46:33 -0700 Subject: [PATCH 14/19] changed :nil to nil --- src/parser/toplevel.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parser/toplevel.lisp b/src/parser/toplevel.lisp index 2ffb24b09..1557cec22 100644 --- a/src/parser/toplevel.lisp +++ b/src/parser/toplevel.lisp @@ -278,7 +278,7 @@ (defstruct (toplevel-define-alias (:include toplevel-definition) - (:copier :nil)) + (:copier nil)) (name (util:required 'name) :type identifier-src :read-only t) (vars (util:required 'vars) :type keyword-src-list :read-only t) (type (util:required 'type) :type ty :read-only t) From 9b3beda0bbc78b5dd029a0f229c4c08f8203bd7f Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Thu, 17 Oct 2024 09:48:34 -0700 Subject: [PATCH 15/19] added documentation to *pprint-aliases* --- src/typechecker/base.lisp | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/typechecker/base.lisp b/src/typechecker/base.lisp index 5f73c254a..80e70e1dc 100644 --- a/src/typechecker/base.lisp +++ b/src/typechecker/base.lisp @@ -61,7 +61,8 @@ This requires a valid PPRINT-VARIABLE-CONTEXT") (with-pprint-variable-scope () ,@body))) -(defvar *pprint-aliases* nil) +(defvar *pprint-aliases* nil + "Whether to display aliases associated with the type of a symbol, when displaying its type") ;;; ;;; Conditions From 57366b7f79147a4d910d218292688914c7a876a8 Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Thu, 17 Oct 2024 10:58:04 -0700 Subject: [PATCH 16/19] changed define-alias -> define-type-alias --- coalton.asd | 2 +- docs/coalton-documentation-guide.md | 8 +- docs/intro-to-coalton.md | 14 +- src/debug.lisp | 10 +- src/entry.lisp | 2 +- src/faux-macros.lisp | 4 +- src/package.lisp | 4 +- src/parser/collect.lisp | 8 +- src/parser/renamer.lisp | 18 +-- src/parser/toplevel.lisp | 123 ++++++++---------- src/parser/type-definition.lisp | 18 +-- src/typechecker/base.lisp | 6 +- src/typechecker/define-type.lisp | 49 +++---- src/typechecker/environment.lisp | 86 ++++++------ src/typechecker/parse-type.lisp | 38 +++--- src/typechecker/type-errors.lisp | 16 +-- src/typechecker/types.lisp | 12 +- tests/coalton-tests.lisp | 2 +- ...define-alias.txt => define-type-alias.txt} | 70 +++++----- ...alias-tests.lisp => type-alias-tests.lisp} | 54 ++++---- 20 files changed, 267 insertions(+), 277 deletions(-) rename tests/test-files/{define-alias.txt => define-type-alias.txt} (67%) rename tests/{alias-tests.lisp => type-alias-tests.lisp} (64%) diff --git a/coalton.asd b/coalton.asd index bcffa4711..f8a1d84bc 100644 --- a/coalton.asd +++ b/coalton.asd @@ -256,7 +256,7 @@ (:file "recursive-let-tests") (:file "class-tests") (:file "struct-tests") - (:file "alias-tests") + (:file "type-alias-tests") (:file "list-tests") (:file "lisparray-tests") (:file "red-black-tests") diff --git a/docs/coalton-documentation-guide.md b/docs/coalton-documentation-guide.md index 5ce08a65c..81d8b10c8 100644 --- a/docs/coalton-documentation-guide.md +++ b/docs/coalton-documentation-guide.md @@ -33,14 +33,14 @@ that contains a filling of various sweet or savoury ingredients." (Meat String) "A meat pie with the type of meat.")) ``` -### `define-alias` +### `define-type-alias` -`define-alias` allows for the same docstring style as `define`. +`define-type-alias` allows for the same docstring style as `define`. ```lisp (coalton-toplevel - (define-alias Index Integer - "This is an alias for a discrete numeric type: INTEGER")) + (define-type-alias Index Integer + "This is a type alias for a discrete numeric type: INTEGER")) ### `define-class` diff --git a/docs/intro-to-coalton.md b/docs/intro-to-coalton.md index 3ac9088ea..0e277e7e9 100644 --- a/docs/intro-to-coalton.md +++ b/docs/intro-to-coalton.md @@ -274,14 +274,14 @@ We'll see how to unpack these types using `match` later in this document. ## Type Aliases -Coalton allows the definition of parametric type aliases. Type aliases can be defined on primitive types and types created with `define-type` or `define-alias`. +Coalton allows the definition of parametric type aliases. Type aliases can be defined on primitive types and types created with `define-type` or `define-type-alias`. ```lisp (coalton-toplevel - ;; New aliases are created with the DEFINE-ALIAS operator - (define-alias Coordinate Integer) - (define-alias (Pair :a) (Tuple :a :a)) - (define-alias Translation (Pair Coordinate -> Pair Coordinate)) + ;; New type aliases are created with the DEFINE-TYPE-ALIAS operator + (define-type-alias Coordinate Integer) + (define-type-alias (Pair :a) (Tuple :a :a)) + (define-type-alias Translation (Pair Coordinate -> Pair Coordinate)) (declare shift-right Translation) (define (shift-right (Tuple x y)) @@ -290,7 +290,7 @@ Coalton allows the definition of parametric type aliases. Type aliases can be de (define shifted-coordinate (shift-right (Tuple 0 0)))) ``` -Outside of a Coalton expression, `describe-type-of` displays the type of a symbol, including its aliases, and returns the type. `describe-alias` displays the alias along with its base type and returns the base type. +Outside of a Coalton expression, `describe-type-of` displays the type of a symbol, including its aliases, and returns the type. `describe-type-alias` displays the alias along with its base type and returns the base type. ```lisp COALTON-USER> shifted-coordinate @@ -302,7 +302,7 @@ COALTON-USER> (type-of 'shifted-coordinate) COALTON-USER> (describe-type-of 'shifted-coordinate) [(PAIR COORDINATE) := (TUPLE [COORDINATE := INTEGER] [COORDINATE := INTEGER])] -COALTON-USER> (describe-alias 'Pair) +COALTON-USER> (describe-type-alias 'Pair) [(PAIR :A) := (TUPLE :A :A)] ``` diff --git a/src/debug.lisp b/src/debug.lisp index 666f6f3ad..71b99cdf5 100644 --- a/src/debug.lisp +++ b/src/debug.lisp @@ -175,15 +175,15 @@ (defun coalton:describe-type-of (symbol) "Print the type of value SYMBOL along with its type aliases and return it" - (let ((tc:*pprint-aliases* t) + (let ((tc:*pprint-type-aliases* t) (type (tc:lookup-value-type entry:*global-environment* symbol))) (format t "~S~%" type) type)) -(defun coalton:describe-alias (symbol) - "Lookup the type represented by the alias SYMBOL in the global environment" - (let ((tc:*pprint-aliases* t) - (type (tc:alias-entry-type (tc:lookup-alias entry:*global-environment* symbol)))) +(defun coalton:describe-type-alias (symbol) + "Lookup the type represented by the type alias SYMBOL in the global environment" + (let ((tc:*pprint-type-aliases* t) + (type (tc:type-alias-entry-type (tc:lookup-type-alias entry:*global-environment* symbol)))) (tc:with-pprint-variable-context () (format t "~S~%" type)) type)) diff --git a/src/entry.lisp b/src/entry.lisp index 3d8ac293a..f9268f6f3 100644 --- a/src/entry.lisp +++ b/src/entry.lisp @@ -37,7 +37,7 @@ (multiple-value-bind (type-definitions instances env) (tc:toplevel-define-type (parser:program-types program) (parser:program-structs program) - (parser:program-aliases program) + (parser:program-type-aliases program) env) (let ((all-instances (append instances (parser:program-instances program)))) diff --git a/src/faux-macros.lisp b/src/faux-macros.lisp index b14b0a656..9a80babbc 100644 --- a/src/faux-macros.lisp +++ b/src/faux-macros.lisp @@ -33,8 +33,8 @@ (define-coalton-editor-macro coalton:define-type (name &body definition) "Create a new algebraic data type named NAME. (Coalton top-level operator.)") -(define-coalton-editor-macro coalton:define-alias (name &body definition) - "Create a new alias named NAME. (Coalton top-level operator.)") +(define-coalton-editor-macro coalton:define-type-alias (name &body definition) + "Create a new type alias named NAME. (Coalton top-level operator.)") (define-coalton-editor-macro coalton:define-struct (name &body definition) "Create a new sruct named NAME. (Coalton top-level operator.)") diff --git a/src/package.lisp b/src/package.lisp index 1a077ca59..96c438b70 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -23,7 +23,7 @@ #:declare #:define #:define-type - #:define-alias + #:define-type-alias #:define-struct #:define-class #:define-instance @@ -110,7 +110,7 @@ #:lookup-fundeps #:type-of #:describe-type-of - #:describe-alias + #:describe-type-alias #:kind-of) (:intern diff --git a/src/parser/collect.lisp b/src/parser/collect.lisp index 16191c287..7e8fd86ae 100644 --- a/src/parser/collect.lisp +++ b/src/parser/collect.lisp @@ -60,9 +60,9 @@ (declare (values tycon-list)) (mapcan #'collect-referenced-types-generic% (toplevel-define-type-ctors type))) - (:method ((alias toplevel-define-alias)) + (:method ((alias toplevel-define-type-alias)) (declare (values (tycon-list))) - (collect-referenced-types-generic% (toplevel-define-alias-type alias))) + (collect-referenced-types-generic% (toplevel-define-type-alias-type alias))) (:method ((field struct-field)) (declare (values tycon-list &optional)) @@ -110,9 +110,9 @@ (declare (values tyvar-list)) (mapcan #'collect-type-variables-generic% (toplevel-define-type-ctors type))) - (:method ((alias toplevel-define-alias)) + (:method ((alias toplevel-define-type-alias)) (declare (values tyvar-list)) - (collect-type-variables-generic% (toplevel-define-alias-type alias))) + (collect-type-variables-generic% (toplevel-define-type-alias-type alias))) (:method ((method method-definition)) (declare (values tyvar-list &optional)) diff --git a/src/parser/renamer.lisp b/src/parser/renamer.lisp index 896fe1e2a..ba20eba55 100644 --- a/src/parser/renamer.lisp +++ b/src/parser/renamer.lisp @@ -516,7 +516,7 @@ (make-program :package (program-package program) :types (rename-type-variables (program-types program)) - :aliases (rename-type-variables (program-aliases program)) + :type-aliases (rename-type-variables (program-type-aliases program)) :structs (rename-type-variables (program-structs program)) :declares (program-declares program) :defines (rename-variables-generic% (program-defines program) ctx) @@ -628,23 +628,23 @@ :repr (toplevel-define-type-repr toplevel) :head-location (toplevel-define-type-head-location toplevel)))) - (:method ((toplevel toplevel-define-alias) ctx) + (:method ((toplevel toplevel-define-type-alias) ctx) (declare (type algo:immutable-map ctx) - (values toplevel-define-alias)) + (values toplevel-define-type-alias)) - (let* ((tvars (mapcar #'keyword-src-name (toplevel-define-alias-vars toplevel))) + (let* ((tvars (mapcar #'keyword-src-name (toplevel-define-type-alias-vars toplevel))) (new-bindings (make-local-vars tvars :package util:+keyword-package+)) (new-ctx (algo:immutable-map-set-multiple ctx new-bindings))) - (make-toplevel-define-alias - :name (toplevel-define-alias-name toplevel) - :vars (rename-type-variables-generic% (toplevel-define-alias-vars toplevel) new-ctx) + (make-toplevel-define-type-alias + :name (toplevel-define-type-alias-name toplevel) + :vars (rename-type-variables-generic% (toplevel-define-type-alias-vars toplevel) new-ctx) :docstring (source:docstring toplevel) - :type (rename-type-variables-generic% (toplevel-define-alias-type toplevel) new-ctx) + :type (rename-type-variables-generic% (toplevel-define-type-alias-type toplevel) new-ctx) :location (source:location toplevel) - :head-location (toplevel-define-alias-head-location toplevel)))) + :head-location (toplevel-define-type-alias-head-location toplevel)))) (:method ((field struct-field) ctx) (declare (type algo:immutable-map ctx) diff --git a/src/parser/toplevel.lisp b/src/parser/toplevel.lisp index 1557cec22..20bea6e38 100644 --- a/src/parser/toplevel.lisp +++ b/src/parser/toplevel.lisp @@ -36,13 +36,13 @@ #:toplevel-define-type-repr ; ACCESSOR #:toplevel-define-type-head-location ; ACCESSOR #:toplevel-define-type-list ; TYPE - #:toplevel-define-alias ; STRUCT - #:make-toplevel-define-alias ; CONSTRUCTOR - #:toplevel-define-alias-name ; ACCESSOR - #:toplevel-define-alias-vars ; ACCESSOR - #:toplevel-define-alias-type ; ACCESSOR - #:toplevel-define-alias-head-location ; ACCESSOR - #:toplevel-define-alias-list ; TYPE + #:toplevel-define-type-alias ; STRUCT + #:make-toplevel-define-type-alias ; CONSTRUCTOR + #:toplevel-define-type-alias-name ; ACCESSOR + #:toplevel-define-type-alias-vars ; ACCESSOR + #:toplevel-define-type-alias-type ; ACCESSOR + #:toplevel-define-type-alias-head-location ; ACCESSOR + #:toplevel-define-type-alias-list ; TYPE #:struct-field ; STRUCT #:make-struct-field ; CONSTRUCTOR #:struct-field-name ; ACCESSOR @@ -119,7 +119,7 @@ #:program-package ; ACCESSOR #:program-lisp-forms ; ACCESSOR #:program-types ; ACCESSOR - #:program-aliases ; ACCESSOR + #:program-type-aliases ; ACCESSOR #:program-structs ; ACCESSOR #:program-declares ; ACCESSOR #:program-defines ; ACCESSOR @@ -177,8 +177,8 @@ ;;;; toplevel-define-type := "(" "define-type" identifier docstring? constructor* ")" ;;;; | "(" "define-type" "(" identifier keyword+ ")" docstring? constructor* ")" ;;;; -;;;; toplevel-define-alias := "(" "define-alias" identifier ty docstring? ")" -;;;; | "(" "define-alias" "(" identifier keyword+ ")" ty docstring? ")" +;;;; toplevel-define-type-alias := "(" "define-type-alias" identifier ty docstring? ")" +;;;; | "(" "define-type-alias" "(" identifier keyword+ ")" ty docstring? ")" ;;;; ;;;; struct-field := "(" identifier docstring? type ")" ;;;; @@ -276,7 +276,7 @@ (deftype toplevel-define-type-list () '(satisfies toplevel-define-type-list-p)) -(defstruct (toplevel-define-alias +(defstruct (toplevel-define-type-alias (:include toplevel-definition) (:copier nil)) (name (util:required 'name) :type identifier-src :read-only t) @@ -285,12 +285,12 @@ (head-location (util:required 'head-location) :type source:location :read-only t)) (eval-when (:load-toplevel :compile-toplevel :execute) - (defun toplevel-define-alias-list-p (x) + (defun toplevel-define-type-alias-list-p (x) (and (alexandria:proper-list-p x) - (every #'toplevel-define-alias-p x)))) + (every #'toplevel-define-type-alias-p x)))) -(deftype toplevel-define-alias-list () - '(satisfies toplevel-define-alias-list-p)) +(deftype toplevel-define-type-alias-list () + '(satisfies toplevel-define-type-alias-list-p)) (defstruct (struct-field (:include toplevel-definition) @@ -491,16 +491,16 @@ (export nil :type list)) (defstruct program - (package nil :type (or null toplevel-package) :read-only t) - (types nil :type toplevel-define-type-list :read-only nil) - (aliases nil :type toplevel-define-alias-list :read-only nil) - (structs nil :type toplevel-define-struct-list :read-only nil) - (declares nil :type toplevel-declare-list :read-only nil) - (defines nil :type toplevel-define-list :read-only nil) - (classes nil :type toplevel-define-class-list :read-only nil) - (instances nil :type toplevel-define-instance-list :read-only nil) - (lisp-forms nil :type toplevel-lisp-form-list :read-only nil) - (specializations nil :type toplevel-specialize-list :read-only nil)) + (package nil :type (or null toplevel-package) :read-only t) + (types nil :type toplevel-define-type-list :read-only nil) + (type-aliases nil :type toplevel-define-type-alias-list :read-only nil) + (structs nil :type toplevel-define-struct-list :read-only nil) + (declares nil :type toplevel-declare-list :read-only nil) + (defines nil :type toplevel-define-list :read-only nil) + (classes nil :type toplevel-define-class-list :read-only nil) + (instances nil :type toplevel-define-instance-list :read-only nil) + (lisp-forms nil :type toplevel-lisp-form-list :read-only nil) + (specializations nil :type toplevel-specialize-list :read-only nil)) (defun read-program (stream source &optional mode) "Read a PROGRAM from SOURCE (an instance of source-error:source). @@ -548,7 +548,7 @@ If MODE is :macro, a package form is forbidden, and an explicit check is made fo "attribute must be attached to another form"))) (setf (program-types program) (nreverse (program-types program))) - (setf (program-aliases program) (nreverse (program-aliases program))) + (setf (program-type-aliases program) (nreverse (program-type-aliases program))) (setf (program-structs program) (nreverse (program-structs program))) (setf (program-declares program) (nreverse (program-declares program))) (setf (program-defines program) (nreverse (program-defines program))) @@ -887,25 +887,10 @@ If the parsed form is an attribute (e.g., repr or monomorphize), add it to to AT (push type (program-types program)) t)) - ((coalton:define-alias) - (let* ((alias (parse-define-alias form source))) - - (loop :for (attribute . attribute-form) :across attributes - :do (etypecase attribute - (attribute-repr - (parse-error "Invalid target for repr attribute" - (note source attribute-form - "repr must be attached to a define-type") - (source:note alias "when parsing define-alias"))) - - (attribute-monomorphize - (parse-error "Invalid target for monomorphize attribute" - (note source attribute-form - "monomorphize must be attached to a define or declare form") - (source:note alias "when parsing define-alias"))))) - - (setf (fill-pointer attributes) 0) - (push alias (program-aliases program)) + ((coalton:define-type-alias) + (forbid-attributes attributes form source) + (let ((alias (parse-define-type-alias form source))) + (push alias (program-type-aliases program)) t)) ((coalton:define-struct) @@ -1157,9 +1142,9 @@ consume all attributes"))) :location (form-location source form) :head-location (form-location source (cst:second form))))) -(defun parse-define-alias (form source) +(defun parse-define-type-alias (form source) (declare (type cst:cst form) - (values toplevel-define-alias)) + (values toplevel-define-type-alias)) (assert (cst:consp form)) @@ -1167,28 +1152,28 @@ consume all attributes"))) name variables) - ;; (define-alias) + ;; (define-type-alias) (unless (cst:consp (cst:rest form)) - (parse-error "Malformed alias definition" + (parse-error "Malformed type alias definition" (note source form "expected body"))) (cond - ;; (define-alias _ ...) + ;; (define-type-alias _ ...) ((cst:atom (cst:second form)) - ;; (define-alias 0.5 ...) + ;; (define-type-alias 0.5 ...) (unless (identifierp (cst:raw (cst:second form))) - (parse-error "Malformed alias definition" + (parse-error "Malformed type alias definition" (note source (cst:second form) "expected symbol"))) - ;; (define-alias name ...) + ;; (define-type-alias name ...) (setf name (make-identifier-src :name (cst:raw (cst:second form)) :location (form-location source form)))) - ;; (define-alias (_ ...) ...) + ;; (define-type-alias (_ ...) ...) (t - ;; (define-alias((name) ...) ...) + ;; (define-type-alias((name) ...) ...) (unless (cst:atom (cst:first (cst:second form))) - (parse-error "Malformed alias definition" + (parse-error "Malformed type alias definition" (note source (cst:first (cst:second form)) "expected symbol") (help source (cst:second form) @@ -1196,51 +1181,51 @@ consume all attributes"))) (subseq existing 1 (1- (length existing)))) "remove parentheses"))) - ;; (define-alias (0.5 ...) ...) + ;; (define-type-alias (0.5 ...) ...) (unless (identifierp (cst:raw (cst:first (cst:second form)))) - (parse-error "Malformed alias definition" + (parse-error "Malformed type alias definition" (note source (cst:first (cst:second form)) "expected symbol"))) - ;; (define-alias (name ...) ...) + ;; (define-type-alias (name ...) ...) (setf name (make-identifier-src :name (cst:raw (cst:first (cst:second form))) :location (form-location source (cst:first (cst:second form))))) - ;; (define-alias (name) ...) + ;; (define-type-alias (name) ...) (when (cst:atom (cst:rest (cst:second form))) - (parse-error "Malformed alias definition" + (parse-error "Malformed type alias definition" (note source (cst:second form) - "nullary aliases should not have parentheses") + "nullary type aliases should not have parentheses") (help source (cst:second form) (lambda (existing) (subseq existing 1 (1- (length existing)))) "remove unnecessary parentheses"))) - ;; (define-alias (name type-variables+) ...) + ;; (define-type-alias (name type-variables+) ...) (loop :for vars := (cst:rest (cst:second form)) :then (cst:rest vars) :while (cst:consp vars) :do (push (parse-type-variable (cst:first vars) source) variables)))) - ;; (define-alias name) + ;; (define-type-alias name) (unless (cst:consp (cst:rest (cst:rest form))) - (parse-error "Malformed alias definition" + (parse-error "Malformed type alias definition" (note source form "expected type"))) - ;; (define-alias name type docstring) + ;; (define-type-alias name type docstring) (when (and (cst:consp (cst:nthrest 3 form)) (cst:atom (cst:fourth form)) (stringp (cst:raw (cst:fourth form)))) (setf docstring (cst:raw (cst:fourth form)))) - ;; (define-alias name type docstring ...) + ;; (define-type-alias name type docstring ...) (when (and docstring (cst:consp (cst:nthrest 4 form))) - (parse-error "Malformed alias definition" + (parse-error "Malformed type alias definition" (note source (cst:fifth form) "unexpected trailing form"))) - (make-toplevel-define-alias + (make-toplevel-define-type-alias :name name :vars (reverse variables) :type (parse-type (cst:third form) source) diff --git a/src/parser/type-definition.lisp b/src/parser/type-definition.lisp index 3a1dfe2bf..126764fbb 100644 --- a/src/parser/type-definition.lisp +++ b/src/parser/type-definition.lisp @@ -30,7 +30,7 @@ (in-package #:coalton-impl/parser/type-definition) (deftype type-definition () - '(or toplevel-define-type toplevel-define-struct toplevel-define-alias)) + '(or toplevel-define-type toplevel-define-struct toplevel-define-type-alias)) (defun type-definition-p (x) (typep x 'type-definition)) @@ -51,9 +51,9 @@ (declare (values identifier-src)) (toplevel-define-struct-name def)) - (:method ((def toplevel-define-alias)) + (:method ((def toplevel-define-type-alias)) (declare (values identifier-src)) - (toplevel-define-alias-name def))) + (toplevel-define-type-alias-name def))) (defgeneric type-definition-vars (def) (:method ((def toplevel-define-type)) @@ -64,9 +64,9 @@ (declare (values keyword-src-list)) (toplevel-define-struct-vars def)) - (:method ((def toplevel-define-alias)) + (:method ((def toplevel-define-type-alias)) (declare (values keyword-src-list)) - (toplevel-define-alias-vars def))) + (toplevel-define-type-alias-vars def))) (defgeneric type-definition-repr (def) (:method ((def toplevel-define-type)) @@ -77,7 +77,7 @@ (declare (values (or null attribute-repr))) (toplevel-define-struct-repr def)) - (:method ((def toplevel-define-alias)) + (:method ((def toplevel-define-type-alias)) (declare (values (or null attribute-repr))) nil)) @@ -90,9 +90,9 @@ (declare (values (or null ty))) nil) - (:method ((def toplevel-define-alias)) + (:method ((def toplevel-define-type-alias)) (declare (values (or null ty))) - (toplevel-define-alias-type def))) + (toplevel-define-type-alias-type def))) (defgeneric type-definition-ctors (def) (:method ((def toplevel-define-type)) @@ -103,7 +103,7 @@ (declare (values toplevel-define-struct-list)) (list def)) - (:method ((def toplevel-define-alias)) + (:method ((def toplevel-define-type-alias)) (declare (values null)) nil)) diff --git a/src/typechecker/base.lisp b/src/typechecker/base.lisp index 80e70e1dc..e12ed4773 100644 --- a/src/typechecker/base.lisp +++ b/src/typechecker/base.lisp @@ -9,7 +9,7 @@ #:*pprint-tyvar-dict* #:*pprint-variable-symbol-code* #:*pprint-variable-symbol-suffix* - #:*pprint-aliases* + #:*pprint-type-aliases* #:tc-error ; CONDITION, FUNCTION #:tc-location #:tc-secondary-location @@ -61,7 +61,7 @@ This requires a valid PPRINT-VARIABLE-CONTEXT") (with-pprint-variable-scope () ,@body))) -(defvar *pprint-aliases* nil +(defvar *pprint-type-aliases* nil "Whether to display aliases associated with the type of a symbol, when displaying its type") ;;; @@ -79,7 +79,7 @@ This requires a valid PPRINT-VARIABLE-CONTEXT") (apply #'format nil format-string format-args)))) (defun tc-note (located format-string &rest format-args) - (let ((*pprint-aliases* t)) + (let ((*pprint-type-aliases* t)) (apply #'tc-location (source:location located) format-string format-args))) (defun tc-secondary-note (located format-string &rest format-args) diff --git a/src/typechecker/define-type.lisp b/src/typechecker/define-type.lisp index 068161fb2..774392207 100644 --- a/src/typechecker/define-type.lisp +++ b/src/typechecker/define-type.lisp @@ -78,15 +78,15 @@ (deftype type-definition-list () '(satisfies type-definition-list-p)) -(defun toplevel-define-type (types structs aliases env) +(defun toplevel-define-type (types structs type-aliases env) (declare (type parser:toplevel-define-type-list types) (type parser:toplevel-define-struct-list structs) - (type parser:toplevel-define-alias-list aliases) + (type parser:toplevel-define-type-alias-list type-aliases) (type tc:environment env) (values type-definition-list parser:toplevel-define-instance-list tc:environment)) ;; Ensure that all types are defined in the current package - (check-package (append types structs aliases) + (check-package (append types structs type-aliases) (alexandria:compose #'parser:identifier-src-name #'parser:type-definition-name) (alexandria:compose #'source:location @@ -102,7 +102,7 @@ ;; Ensure that there are no duplicate type definitions (check-duplicates - (append types structs aliases) + (append types structs type-aliases) (alexandria:compose #'parser:identifier-src-name #'parser:type-definition-name) (lambda (first second) (tc:tc-error "Duplicate type definitions" @@ -113,7 +113,7 @@ ;; NOTE: structs define a constructor with the same name (check-duplicates (mapcan (alexandria:compose #'copy-list #'parser:type-definition-ctors) - (append types structs aliases)) + (append types structs type-aliases)) (alexandria:compose #'parser:identifier-src-name #'parser:type-definition-ctor-name) (lambda (first second) (tc:tc-error "Duplicate constructor definitions" @@ -121,7 +121,7 @@ (tc:tc-note second "second definition here")))) ;; Ensure that no type has duplicate type variables - (loop :for type :in (append types structs aliases) + (loop :for type :in (append types structs type-aliases) :do (check-duplicates (parser:type-definition-vars type) #'parser:keyword-src-name @@ -132,10 +132,10 @@ (let* ((type-names (mapcar (alexandria:compose #'parser:identifier-src-name #'parser:type-definition-name) - (append types structs aliases))) + (append types structs type-aliases))) (type-dependencies - (loop :for type :in (append types structs aliases) + (loop :for type :in (append types structs type-aliases) :for referenced-types := (parser:collect-referenced-types type) :collect (list* (parser:identifier-src-name (parser:type-definition-name type)) @@ -145,7 +145,7 @@ (type-table (loop :with table := (make-hash-table :test #'eq) - :for type :in (append types structs aliases) + :for type :in (append types structs type-aliases) :for type-name := (parser:identifier-src-name (parser:type-definition-name type)) :do (setf (gethash type-name table) type) :finally (return table))) @@ -216,24 +216,24 @@ (when (plusp (tc:constructor-entry-arity ctor-entry)) (setf env (tc:unset-function env constructor)))))) - (cond ((typep parsed-type 'parser:toplevel-define-alias) + (cond ((typep parsed-type 'parser:toplevel-define-type-alias) (let ((alias (tc:apply-type-argument-list (type-definition-type type) tyvars)) (aliased-type (type-definition-aliased-type type))) (setf aliased-type - (tc:push-alias aliased-type - (tc:apply-ksubstitution - (tc:kind-monomorphize-subs (tc:kind-variables tyvars) nil) - alias))) - (setf env (tc:set-alias + (tc:push-type-alias aliased-type + (tc:apply-ksubstitution + (tc:kind-monomorphize-subs (tc:kind-variables tyvars) nil) + alias))) + (setf env (tc:set-type-alias env (type-definition-name type) - (tc:make-alias-entry + (tc:make-type-alias-entry :name (type-definition-name type) :tyvars tyvars :type aliased-type :docstring nil))))) - ((tc:lookup-alias env (type-definition-name type) :no-error t) - (setf env (tc:unset-alias env (type-definition-name type))))) + ((tc:lookup-type-alias env (type-definition-name type) :no-error t) + (setf env (tc:unset-type-alias env (type-definition-name type))))) (cond ((typep parsed-type 'parser:toplevel-define-struct) (let ((fields (loop :for field @@ -312,7 +312,12 @@ env) -(defun check-for-unused-alias-type-variables (aliased-type parsed-type partial-env) +;; This function is necessary because the arguments of a type alias +;; and its used variables are processed at different steps in the +;; typechecker, which is unprecedented. The other main instance where +;; we check for unused type variables is qualified types, but in that +;; case, the type variables are processed all together. +(defun check-for-unused-type-alias-type-variables (aliased-type parsed-type partial-env) (declare (type tc:ty aliased-type) (type parser:type-definition parsed-type) (type partial-type-env partial-env)) @@ -321,11 +326,11 @@ (unused-variables (loop :for tyvar :in defined-variables :when (not (member (tc:tyvar-id (partial-type-env-lookup-var partial-env tyvar parsed-type)) used-variables)) - :collect tyvar)) + :collect tyvar)) (number-of-unused-variables (length unused-variables))) (unless (zerop number-of-unused-variables) (tc-error (format nil "Alias type variable~P defined but never used" number-of-unused-variables) - (tc-note parsed-type "Alias ~S defines unused type variable~P ~{:~A~^ ~}" + (tc-note parsed-type "Type alias ~S defines unused type variable~P ~{:~A~^ ~}" (parser:identifier-src-name (parser:type-definition-name parsed-type)) number-of-unused-variables (mapcar (lambda (str) (subseq str 0 (- (length str) 5))) @@ -464,7 +469,7 @@ (parser:type-definition-aliased-type type))) (when parser-aliased-type (let ((aliased-type (parse-type parser-aliased-type env))) - (check-for-unused-alias-type-variables aliased-type type env) + (check-for-unused-type-alias-type-variables aliased-type type env) aliased-type))) :explicit-repr (if (eq repr-type :native) (list repr-type repr-arg) diff --git a/src/typechecker/environment.lisp b/src/typechecker/environment.lisp index e9dab718f..f8697a94e 100644 --- a/src/typechecker/environment.lisp +++ b/src/typechecker/environment.lisp @@ -49,13 +49,13 @@ #:constructor-entry-compressed-repr ; ACCESSOR #:constructor-entry-list ; TYPE #:constructor-environment ; STRUCT - #:alias-entry ; STRUCT - #:make-alias-entry ; CONSTRUCTOR - #:alias-entry-name ; ACCESSOR - #:alias-entry-tyvars ; ACCESSOR - #:alias-entry-type ; ACCESSOR - #:alias-entry-list ; ACCESSOR - #:alias-environment ; STRUCT + #:type-alias-entry ; STRUCT + #:make-type-alias-entry ; CONSTRUCTOR + #:type-alias-entry-name ; ACCESSOR + #:type-alias-entry-tyvars ; ACCESSOR + #:type-alias-entry-type ; ACCESSOR + #:type-alias-entry-list ; ACCESSOR + #:type-alias-environment ; STRUCT #:struct-field ; STRUCT #:make-struct-field ; CONSTRUCTOR #:struct-field-name ; ACCESSOR @@ -119,7 +119,7 @@ #:make-default-environment ; FUNCTION #:environment-value-environment ; ACCESSOR #:environment-type-environment ; ACCESSOR - #:environment-alias-environment ; ACCESSOR + #:environment-type-alias-environment ; ACCESSOR #:environment-constructor-environment ; ACCESSOR #:environment-class-environment ; ACCESSOR #:environment-fundep-environment ; ACCESSOR @@ -137,9 +137,9 @@ #:lookup-constructor ; FUNCTION #:set-constructor ; FUNCTION #:unset-constructor ; FUNCTION - #:lookup-alias ; FUNCTION - #:set-alias ; FUNCTION - #:unset-alias ; FUNCTION + #:lookup-type-alias ; FUNCTION + #:set-type-alias ; FUNCTION + #:unset-type-alias ; FUNCTION #:lookup-struct ; FUNCTION #:set-struct ; FUNCTION #:unset-struct ; FUNCTION @@ -510,35 +510,35 @@ (declaim (sb-ext:freeze-type constructor-environment)) ;;; -;;; Alias environment +;;; Type alias environment ;;; -(defstruct alias-entry +(defstruct type-alias-entry (name (util:required 'name) :type symbol :read-only t) (tyvars (util:required 'tyvars) :type tyvar-list :read-only t) (type (util:required 'type) :type ty :read-only t) (docstring (util:required 'docstring) :type (or null string) :read-only t)) -(defmethod source:docstring ((self alias-entry)) - (alias-entry-docstring self)) +(defmethod source:docstring ((self type-alias-entry)) + (type-alias-entry-docstring self)) -(defmethod make-load-form ((self alias-entry) &optional env) +(defmethod make-load-form ((self type-alias-entry) &optional env) (make-load-form-saving-slots self :environment env)) #+(and sbcl coalton-release) -(declaim (sb-ext:freeze-type alias-entry)) +(declaim (sb-ext:freeze-type type-alias-entry)) -(defun alias-entry-list-p (x) +(defun type-alias-entry-list-p (x) (and (alexandria:proper-list-p x) - (every #'alias-entry-p x))) + (every #'type-alias-entry-p x))) -(deftype alias-entry-list () - '(satisfies alias-entry-list-p)) +(deftype type-alias-entry-list () + '(satisfies type-alias-entry-list-p)) -(defstruct (alias-environment (:include immutable-map))) +(defstruct (type-alias-environment (:include immutable-map))) #+(and sbcl coalton-release) -(declaim (sb-ext:freeze-type alias-environment)) +(declaim (sb-ext:freeze-type type-alias-environment)) ;;; ;;; Struct environment @@ -844,7 +844,7 @@ (value-environment (util:required 'value-environment) :type value-environment :read-only t) (type-environment (util:required 'type-environment) :type type-environment :read-only t) (constructor-environment (util:required 'constructor-environment) :type constructor-environment :read-only t) - (alias-environment (util:required 'alias-environment) :type alias-environment :read-only t) + (type-alias-environment (util:required 'type-alias-environment) :type type-alias-environment :read-only t) (struct-environment (util:required 'struct-environment) :type struct-environment :read-only t) (class-environment (util:required 'class-environment) :type class-environment :read-only t) (fundep-environment (util:required 'fundep-environment) :type fundep-environment :read-only t) @@ -873,7 +873,7 @@ (make-environment :value-environment (make-value-environment) :type-environment (make-default-type-environment) - :alias-environment (make-alias-environment) + :type-alias-environment (make-type-alias-environment) :struct-environment (make-struct-environment) :constructor-environment (make-default-constructor-environment) :class-environment (make-class-environment) @@ -890,7 +890,7 @@ &key (value-environment (environment-value-environment env)) (type-environment (environment-type-environment env)) - (alias-environment (environment-alias-environment env)) + (type-alias-environment (environment-type-alias-environment env)) (constructor-environment (environment-constructor-environment env)) (struct-environment (environment-struct-environment env)) (class-environment (environment-class-environment env)) @@ -905,7 +905,7 @@ (declare (type environment env) (type value-environment value-environment) (type constructor-environment constructor-environment) - (type alias-environment alias-environment) + (type type-alias-environment type-alias-environment) (type struct-environment struct-environment) (type class-environment class-environment) (type fundep-environment fundep-environment) @@ -921,7 +921,7 @@ :value-environment value-environment :type-environment type-environment :constructor-environment constructor-environment - :alias-environment alias-environment + :type-alias-environment type-alias-environment :struct-environment struct-environment :class-environment class-environment :fundep-environment fundep-environment @@ -1037,34 +1037,34 @@ symbol #'make-constructor-environment))) -(defun lookup-alias (env symbol &key no-error) +(defun lookup-type-alias (env symbol &key no-error) (declare (type environment env) (type symbol symbol)) - (or (immutable-map-lookup (environment-alias-environment env) symbol) + (or (immutable-map-lookup (environment-type-alias-environment env) symbol) (unless no-error - (util:coalton-bug "Unknown alias ~S" symbol)))) + (util:coalton-bug "Unknown type-alias ~S" symbol)))) -(define-env-updater set-alias (env symbol value) +(define-env-updater set-type-alias (env symbol value) (declare (type environment env) (type symbol symbol) - (type alias-entry value)) + (type type-alias-entry value)) (update-environment env - :alias-environment (immutable-map-set - (environment-alias-environment env) - symbol - value - #'make-alias-environment))) + :type-alias-environment (immutable-map-set + (environment-type-alias-environment env) + symbol + value + #'make-type-alias-environment))) -(define-env-updater unset-alias (env symbol) +(define-env-updater unset-type-alias (env symbol) (declare (type environment env) (type symbol symbol)) (update-environment env - :alias-environment (immutable-map-remove - (environment-alias-environment env) - symbol - #'make-alias-environment))) + :type-alias-environment (immutable-map-remove + (environment-type-alias-environment env) + symbol + #'make-type-alias-environment))) (defun lookup-struct (env symbol &key no-error) (declare (type environment env) diff --git a/src/typechecker/parse-type.lisp b/src/typechecker/parse-type.lisp index 393c7021e..9771578f6 100644 --- a/src/typechecker/parse-type.lisp +++ b/src/typechecker/parse-type.lisp @@ -17,7 +17,7 @@ (#:source #:coalton-impl/source) (#:tc #:coalton-impl/typechecker/stage-1)) (:export - #:apply-alias-substitutions ; FUNCTION + #:apply-type-alias-substitutions ; FUNCTION #:parse-type ; FUNCTION #:parse-qualified-type ; FUNCTION #:parse-ty-scheme ; FUNCTION @@ -31,22 +31,22 @@ ;;; Entrypoints ;;; -(defgeneric apply-alias-substitutions (type parser-type env) +(defgeneric apply-type-alias-substitutions (type parser-type env) (:method ((type tc:tycon) parser-type env) (declare (type parser:ty parser-type) (type partial-type-env env) (values tc:ty)) - (let ((alias (tc:lookup-alias (partial-type-env-env env) (tc:tycon-name type) :no-error t))) + (let ((alias (tc:lookup-type-alias (partial-type-env-env env) (tc:tycon-name type) :no-error t))) (when alias (handler-case - (let ((substs (tc:match (first (tc:ty-alias (tc:alias-entry-type alias))) type))) - (setf type (tc:apply-substitution substs (tc:alias-entry-type alias)))) + (let ((substs (tc:match (first (tc:ty-alias (tc:type-alias-entry-type alias))) type))) + (setf type (tc:apply-substitution substs (tc:type-alias-entry-type alias)))) (tc:unification-error () - (tc-error "Incomplete alias application" + (tc-error "Incomplete type alias application" (tc-note parser-type "Type alias ~S is applied to 0 arguments, but ~D argument~:P ~:*~[are~;is~:;are~] required." - (tc:alias-entry-name alias) - (length (tc:alias-entry-tyvars alias))))))) + (tc:type-alias-entry-name alias) + (length (tc:type-alias-entry-tyvars type-alias))))))) type)) (:method ((type tc:tapp) parser-type env) @@ -54,25 +54,25 @@ (type partial-type-env env) (values tc:tapp)) (when (typep (tc:tapp-from type) 'tc:tycon) - (let ((alias (tc:lookup-alias (partial-type-env-env env) (tc:tycon-name (tc:tapp-from type)) :no-error t))) + (let ((alias (tc:lookup-type-alias (partial-type-env-env env) (tc:tycon-name (tc:tapp-from type)) :no-error t))) (when alias (handler-case - (let ((substs (tc:match (first (tc:ty-alias (tc:alias-entry-type alias))) type))) - (setf type (tc:apply-substitution substs (tc:alias-entry-type alias)))) + (let ((substs (tc:match (first (tc:ty-alias (tc:type-alias-entry-type alias))) type))) + (setf type (tc:apply-substitution substs (tc:type-alias-entry-type alias)))) (tc:unification-error () - (tc-error "Incomplete alias application" + (tc-error "Incomplete type alias application" (tc-note parser-type "Type alias ~S is applied to ~D argument~:P, but ~D argument~:P ~:*~[are~;is~:;are~] required." - (tc:alias-entry-name alias) + (tc:type-alias-entry-name alias) (let ((type_ (copy-structure type))) (loop :while (tc:tapp-p type_) :sum 1 :do (setf type_ (tc:tapp-to type_)))) - (length (tc:alias-entry-tyvars alias))))))))) + (length (tc:type-alias-entry-tyvars alias))))))))) (tc:make-tapp :alias (tc:ty-alias type) - :from (apply-alias-substitutions (tc:tapp-from type) parser-type env) - :to (apply-alias-substitutions (tc:tapp-to type) parser-type env))) + :from (apply-type-alias-substitutions (tc:tapp-from type) parser-type env) + :to (apply-type-alias-substitutions (tc:tapp-to type) parser-type env))) (:method ((type tc:qualified-ty) parser-type env) (declare (type parser:qualified-ty parser-type) @@ -80,7 +80,7 @@ (values tc:qualified-ty)) (tc:make-qualified-ty :predicates (tc:qualified-ty-predicates type) - :type (apply-alias-substitutions (tc:qualified-ty-type type) + :type (apply-type-alias-substitutions (tc:qualified-ty-type type) (parser:qualified-ty-type parser-type) env))) @@ -116,7 +116,7 @@ (setf ty (tc:apply-ksubstitution ksubs ty)) (setf ksubs (tc:kind-monomorphize-subs (tc:kind-variables ty) ksubs)) (setf ty (tc:apply-ksubstitution ksubs ty)) - (setf ty (apply-alias-substitutions ty parser-ty partial-env)) + (setf ty (apply-type-alias-substitutions ty parser-ty partial-env)) (values ty ksubs)))) (defun parse-qualified-type (unparsed-ty env) @@ -149,7 +149,7 @@ (check-for-ambiguous-variables preds ty unparsed-ty env) (check-for-reducible-context preds unparsed-ty env) - (apply-alias-substitutions qual-ty unparsed-ty partial-env))))) + (apply-type-alias-substitutions qual-ty unparsed-ty partial-env))))) (defun parse-ty-scheme (ty env) (declare (type parser:qualified-ty ty) diff --git a/src/typechecker/type-errors.lisp b/src/typechecker/type-errors.lisp index 217b4093f..19a407ff8 100644 --- a/src/typechecker/type-errors.lisp +++ b/src/typechecker/type-errors.lisp @@ -38,7 +38,7 @@ (lambda (c s) (let ((*print-circle* nil) ; Prevent printing using reader macros (*print-readably* nil) - (*pprint-aliases* nil)) + (*pprint-type-aliases* nil)) (format s "Failed to unify types ~S and ~S" (unification-error-type1 c) (unification-error-type2 c)))))) @@ -50,7 +50,7 @@ (lambda (c s) (let ((*print-circle* nil) ; Prevent printing using reader macros (*print-readably* nil) - (*pprint-aliases* nil)) + (*pprint-type-aliases* nil)) (format s "Cannot construct infinite type by unifying ~S with internal variable." (infinite-type-unification-error-type c)))))) @@ -64,7 +64,7 @@ (lambda (c s) (let ((*print-circle* nil) ; Prevent printing using reader macros (*print-readably* nil) - (*pprint-aliases* nil)) + (*pprint-type-aliases* nil)) (format s "Kind mismatch between type ~S of kind ~S and kind ~S" (kind-mismatch-error-type c) (kind-of (kind-mismatch-error-type c)) @@ -79,7 +79,7 @@ (lambda (c s) (let ((*print-circle* nil) ; Prevent printing using reader macros (*print-readably* nil) - (*pprint-aliases* nil)) + (*pprint-type-aliases* nil)) (format s "Kind mismatch between type ~S of kind ~S and type ~S kind ~S" (type-kind-mismatch-error-type1 c) (kind-of (type-kind-mismatch-error-type1 c)) @@ -95,7 +95,7 @@ (lambda (c s) (let ((*print-circle* nil) ; Prevent printing using reader macros (*print-readably* nil) - (*pprint-aliases* nil)) + (*pprint-type-aliases* nil)) (format s "Failed to unify types ~S and ~S" (unification-error-pred1 c) (unification-error-pred2 c)))))) @@ -107,7 +107,7 @@ (lambda (c s) (let ((*print-circle* nil) ; Prevent printing using reader macros (*print-readably* nil) - (*pprint-aliases* nil)) + (*pprint-type-aliases* nil)) (format s "Ambiguous constraint ~S~%" (ambiguous-constraint-pred c)))))) @@ -120,7 +120,7 @@ (lambda (c s) (let ((*print-circle* nil) ; Prevent printing using reader macros (*print-readably* nil) - (*pprint-aliases* nil)) + (*pprint-type-aliases* nil)) (format s "Instance ~S overlaps with instance ~S" (overlapping-instance-error-inst1 c) (overlapping-instance-error-inst2 c)))))) @@ -160,7 +160,7 @@ (lambda (c s) (let ((*print-circle* nil) ; Prevent printing using reader macros (*print-readably* nil) - (*pprint-aliases* nil)) + (*pprint-type-aliases* nil)) (with-pprint-variable-context () (format s "instance conflicts previous instance ~S" (fundep-conflict-old-pred c))))))) diff --git a/src/typechecker/types.lisp b/src/typechecker/types.lisp index 782be626e..64a28557e 100644 --- a/src/typechecker/types.lisp +++ b/src/typechecker/types.lisp @@ -48,7 +48,7 @@ #:*fraction-type* ; VARIABLE #:*arrow-type* ; VARIABLE #:*list-type* ; VARIABLE - #:push-alias ; FUNCTION + #:push-type-alias ; FUNCTION #:apply-type-argument ; FUNCTION #:apply-type-argument-list ; FUNCTION #:make-function-type ; FUNCTION @@ -208,7 +208,7 @@ (mapcan #'type-constructors-generic% lst))) (defgeneric ty= (type1 type2) - (:documentation "For equal types, apply the aliases in TYPE1 to TYPE2.") + (:documentation "Are TYPE1 to TYPE2 EQUALP, ignoring their aliases.") (:method ((type1 tyvar) (type2 tyvar)) (and (equalp (tyvar-id type1) @@ -258,7 +258,7 @@ ;;; Operations on Types ;;; -(defun push-alias (type alias) +(defun push-type-alias (type alias) (declare (type ty type) (type ty alias) (values ty &optional)) @@ -413,7 +413,7 @@ (declare (type stream stream) (type ty ty) (values ty)) - (when (and *pprint-aliases* (ty-alias ty)) + (when (and *pprint-type-aliases* (ty-alias ty)) (format stream "[~{~S := ~}" (ty-alias ty))) (etypecase ty (tyvar @@ -472,7 +472,7 @@ (tgen (write-string "#GEN" stream) (write (tgen-id ty) :stream stream))) - (when (and *pprint-aliases* (ty-alias ty)) + (when (and *pprint-type-aliases* (ty-alias ty)) (format stream "]")) ty) @@ -494,7 +494,7 @@ (lambda (c s) (let ((*print-circle* nil) ; Prevent printing using reader macros (*print-readably* nil) - (*print-aliases* nil)) + (*print-type-aliases* nil)) (format s "Cannot apply ~S of kind ~S to ~S of kind ~S" (type-application-error-argument c) (kind-of (type-application-error-argument c)) diff --git a/tests/coalton-tests.lisp b/tests/coalton-tests.lisp index cf61ebd29..c48412f7c 100644 --- a/tests/coalton-tests.lisp +++ b/tests/coalton-tests.lisp @@ -14,7 +14,7 @@ (%run-tests "define-class.txt") (%run-tests "define-instance.txt") (%run-tests "define-type.txt") - (%run-tests "define-alias.txt") + (%run-tests "define-type-alias.txt") (%run-tests "define.txt") (%run-tests "fundeps.txt") (%run-tests "hashtable.txt") diff --git a/tests/test-files/define-alias.txt b/tests/test-files/define-type-alias.txt similarity index 67% rename from tests/test-files/define-alias.txt rename to tests/test-files/define-type-alias.txt index 33b1eab0e..12a3d580e 100644 --- a/tests/test-files/define-alias.txt +++ b/tests/test-files/define-type-alias.txt @@ -1,126 +1,126 @@ ================================================================================ -1 Define alias +1 Define type alias ================================================================================ (package coalton-unit-tests) -(define-alias Index Integer) +(define-type-alias Index Integer) ================================================================================ -2 Define alias +2 Define type alias ================================================================================ (package coalton-unit-tests) -(define-alias UnaryIntegerOperator (Integer -> Integer)) +(define-type-alias UnaryIntegerOperator (Integer -> Integer)) ================================================================================ -3 Define alias +3 Define type alias ================================================================================ (package coalton-unit-tests) -(define-alias (UnaryOperator :a) (:a -> :a)) +(define-type-alias (UnaryOperator :a) (:a -> :a)) ================================================================================ -4 Define alias +4 Define type alias ================================================================================ (package coalton-unit-tests) -(define-alias (ReverseTranslationRules :a :b) (:b -> :a)) +(define-type-alias (ReverseTranslationRules :a :b) (:b -> :a)) ================================================================================ -5 Define alias +5 Define type alias ================================================================================ (package coalton-unit-tests) -(define-alias Index Integer) +(define-type-alias Index Integer) -(define-alias MyIndex Index) +(define-type-alias MyIndex Index) -(define-alias (Collection :a) (List :a)) +(define-type-alias (Collection :a) (List :a)) -(define-alias MyIndices (Collection MyIndex)) +(define-type-alias MyIndices (Collection MyIndex)) ================================================================================ -100 define-alias, parse-error +100 define-type-alias, parse-error ================================================================================ (package test-package) -(define-alias "Index" UFix) +(define-type-alias "Index" UFix) -------------------------------------------------------------------------------- -error: Malformed alias definition - --> test:3:14 +error: Malformed type alias definition + --> test:3:19 | - 3 | (define-alias "Index" UFix) - | ^^^^^^^ expected symbol + 3 | (define-type-alias "Index" UFix) + | ^^^^^^^ expected symbol ================================================================================ -101 define-alias, parse-error +101 define-type-alias, parse-error ================================================================================ (package test-package) -(define-alias Index UFix +(define-type-alias Index UFix "An index" "A really good index") -------------------------------------------------------------------------------- -error: Malformed alias definition +error: Malformed type alias definition --> test:5:2 | 5 | "A really good index") | ^^^^^^^^^^^^^^^^^^^^^ unexpected trailing form ================================================================================ -102 define-alias, type variables +102 define-type-alias, type variables ================================================================================ (package test-package) -(define-alias (Collection :a) (List :b)) +(define-type-alias (Collection :a) (List :b)) -------------------------------------------------------------------------------- error: Unknown type variable - --> test:3:36 + --> test:3:41 | - 3 | (define-alias (Collection :a) (List :b)) - | ^^ Unknown type variable :B + 3 | (define-type-alias (Collection :a) (List :b)) + | ^^ Unknown type variable :B ================================================================================ -103 define-alias, type variables +103 define-type-alias, type variables ================================================================================ (package test-package) -(define-alias (Collection :a) (List Integer)) +(define-type-alias (Collection :a) (List Integer)) -------------------------------------------------------------------------------- error: Alias type variable defined but never used --> test:3:0 | - 3 | (define-alias (Collection :a) (List Integer)) - | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Alias COLLECTION defines unused type variable :A + 3 | (define-type-alias (Collection :a) (List Integer)) + | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Type alias COLLECTION defines unused type variable :A ================================================================================ -104 define-alias, type errors +104 define-type-alias, type errors ================================================================================ (package test-package) -(define-alias Index UFix) +(define-type-alias Index UFix) -(define-alias MyIndex Index) +(define-type-alias MyIndex Index) -(define-alias (UnaryOperator :a) (:a -> :a)) +(define-type-alias (UnaryOperator :a) (:a -> :a)) (declare increment-my-index (UnaryOperator MyIndex)) (define increment-my-index (+ 1)) diff --git a/tests/alias-tests.lisp b/tests/type-alias-tests.lisp similarity index 64% rename from tests/alias-tests.lisp rename to tests/type-alias-tests.lisp index c09719c6b..407622068 100644 --- a/tests/alias-tests.lisp +++ b/tests/type-alias-tests.lisp @@ -1,34 +1,34 @@ -;;;; alias-tests.lisp +;;;; type-alias-tests.lisp (in-package #:coalton-tests) -(deftest test-alias-definition () +(deftest test-type-alias-definition () (check-coalton-types - "(define-alias UnaryIntegerOperator (Integer -> Integer))") + "(define-type-alias UnaryIntegerOperator (Integer -> Integer))") (check-coalton-types - "(define-alias UnaryIntegerOperator (Integer -> Integer) + "(define-type-alias UnaryIntegerOperator (Integer -> Integer) \"An alias for functions mapping integers to integers.\")")) -(deftest test-alias-the () +(deftest test-type-alias-the () (check-coalton-types - "(define-alias Index UFix) + "(define-type-alias Index UFix) (define i (the Index 5))" '("i" . "UFix")) (check-coalton-types - "(define-alias Index UFix) - (define-alias IndexList (List Index)) + "(define-type-alias Index UFix) + (define-type-alias IndexList (List Index)) (define indices (the IndexList (make-list 0 1 2 3 4 5)))" '("indices" . "(List UFix)"))) -(deftest test-alias-declare () +(deftest test-type-alias-declare () (check-coalton-types - "(define-alias Index UFix) + "(define-type-alias Index UFix) (declare i Index) (define i 5)" @@ -36,17 +36,17 @@ '("i" . "UFix")) (check-coalton-types - "(define-alias Index UFix) - (define-alias IndexList (List Index)) + "(define-type-alias Index UFix) + (define-type-alias IndexList (List Index)) (declare indices IndexList) (define indices (make-list 0 1 2 3 4 5))" '("indices" . "(List UFix)"))) -(deftest test-alias-constructors () +(deftest test-type-alias-constructors () (check-coalton-types - "(define-alias Coordinate IFix) + "(define-type-alias Coordinate IFix) (define-type Point (Point Coordinate Coordinate)) @@ -62,7 +62,7 @@ '("x" . "IFix")) (check-coalton-types - "(define-alias Coordinate IFix) + "(define-type-alias Coordinate IFix) (define-struct Point (x Coordinate) @@ -74,26 +74,26 @@ '("p" . "Point") '("x" . "IFix"))) -(deftest test-parametric-alias-definition () +(deftest test-parametric-type-alias-definition () (check-coalton-types - "(define-alias (UnaryOperator :a) (:a -> :a))") + "(define-type-alias (UnaryOperator :a) (:a -> :a))") (check-coalton-types - "(define-alias (Collapse :a :b :c :d) (:d -> :c -> :b -> :a))")) + "(define-type-alias (Collapse :a :b :c :d) (:d -> :c -> :b -> :a))")) -(deftest test-parametric-alias-the () +(deftest test-parametric-type-alias-the () (check-coalton-types - "(define-alias Index UFix) - (define-alias (Collection :a) (List :a)) + "(define-type-alias Index UFix) + (define-type-alias (Collection :a) (List :a)) (define l (the (Collection Index) (make-list 1 2 3 4)))" '("l" . "(List UFix)"))) -(deftest test-parametric-alias-declare () +(deftest test-parametric-type-alias-declare () (check-coalton-types - "(define-alias (UnaryOperator :a) (:a -> :a)) + "(define-type-alias (UnaryOperator :a) (:a -> :a)) (declare f (UnaryOperator Integer)) (define f 1+)" @@ -101,14 +101,14 @@ '("f" . "(Integer -> Integer)")) (check-coalton-types - "(define-alias (UnaryOperator :a) (:a -> :a)) + "(define-type-alias (UnaryOperator :a) (:a -> :a)) (declare f ((Num :a) => (UnaryOperator :a))) (define f 1+)")) -(deftest test-parametric-alias-constructors () +(deftest test-parametric-type-alias-constructors () (check-coalton-types - "(define-alias (Pair :a) (Tuple :a :a)) + "(define-type-alias (Pair :a) (Tuple :a :a)) (define-type (Translation :a) (Translation (Pair (Pair :a)))) @@ -124,7 +124,7 @@ '("x" . "Integer")) (check-coalton-types - "(define-alias (Pair :a) (Tuple :a :a)) + "(define-type-alias (Pair :a) (Tuple :a :a)) (define-struct (Translation :a) (from (Pair :a)) From 1aba69504a1d587880d9b6ad07e30782a47c339f Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Thu, 17 Oct 2024 13:15:26 -0700 Subject: [PATCH 17/19] Improved error message for unused type alias arguments --- src/typechecker/define-type.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/typechecker/define-type.lisp b/src/typechecker/define-type.lisp index 774392207..70b949aea 100644 --- a/src/typechecker/define-type.lisp +++ b/src/typechecker/define-type.lisp @@ -333,7 +333,7 @@ (tc-note parsed-type "Type alias ~S defines unused type variable~P ~{:~A~^ ~}" (parser:identifier-src-name (parser:type-definition-name parsed-type)) number-of-unused-variables - (mapcar (lambda (str) (subseq str 0 (- (length str) 5))) + (mapcar (lambda (str) (subseq str 0 (- (1+ (length str) (position #\- (reverse str)))))) (mapcar #'string unused-variables))))))) (defun infer-define-type-scc-kinds (types env) From e6784b8af41ddf55aaa321f5139265ec6d69c803 Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Thu, 17 Oct 2024 13:23:35 -0700 Subject: [PATCH 18/19] typo fix --- src/typechecker/define-type.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/typechecker/define-type.lisp b/src/typechecker/define-type.lisp index 70b949aea..24219759a 100644 --- a/src/typechecker/define-type.lisp +++ b/src/typechecker/define-type.lisp @@ -333,7 +333,7 @@ (tc-note parsed-type "Type alias ~S defines unused type variable~P ~{:~A~^ ~}" (parser:identifier-src-name (parser:type-definition-name parsed-type)) number-of-unused-variables - (mapcar (lambda (str) (subseq str 0 (- (1+ (length str) (position #\- (reverse str)))))) + (mapcar (lambda (str) (subseq str 0 (- (length str) (1+ (position #\- (reverse str)))))) (mapcar #'string unused-variables))))))) (defun infer-define-type-scc-kinds (types env) From 8619ceba30bdc39e007b943a068655ce1fe90dbc Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Mon, 18 Nov 2024 16:43:18 -0800 Subject: [PATCH 19/19] minor fixes --- src/typechecker/define-type.lisp | 8 ++++---- src/typechecker/types.lisp | 15 +++++++++++++-- 2 files changed, 17 insertions(+), 6 deletions(-) diff --git a/src/typechecker/define-type.lisp b/src/typechecker/define-type.lisp index 24219759a..64a2c51cc 100644 --- a/src/typechecker/define-type.lisp +++ b/src/typechecker/define-type.lisp @@ -324,8 +324,8 @@ (let* ((defined-variables (mapcar #'parser:keyword-src-name (parser:type-definition-vars parsed-type))) (used-variables (mapcar #'tc:tyvar-id (tc:type-variables aliased-type))) (unused-variables (loop :for tyvar :in defined-variables - :when (not (member (tc:tyvar-id (partial-type-env-lookup-var partial-env tyvar parsed-type)) - used-variables)) + :unless (member (tc:tyvar-id (partial-type-env-lookup-var partial-env tyvar parsed-type)) + used-variables) :collect tyvar)) (number-of-unused-variables (length unused-variables))) (unless (zerop number-of-unused-variables) @@ -333,7 +333,7 @@ (tc-note parsed-type "Type alias ~S defines unused type variable~P ~{:~A~^ ~}" (parser:identifier-src-name (parser:type-definition-name parsed-type)) number-of-unused-variables - (mapcar (lambda (str) (subseq str 0 (- (length str) (1+ (position #\- (reverse str)))))) + (mapcar (lambda (str) (subseq str 0 (position #\- str :from-end t))) (mapcar #'string unused-variables))))))) (defun infer-define-type-scc-kinds (types env) @@ -467,7 +467,7 @@ name)) :aliased-type (let ((parser-aliased-type (parser:type-definition-aliased-type type))) - (when parser-aliased-type + (if parser-aliased-type (let ((aliased-type (parse-type parser-aliased-type env))) (check-for-unused-type-alias-type-variables aliased-type type env) aliased-type))) diff --git a/src/typechecker/types.lisp b/src/typechecker/types.lisp index 64a28557e..a52379ae0 100644 --- a/src/typechecker/types.lisp +++ b/src/typechecker/types.lisp @@ -75,6 +75,18 @@ ;;; (defstruct (ty (:constructor nil)) + ;; When this field is not null, it comprises a head which is the + ;; explicit type-alias used, and a tail which consists of the + ;; type-aliases used to define the explicit alias. + ;; for example: + ;; (define-type-alias T1 T) + ;; (define-type-alias T2 T1) + ;; (declare x T2) + ;; (define x ...) + ;; the type of x will be T, with the alias field + ;; populated with (Cons T2 (Cons T1 Nil)). + ;; + ;; Could be replaced by a weak hash table. (alias nil :type (or null ty-list) :read-only nil)) (defmethod make-load-form ((self ty) &optional env) @@ -233,8 +245,7 @@ (tgen-id type2))) (:method (type1 type2) - (declare (ignore type1) - (ignore type2)) + (declare (ignore type1 type2)) nil)) ;;;