diff --git a/coalton.asd b/coalton.asd index 5c398008c..f8a1d84bc 100644 --- a/coalton.asd +++ b/coalton.asd @@ -256,6 +256,7 @@ (:file "recursive-let-tests") (:file "class-tests") (:file "struct-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 2e5584d41..81d8b10c8 100644 --- a/docs/coalton-documentation-guide.md +++ b/docs/coalton-documentation-guide.md @@ -33,6 +33,15 @@ that contains a filling of various sweet or savoury ingredients." (Meat String) "A meat pie with the type of meat.")) ``` +### `define-type-alias` + +`define-type-alias` allows for the same docstring style as `define`. + +```lisp +(coalton-toplevel + (define-type-alias Index Integer + "This is a type alias for a discrete numeric type: INTEGER")) + ### `define-class` `define-class` allows for documentation both on the main form and in each method. diff --git a/docs/intro-to-coalton.md b/docs/intro-to-coalton.md index f822b4579..b39d3d12b 100644 --- a/docs/intro-to-coalton.md +++ b/docs/intro-to-coalton.md @@ -237,7 +237,6 @@ As suggested, one can replace `y` with `_y`, which tells the Coalton compiler th One should treat underscore prefixed variables as ignored whenever possible, and use a name not prefixed with `_` if it may be used. Reading from underscore-prefixed variables is permitted so that generated code (e.g., using macros or read-conditionals) may avoid unused variable warnings for variables which will be used in some compilation contexts but not others. - ## Data Types Coalton allows the definition of parametric algebraic data types. @@ -272,6 +271,85 @@ 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-type-alias`. + +```lisp +(coalton-toplevel + ;; 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)) + (Tuple (1+ x) y)) + + (define shifted-coordinate (shift-right (Tuple 0 0)))) + + ;; Type aliases can have multiple parameters + (define-type-alias (MyTuple3 :a :b :c) (Tuple :a (Tuple :b :c))) + + ;; Type aliases can have parameters that do not have a kind of * + (define-type-alias (IntegerCollection :col) (:col Integer)) + + ;; Type aliases can alias types that do not have a kind of * + (define-type-alias MyCollection List) +``` + +Parametric type aliases must be fully applied. +```lisp +(coalton-toplevel + + (define-type (T :a) (ConstrT (:a Integer))) + + (define-type-alias (MyCollection1 :a) (List :a)) + (define-type-alias MyCollection2 List) + + ;; This line will not compile, because MyCollection1 has a + ;; parameter :A which is not applied + (define-type-alias A (T MyCollection1)) + + ;; However, this line will compile + (define-type-alias A (T MyCollection2))) +``` + +There are several debugging tools which are useful when working with type aliases. Outside of a Coalton expression, `describe-type-of` can be used to display the type of a symbol, including its aliases, and to return the type. `describe-type-alias` displays the alias along with the aliased type and returns the aliased type. Additionally, Coalton can be configured to display only aliases, only types, or both, when displaying the type associated with a symbol. The preference can be set before compiling Coalton using `(setf (get ':coalton-config ':type-printing-mode) mode)` where `mode` is one of `:types`, `:aliases`, and `:types-and-aliases`. Thereafter, the mode can be changed among those three options using the function `set-type-printing-mode`. The default mode is `:types`. + +```lisp +COALTON-USER> (coalton-toplevel + (define-type-alias A Integer) + (define x (the A 5))) +; No value + +COALTON-USER> (set-type-printing-mode :aliases) +:ALIASES + +COALTON-USER> (type-of 'x) +A + +COALTON-USER> (set-type-printing-mode :types-and-aliases) +:TYPES-AND-ALIASES + +COALTON-USER> (type-of 'x) +[A := INTEGER] + +COALTON-USER> (set-type-printing-mode :types) +:TYPES + +COALTON-USER> shifted-coordinate ;; from the example above +#.(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-type-alias 'Pair) +[(PAIR :A) := (TUPLE :A :A)] +``` ### Structs diff --git a/src/debug.lisp b/src/debug.lisp index 379505043..a4b6e1e7a 100644 --- a/src/debug.lisp +++ b/src/debug.lisp @@ -173,9 +173,36 @@ "Lookup the type of value SYMBOL in the global environment" (tc:lookup-value-type entry:*global-environment* symbol)) +(defun coalton:describe-type-of (symbol) + "Lookup the type of value SYMBOL in the global environment. Prints the type and type aliases." + (let ((tc:*coalton-type-printing-mode* :types-and-aliases) + (type (tc:lookup-value-type entry:*global-environment* symbol))) + (format t "~S~%" type) + type)) + +(defun coalton:describe-type-alias (symbol) + "Lookup the type aliased by SYMBOL in the global environment" + (let ((tc::*coalton-type-printing-mode* :types-and-aliases) + (type (tc:type-alias-entry-type (tc:lookup-type-alias entry:*global-environment* symbol)))) + (tc:with-pprint-variable-context () + (format t "~S~%" type)) + type)) + +(defun coalton:set-type-printing-mode (mode) + "Set the type printing mode for the display of types. + +MODE must be one of + +:TYPES only display the types of symbols +:ALIASES only display the aliases of the types of symbols +:TYPES-AND-ALIASES display types and the aliases that refer to them." + (unless (member mode '(:types :aliases :types-and-aliases)) + (error "Invalid type printing mode ~A, must be :TYPES, :ALIASES, or :TYPES-AND-ALIASES." mode)) + (setf tc:*coalton-type-printing-mode* mode)) + (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/entry.lisp b/src/entry.lisp index 919e0cb03..f9268f6f3 100644 --- a/src/entry.lisp +++ b/src/entry.lisp @@ -37,6 +37,7 @@ (multiple-value-bind (type-definitions instances env) (tc:toplevel-define-type (parser:program-types program) (parser:program-structs 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 a2ff9a79d..9a80babbc 100644 --- a/src/faux-macros.lisp +++ b/src/faux-macros.lisp @@ -33,6 +33,9 @@ (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-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 8e88261ed..bf6895d86 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -23,6 +23,7 @@ #:declare #:define #:define-type + #:define-type-alias #:define-struct #:define-class #:define-instance @@ -108,6 +109,9 @@ #:lookup-class #:lookup-fundeps #:type-of + #:describe-type-of + #:describe-type-alias + #:set-type-printing-mode #:kind-of) (:intern diff --git a/src/parser/collect.lisp b/src/parser/collect.lisp index 75a820bb3..7e8fd86ae 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-type-alias)) + (declare (values (tycon-list))) + (collect-referenced-types-generic% (toplevel-define-type-alias-type alias))) + (:method ((field struct-field)) (declare (values tycon-list &optional)) (collect-referenced-types-generic% (struct-field-type field))) @@ -106,6 +110,10 @@ (declare (values tyvar-list)) (mapcan #'collect-type-variables-generic% (toplevel-define-type-ctors type))) + (:method ((alias toplevel-define-type-alias)) + (declare (values tyvar-list)) + (collect-type-variables-generic% (toplevel-define-type-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 5656e8bbb..ba20eba55 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)) + :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) @@ -627,6 +628,24 @@ :repr (toplevel-define-type-repr toplevel) :head-location (toplevel-define-type-head-location toplevel)))) + (:method ((toplevel toplevel-define-type-alias) ctx) + (declare (type algo:immutable-map ctx) + (values toplevel-define-type-alias)) + + (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-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-type-alias-type toplevel) new-ctx) + :location (source:location toplevel) + :head-location (toplevel-define-type-alias-head-location 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 89e215b91..20bea6e38 100644 --- a/src/parser/toplevel.lisp +++ b/src/parser/toplevel.lisp @@ -36,6 +36,13 @@ #:toplevel-define-type-repr ; ACCESSOR #:toplevel-define-type-head-location ; ACCESSOR #:toplevel-define-type-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 @@ -112,6 +119,7 @@ #:program-package ; ACCESSOR #:program-lisp-forms ; ACCESSOR #:program-types ; ACCESSOR + #:program-type-aliases ; ACCESSOR #:program-structs ; ACCESSOR #:program-declares ; ACCESSOR #:program-defines ; ACCESSOR @@ -169,6 +177,9 @@ ;;;; toplevel-define-type := "(" "define-type" identifier docstring? constructor* ")" ;;;; | "(" "define-type" "(" identifier keyword+ ")" docstring? constructor* ")" ;;;; +;;;; toplevel-define-type-alias := "(" "define-type-alias" identifier ty docstring? ")" +;;;; | "(" "define-type-alias" "(" identifier keyword+ ")" ty docstring? ")" +;;;; ;;;; struct-field := "(" identifier docstring? type ")" ;;;; ;;;; toplevel-define-struct := "(" "define-struct" identifier docstring? struct-field* ")" @@ -265,6 +276,22 @@ (deftype toplevel-define-type-list () '(satisfies toplevel-define-type-list-p)) +(defstruct (toplevel-define-type-alias + (: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)) + +(eval-when (:load-toplevel :compile-toplevel :execute) + (defun toplevel-define-type-alias-list-p (x) + (and (alexandria:proper-list-p x) + (every #'toplevel-define-type-alias-p x)))) + +(deftype toplevel-define-type-alias-list () + '(satisfies toplevel-define-type-alias-list-p)) + (defstruct (struct-field (:include toplevel-definition) (:copier nil)) @@ -464,15 +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) - (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). @@ -520,6 +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-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))) @@ -858,6 +887,12 @@ 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-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) (let* ((struct (parse-define-struct form source)) (repr (consume-repr attributes struct "when parsing define-struct"))) @@ -1107,6 +1142,97 @@ consume all attributes"))) :location (form-location source form) :head-location (form-location source (cst:second form))))) +(defun parse-define-type-alias (form source) + (declare (type cst:cst form) + (values toplevel-define-type-alias)) + + (assert (cst:consp form)) + + (let (docstring + name + variables) + + ;; (define-type-alias) + (unless (cst:consp (cst:rest form)) + (parse-error "Malformed type alias definition" + (note source form "expected body"))) + + (cond + ;; (define-type-alias _ ...) + ((cst:atom (cst:second form)) + ;; (define-type-alias 0.5 ...) + (unless (identifierp (cst:raw (cst:second form))) + (parse-error "Malformed type alias definition" + (note source (cst:second form) "expected symbol"))) + + ;; (define-type-alias name ...) + (setf name (make-identifier-src :name (cst:raw (cst:second form)) + :location (form-location source form)))) + + ;; (define-type-alias (_ ...) ...) + (t + ;; (define-type-alias((name) ...) ...) + (unless (cst:atom (cst:first (cst:second form))) + (parse-error "Malformed type 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-type-alias (0.5 ...) ...) + (unless (identifierp (cst:raw (cst:first (cst:second form)))) + (parse-error "Malformed type alias definition" + (note source (cst:first (cst:second form)) + "expected symbol"))) + + ;; (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-type-alias (name) ...) + (when (cst:atom (cst:rest (cst:second form))) + (parse-error "Malformed type alias definition" + (note source (cst:second form) + "nullary type aliases should not have parentheses") + (help source (cst:second form) + (lambda (existing) + (subseq existing 1 (1- (length existing)))) + "remove unnecessary parentheses"))) + + ;; (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-type-alias name) + (unless (cst:consp (cst:rest (cst:rest form))) + (parse-error "Malformed type alias definition" + (note source form "expected type"))) + + ;; (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-type-alias name type docstring ...) + (when (and docstring + (cst:consp (cst:nthrest 4 form))) + (parse-error "Malformed type alias definition" + (note source (cst:fifth form) + "unexpected trailing form"))) + + (make-toplevel-define-type-alias + :name name + :vars (reverse variables) + :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..126764fbb 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 @@ -29,7 +30,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-type-alias)) (defun type-definition-p (x) (typep x 'type-definition)) @@ -48,7 +49,11 @@ (:method ((def toplevel-define-struct)) (declare (values identifier-src)) - (toplevel-define-struct-name def))) + (toplevel-define-struct-name def)) + + (:method ((def toplevel-define-type-alias)) + (declare (values identifier-src)) + (toplevel-define-type-alias-name def))) (defgeneric type-definition-vars (def) (:method ((def toplevel-define-type)) @@ -57,7 +62,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-type-alias)) + (declare (values keyword-src-list)) + (toplevel-define-type-alias-vars def))) (defgeneric type-definition-repr (def) (:method ((def toplevel-define-type)) @@ -66,7 +75,24 @@ (: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-type-alias)) + (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-type-alias)) + (declare (values (or null ty))) + (toplevel-define-type-alias-type def))) (defgeneric type-definition-ctors (def) (:method ((def toplevel-define-type)) @@ -75,7 +101,11 @@ (:method ((def toplevel-define-struct)) (declare (values toplevel-define-struct-list)) - (list def))) + (list def)) + + (:method ((def toplevel-define-type-alias)) + (declare (values null)) + nil)) (defgeneric type-definition-ctor-name (ctor) (:method ((ctor constructor)) diff --git a/src/parser/types.lisp b/src/parser/types.lisp index d5424adc0..2b95df671 100644 --- a/src/parser/types.lisp +++ b/src/parser/types.lisp @@ -37,6 +37,7 @@ #:qualified-ty-predicates ; ACCESSOR #:qualified-ty-type ; ACCESSOR #:qualified-ty-list ; TYPE + #:flatten-type ; FUNCTION #:parse-qualified-type ; FUNCTION #:parse-type ; FUNCTION #:parse-predicate ; FUNCTION @@ -134,6 +135,18 @@ (defmethod source:location ((self qualified-ty)) (qualified-ty-location self)) +(defun flatten-type (type) + "If TYPE is a TAPP of the form ((((T1 T2) T3) T4) ...), then return +the list (T1 T2 T3 T4 ...). Otherwise, return (LIST TYPE)." + (declare (type ty type) + (values ty-list &optional)) + (let ((flattened-type nil)) + (loop :for from := type :then (tapp-from from) + :while (typep from 'tapp) + :do (push (tapp-to from) flattened-type) + :finally (push from flattened-type)) + flattened-type)) + (defun parse-qualified-type (form source) (declare (type cst:cst form)) diff --git a/src/settings.lisp b/src/settings.lisp index ae32a195b..bfcdccede 100644 --- a/src/settings.lisp +++ b/src/settings.lisp @@ -10,6 +10,7 @@ #:*coalton-disable-specialization* ; VARIABLE #:*coalton-heuristic-inlining* ; VARIABLE #:*coalton-print-unicode* ; VARIABLE + #:*coalton-type-printing-mode* ; VARIABLE #:*emit-type-annotations* ; VARIABLE #:*coalton-optimize* ; VARIABLE #:*coalton-optimize-library* ; VARIABLE @@ -43,6 +44,7 @@ (defvar *config-keys* '(:compiler-mode ; [string] compiler mode :print-unicode ; [boolean] print unicode? + :type-printing-mode ; [member :types :aliases :types-and-aliases] type printing mode :perform-specialization ; [boolean] use specializations? :perform-inlining ; [boolean] automatic inlining? :emit-type-annotations ; [boolean] emit type annotations? @@ -68,6 +70,11 @@ found, return DEFAULT instead." (defvar *coalton-print-unicode* (config ':print-unicode :default t) "Whether to print coalton info using unicode symbols") +(declaim (type (member :types :aliases :types-and-aliases) *coalton-type-printing-mode*)) +(defvar *coalton-type-printing-mode* (config ':type-printing-mode :default :types) + "Whether to display types, aliases, or both, when displaying the type associated with a symbol. +Must be one of (:TYPES :ALIASES :TYPES-AND-ALIASES).") + (defun coalton-release-p () "Determines how redefinable code generated by Coalton is. diff --git a/src/typechecker/base.lisp b/src/typechecker/base.lisp index 2234b5322..210641980 100644 --- a/src/typechecker/base.lisp +++ b/src/typechecker/base.lisp @@ -4,7 +4,11 @@ (:local-nicknames (#:source #:coalton-impl/source) (#:util #:coalton-impl/util)) + (:import-from + #:coalton-impl/settings + #:*coalton-type-printing-mode*) (:export + #:*coalton-type-printing-mode* #:*coalton-pretty-print-tyvars* #:*pprint-tyvar-dict* #:*pprint-variable-symbol-code* @@ -74,7 +78,7 @@ This requires a valid PPRINT-VARIABLE-CONTEXT") (with-pprint-variable-context () (apply #'format nil format-string format-args)))) -(defun tc-note (located format-string &rest format-args) +(defun tc-note (located format-string &rest format-args) (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 e2ef7b2c8..8ec2a65f4 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 'aliased-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) @@ -76,14 +78,15 @@ (deftype type-definition-list () '(satisfies type-definition-list-p)) -(defun toplevel-define-type (types structs 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-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) + (check-package (append types structs type-aliases) (alexandria:compose #'parser:identifier-src-name #'parser:type-definition-name) (alexandria:compose #'source:location @@ -99,7 +102,7 @@ ;; Ensure that there are no duplicate type definitions (check-duplicates - (append types structs) + (append types structs type-aliases) (alexandria:compose #'parser:identifier-src-name #'parser:type-definition-name) (lambda (first second) (tc:tc-error "Duplicate type definitions" @@ -118,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) + (loop :for type :in (append types structs type-aliases) :do (check-duplicates (parser:type-definition-vars type) #'parser:keyword-src-name @@ -127,12 +130,22 @@ (tc:tc-note first "first definition here") (tc:tc-note second "second definition here"))))) + ;; Ensure that no parametric type alias has unused type variables. + (loop :for type :in type-aliases + :for used-vars := (mapcar #'parser:tyvar-name + (parser:collect-type-variables + (parser:type-definition-aliased-type type))) + :do (loop :for defined-var :in (parser:type-definition-vars type) + :unless (member (parser:keyword-src-name defined-var) used-vars) + :do (tc:tc-error "Unused type variable in define-type-alias" + (tc:tc-note defined-var "unused variable defined here")))) + (let* ((type-names (mapcar (alexandria:compose #'parser:identifier-src-name #'parser:type-definition-name) - (append types structs))) + (append types structs type-aliases))) (type-dependencies - (loop :for type :in (append types structs) + (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)) @@ -142,7 +155,7 @@ (type-table (loop :with table := (make-hash-table :test #'eq) - :for type :in (append types structs) + :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))) @@ -170,7 +183,12 @@ := (loop :for var :in vars :collect (tc:kind-of (partial-type-env-add-var partial-env var))) - :for kind := (tc:make-kind-function* kvars tc:+kstar+) + :for kind := (if (typep type 'parser:toplevel-define-type-alias) + ;; Type aliases may not alias a type of kind *. + (tc:make-kind-function* kvars (tc:make-kvariable)) + ;; However, type and struct definitions always + ;; yield types of kind *. + (tc:make-kind-function* kvars tc:+kstar+)) :for ty := (tc:make-tycon :name name :kind kind) :do (partial-type-env-add-type partial-env name ty)) @@ -213,6 +231,21 @@ (when (plusp (tc:constructor-entry-arity ctor-entry)) (setf env (tc:unset-function env constructor)))))) + (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-type-alias aliased-type alias)) + (setf env (tc:set-type-alias + env + (type-definition-name type) + (tc:make-type-alias-entry + :name (type-definition-name type) + :tyvars tyvars + :type aliased-type + :docstring nil))))) + ((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 :in (parser:toplevel-define-struct-fields parsed-type) @@ -290,7 +323,6 @@ env) - (defun infer-define-type-scc-kinds (types env) (declare (type parser:type-definition-list types) (type partial-type-env env) @@ -298,7 +330,9 @@ (let ((ksubs nil) - (ctor-table (make-hash-table :test #'eq))) + (ctor-table (make-hash-table :test #'eq)) + + (alias-table (make-hash-table :test #'eq))) ;; Infer the kinds of each type (loop :for type :in types @@ -307,16 +341,32 @@ :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_) type)) :do (setf (gethash ctor-name ctor-table) fields))) + ;; Infer the kinds of each type alias. + (loop :for type :in types + :for name := (parser:identifier-src-name (parser:type-definition-name type)) + :for parser-aliased-type := (parser:type-definition-aliased-type type) + :when parser-aliased-type + :do (multiple-value-bind (aliased-type ksubs_) + (parse-type parser-aliased-type + env + ksubs + (let ((kind (tc:kind-of (gethash name (partial-type-env-ty-table env))))) + (loop :while (typep kind 'tc:kfun) + :do (setf kind (tc:kfun-to kind))) + kind)) + (setf ksubs ksubs_) + (setf (gethash name alias-table) aliased-type))) + ;; Redefine types with final inferred kinds in the environment (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 @@ -338,7 +388,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 @@ -353,9 +403,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) @@ -420,6 +470,7 @@ `(member ,@(mapcar #'tc:constructor-entry-compressed-repr ctors))) (t name)) + :aliased-type (gethash name alias-table) :explicit-repr (if (eq repr-type :native) (list repr-type repr-arg) repr-type) @@ -444,7 +495,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 30df42067..f8697a94e 100644 --- a/src/typechecker/environment.lisp +++ b/src/typechecker/environment.lisp @@ -49,6 +49,13 @@ #:constructor-entry-compressed-repr ; ACCESSOR #:constructor-entry-list ; TYPE #:constructor-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 @@ -112,6 +119,7 @@ #:make-default-environment ; FUNCTION #:environment-value-environment ; ACCESSOR #:environment-type-environment ; ACCESSOR + #:environment-type-alias-environment ; ACCESSOR #:environment-constructor-environment ; ACCESSOR #:environment-class-environment ; ACCESSOR #:environment-fundep-environment ; ACCESSOR @@ -129,6 +137,9 @@ #:lookup-constructor ; FUNCTION #:set-constructor ; FUNCTION #:unset-constructor ; FUNCTION + #:lookup-type-alias ; FUNCTION + #:set-type-alias ; FUNCTION + #:unset-type-alias ; FUNCTION #:lookup-struct ; FUNCTION #:set-struct ; FUNCTION #:unset-struct ; FUNCTION @@ -498,6 +509,37 @@ #+(and sbcl coalton-release) (declaim (sb-ext:freeze-type constructor-environment)) +;;; +;;; Type alias environment +;;; + +(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 type-alias-entry)) + (type-alias-entry-docstring self)) + +(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 type-alias-entry)) + +(defun type-alias-entry-list-p (x) + (and (alexandria:proper-list-p x) + (every #'type-alias-entry-p x))) + +(deftype type-alias-entry-list () + '(satisfies type-alias-entry-list-p)) + +(defstruct (type-alias-environment (:include immutable-map))) + +#+(and sbcl coalton-release) +(declaim (sb-ext:freeze-type type-alias-environment)) + ;;; ;;; Struct environment ;;; @@ -802,6 +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) + (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) @@ -830,6 +873,7 @@ (make-environment :value-environment (make-value-environment) :type-environment (make-default-type-environment) + :type-alias-environment (make-type-alias-environment) :struct-environment (make-struct-environment) :constructor-environment (make-default-constructor-environment) :class-environment (make-class-environment) @@ -846,6 +890,7 @@ &key (value-environment (environment-value-environment env)) (type-environment (environment-type-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)) @@ -860,6 +905,7 @@ (declare (type environment env) (type value-environment value-environment) (type constructor-environment constructor-environment) + (type type-alias-environment type-alias-environment) (type struct-environment struct-environment) (type class-environment class-environment) (type fundep-environment fundep-environment) @@ -875,6 +921,7 @@ :value-environment value-environment :type-environment type-environment :constructor-environment constructor-environment + :type-alias-environment type-alias-environment :struct-environment struct-environment :class-environment class-environment :fundep-environment fundep-environment @@ -990,6 +1037,35 @@ symbol #'make-constructor-environment))) +(defun lookup-type-alias (env symbol &key no-error) + (declare (type environment env) + (type symbol symbol)) + (or (immutable-map-lookup (environment-type-alias-environment env) symbol) + (unless no-error + (util:coalton-bug "Unknown type-alias ~S" symbol)))) + +(define-env-updater set-type-alias (env symbol value) + (declare (type environment env) + (type symbol symbol) + (type type-alias-entry value)) + (update-environment + env + :type-alias-environment (immutable-map-set + (environment-type-alias-environment env) + symbol + value + #'make-type-alias-environment))) + +(define-env-updater unset-type-alias (env symbol) + (declare (type environment env) + (type symbol symbol)) + (update-environment + env + :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) (type symbol symbol)) diff --git a/src/typechecker/parse-type.lisp b/src/typechecker/parse-type.lisp index 270fcde43..7c5d3ccd1 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-type-alias-substitutions ; FUNCTION #:parse-type ; FUNCTION #:parse-qualified-type ; FUNCTION #:parse-ty-scheme ; FUNCTION @@ -30,28 +31,116 @@ ;;; Entrypoints ;;; -(defun parse-type (ty env) - (declare (type parser:ty ty) - (type tc:environment env) - (values tc:ty &optional)) +(defgeneric apply-type-alias-substitutions (type parser-type env) + (:documentation "Replace all type aliases in TYPE with the true types represented by them.") + (: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-type-alias (partial-type-env-env env) (tc:tycon-name type) :no-error t))) + (if alias + ;; Kind information is tracked with type aliases. + ;; So, kind mismatch is caught earlier and we do not check for it here. + (if (zerop (length (tc:type-alias-entry-tyvars alias))) + (setf type (tc:type-alias-entry-type alias)) + (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:type-alias-entry-name alias) + (length (tc:type-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)) + ;; Flatten the type-checker and parser types. + (let ((flattened-tapp (tc:flatten-type type)) + (flattened-parser-tapp (parser:flatten-type parser-type))) + ;; Apply substitutions to the type arguments. + (setf flattened-tapp (cons (first flattened-tapp) + (mapcar (lambda (tc-ty parser-ty) + (apply-type-alias-substitutions tc-ty parser-ty env)) + (rest flattened-tapp) + (rest flattened-parser-tapp)))) + ;; Check if the foremost tapp-from is an alias. + (if (typep (first flattened-tapp) 'tc:tycon) + (let ((alias (tc:lookup-type-alias (partial-type-env-env env) (tc:tycon-name (first flattened-tapp)) :no-error t))) + (if alias + (let ((var-count (length (tc:type-alias-entry-tyvars alias))) + (arg-count (length (rest flattened-tapp)))) + ;; Kind mismatches are caught earlier. + ;; Ensure sufficient parameters are supplied. + (if (> var-count arg-count) + (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:type-alias-entry-name alias) + arg-count + var-count)) + ;; Apply the type parameters to the parametric type alias. + (let ((substs nil)) + (loop :for var :in (tc:type-alias-entry-tyvars alias) + :for arg :in (subseq flattened-tapp 1 (1+ var-count)) + :do (setf substs (tc:merge-substitution-lists substs (tc:match var arg)))) + ;; Replace the alias and its parameters with the corresponding type + ;; in the flattened type. + (setf flattened-tapp (cons (tc:apply-substitution substs (tc:type-alias-entry-type alias)) + (nthcdr var-count (rest flattened-tapp))))))))) + ;; If the first type in the flattened type is not a tycon, + ;; then apply alias substitutions directly to it. + (setf flattened-tapp (cons (apply-type-alias-substitutions (first flattened-tapp) (first flattened-parser-tapp) env) + (rest flattened-tapp)))) + (setf type (first flattened-tapp)) + ;; Reconstruct the flattened type with any remaining types to be applied. + (loop :for arg :in (rest flattened-tapp) + :do (setf type (tc:apply-type-argument type arg))) + type)) + + (: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-type-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)) + (if (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 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-type-alias-substitutions ty parser-ty partial-env)) + (values ty ksubs)))) (defun parse-qualified-type (unparsed-ty env) (declare (type parser:qualified-ty unparsed-ty) @@ -59,7 +148,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 @@ -70,6 +158,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 (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)) @@ -81,7 +172,7 @@ (check-for-ambiguous-variables preds ty unparsed-ty env) (check-for-reducible-context preds unparsed-ty env) - qual-ty)))) + (apply-type-alias-substitutions qual-ty unparsed-ty partial-env))))) (defun parse-ty-scheme (ty env) (declare (type parser:qualified-ty ty) @@ -154,7 +245,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) @@ -177,7 +270,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 @@ -232,7 +325,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+)) @@ -273,9 +366,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/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..8454e2781 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 (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..c3a5d6051 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) + (*coalton-type-printing-mode* :types)) (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) + (*coalton-type-printing-mode* :types)) (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) + (*coalton-type-printing-mode* :types)) (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) + (*coalton-type-printing-mode* :types)) (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) + (*coalton-type-printing-mode* :types)) (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) + (*coalton-type-printing-mode* :types)) (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) + (*coalton-type-printing-mode* :types)) (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) + (*coalton-type-printing-mode* :types)) (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 fff5a4797..cc3414c15 100644 --- a/src/typechecker/types.lisp +++ b/src/typechecker/types.lisp @@ -8,6 +8,7 @@ (#:settings #:coalton-impl/settings)) (:export #:ty ; STRUCT + #:ty-alias ; ACCESSOR #:ty-list ; TYPE #:tyvar ; STRUCT #:make-tyvar ; CONSTRUCTOR @@ -34,6 +35,7 @@ #:instantiate ; FUNCTION #:kind-of ; FUNCTION #:type-constructors ; FUNCTION + #:ty= ; FUNCTION #:*boolean-type* ; VARIABLE #:*unit-type* ; VARIABLE #:*char-type* ; VARIABLE @@ -46,6 +48,8 @@ #:*fraction-type* ; VARIABLE #:*arrow-type* ; VARIABLE #:*list-type* ; VARIABLE + #:push-type-alias ; FUNCTION + #:flatten-type ; FUNCTION #:apply-type-argument ; FUNCTION #:apply-type-argument-list ; FUNCTION #:make-function-type ; FUNCTION @@ -71,7 +75,20 @@ ;;; Types ;;; -(defstruct (ty (:constructor nil))) +(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) (make-load-form-saving-slots self :environment env)) @@ -133,6 +150,7 @@ (defgeneric instantiate (types type) (:method (types (type tapp)) (make-tapp + :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)) @@ -156,16 +174,19 @@ (defmethod apply-ksubstitution (subs (type tyvar)) (make-tyvar + :alias (mapcar (lambda (alias) (apply-ksubstitution subs alias)) (ty-alias type)) :id (tyvar-id type) :kind (apply-ksubstitution subs (tyvar-kind type)))) (defmethod apply-ksubstitution (subs (type tycon)) (make-tycon + :alias (mapcar (lambda (alias) (apply-ksubstitution subs alias)) (ty-alias type)) :name (tycon-name type) :kind (apply-ksubstitution subs (tycon-kind type)))) (defmethod apply-ksubstitution (subs (type tapp)) (make-tapp + :alias (mapcar (lambda (alias) (apply-ksubstitution subs alias)) (ty-alias type)) :from (apply-ksubstitution subs (tapp-from type)) :to (apply-ksubstitution subs (tapp-to type)))) @@ -199,6 +220,35 @@ (:method ((lst list)) (mapcan #'type-constructors-generic% lst))) +(defgeneric ty= (type1 type2) + (:documentation "Are TYPE1 to TYPE2 EQUALP, ignoring their aliases.") + + (: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 type2)) + nil)) + ;;; ;;; Early types ;;; @@ -220,6 +270,27 @@ ;;; Operations on Types ;;; +(defun push-type-alias (type alias) + "Update the alias field of TYPE with ALIAS as the most high-level alias." + (declare (type ty type) + (type ty alias) + (values ty &optional)) + (let ((new-type (copy-structure type))) + (push alias (ty-alias new-type)) + new-type)) + +(defun flatten-type (type) + "If TYPE is a TAPP of the form ((((T1 T2) T3) T4) ...), then return +the list (T1 T2 T3 T4 ...). Otherwise, return (LIST TYPE)." + (declare (type ty type) + (values ty-list &optional)) + (let ((flattened-type nil)) + (loop :for from := type :then (tapp-from from) + :while (typep from 'tapp) + :do (push (tapp-to from) flattened-type) + :finally (push from flattened-type)) + flattened-type)) + (defun apply-type-argument (tcon arg &key ksubs) (declare (type (or tycon tapp tyvar) tcon) (type ty arg) @@ -367,6 +438,18 @@ (declare (type stream stream) (type ty ty) (values ty)) + + ;; If the type printing mode is :ALIASES and TY is aliased, print the + ;; most high-level alias that represents TY and return from PPRINT-TY. + (when (and (eq *coalton-type-printing-mode* :aliases) (ty-alias ty)) + (format stream "~S" (first (ty-alias ty))) + (return-from pprint-ty ty)) + + ;; If the type printing mode is :TYPES-AND-ALIASES and TY is aliased, + ;; print the stack of aliases that represent TY before printing TY. + (when (and (eq *coalton-type-printing-mode* :types-and-aliases) (ty-alias ty)) + (format stream "[~{~S := ~}" (ty-alias ty))) + (etypecase ty (tyvar (if *coalton-pretty-print-tyvars* @@ -424,6 +507,12 @@ (tgen (write-string "#GEN" stream) (write (tgen-id ty) :stream stream))) + + ;; Close the braces in the case that the type printing mode is + ;; :TYPES-AND-ALIASES and TY is aliased. + (when (and (eq *coalton-type-printing-mode* :types-and-aliases) (ty-alias ty)) + (format stream "]")) + ty) (defmethod print-object ((ty ty) stream) @@ -443,7 +532,8 @@ (:report (lambda (c s) (let ((*print-circle* nil) ; Prevent printing using reader macros - ) + (*print-readably* nil) + (*coalton-type-printing-mode* :types)) (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/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/coalton-tests.lisp b/tests/coalton-tests.lisp index eb6bb3f8a..c48412f7c 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-type-alias.txt") (%run-tests "define.txt") (%run-tests "fundeps.txt") (%run-tests "hashtable.txt") diff --git a/tests/test-files/define-type-alias.txt b/tests/test-files/define-type-alias.txt new file mode 100644 index 000000000..b4ad0954b --- /dev/null +++ b/tests/test-files/define-type-alias.txt @@ -0,0 +1,188 @@ +================================================================================ +1 Define type alias +================================================================================ + +(package coalton-unit-tests) + +(define-type-alias Index Integer) + +================================================================================ +2 Define type alias +================================================================================ + +(package coalton-unit-tests) + +(define-type-alias UnaryIntegerOperator (Integer -> Integer)) + +================================================================================ +3 Define type alias +================================================================================ + +(package coalton-unit-tests) + +(define-type-alias (UnaryOperator :a) (:a -> :a)) + +================================================================================ +4 Define type alias +================================================================================ + +(package coalton-unit-tests) + +(define-type-alias (ReverseTranslationRules :a :b) (:b -> :a)) + +================================================================================ +5 Define type alias +================================================================================ + +(package coalton-unit-tests) + +(define-type-alias Index Integer) + +(define-type-alias MyIndex Index) + +(define-type-alias (Collection :a) (List :a)) + +(define-type-alias MyIndices (Collection MyIndex)) + +================================================================================ +6 Define type alias +================================================================================ + +(package coalton-unit-tests) + +(define-type-alias (U :a :b) (:b (:b :a))) + +================================================================================ +7 Define type alias +================================================================================ + +(package coalton-unit-tests) + +(define-type-alias T Arrow) + +================================================================================ +100 define-type-alias, parse-error +================================================================================ + +(package test-package) + +(define-type-alias "Index" UFix) + +-------------------------------------------------------------------------------- + +error: Malformed type alias definition + --> test:3:19 + | + 3 | (define-type-alias "Index" UFix) + | ^^^^^^^ expected symbol + +================================================================================ +101 define-type-alias, parse-error +================================================================================ + +(package test-package) + +(define-type-alias Index UFix + "An index" + "A really good index") + +-------------------------------------------------------------------------------- + +error: Malformed type alias definition + --> test:5:2 + | + 5 | "A really good index") + | ^^^^^^^^^^^^^^^^^^^^^ unexpected trailing form + +================================================================================ +102 define-type-alias, type variables +================================================================================ + +(package test-package) + +(define-type-alias (Collection :a) (List :b)) + +-------------------------------------------------------------------------------- + +error: Unused type variable in define-type-alias + --> test:3:31 + | + 3 | (define-type-alias (Collection :a) (List :b)) + | ^^ unused variable defined here + +================================================================================ +103 define-type-alias, type variables +================================================================================ + +(package test-package) + +(define-type-alias Collection (List :b)) + +-------------------------------------------------------------------------------- + +error: Unknown type variable + --> test:3:36 + | + 3 | (define-type-alias Collection (List :b)) + | ^^ Unknown type variable :B + +================================================================================ +104 define-type-alias, type variables +================================================================================ + +(package test-package) + +(define-type-alias (Collection :a) (List Integer)) + +-------------------------------------------------------------------------------- + +error: Unused type variable in define-type-alias + --> test:3:31 + | + 3 | (define-type-alias (Collection :a) (List Integer)) + | ^^ unused variable defined here + +================================================================================ +105 define-type-alias, type variables +================================================================================ + +(package test-package) + +(define-type-alias (T :a) (List :a)) +(define-type-alias U T) + +-------------------------------------------------------------------------------- + + error: Incomplete type alias application + --> test:4:21 + | + 4 | (define-type-alias U T) + | ^ Type alias T is applied to 0 arguments, but 1 argument is required. + +================================================================================ +106 define-type-alias, type errors +================================================================================ + +(package test-package) + +(define-type-alias Index UFix) + +(define-type-alias MyIndex Index) + +(define-type-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 'UFIX' but got 'INTEGER' diff --git a/tests/type-alias-tests.lisp b/tests/type-alias-tests.lisp new file mode 100644 index 000000000..4e496ff5c --- /dev/null +++ b/tests/type-alias-tests.lisp @@ -0,0 +1,174 @@ +;;;; type-alias-tests.lisp + +(in-package #:coalton-tests) + +(deftest test-type-alias-definition () + + (check-coalton-types + "(define-type-alias UnaryIntegerOperator (Integer -> Integer))") + + (check-coalton-types + "(define-type-alias UnaryIntegerOperator (Integer -> Integer) + \"An alias for functions mapping integers to integers.\")")) + +(deftest test-type-alias-the () + + (check-coalton-types + "(define-type-alias Index UFix) + + (define i (the Index 5))" + + '("i" . "UFix")) + + (check-coalton-types + "(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-type-alias-declare () + + (check-coalton-types + "(define-type-alias Index UFix) + + (declare i Index) + (define i 5)" + + '("i" . "UFix")) + + (check-coalton-types + "(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-type-alias-constructors () + + (check-coalton-types + "(define-type-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-type-alias Coordinate IFix) + + (define-struct Point + (x Coordinate) + (y Coordinate)) + + (define p (Point 2 5)) + (define x (.x p))" + + '("p" . "Point") + '("x" . "IFix"))) + +(deftest test-parametric-type-alias-definition () + + (check-coalton-types + "(define-type-alias (UnaryOperator :a) (:a -> :a))") + + (check-coalton-types + "(define-type-alias (Collapse :a :b :c :d) (:d -> :c -> :b -> :a))")) + +(deftest test-complex-type-alias-definition () + + (check-coalton-types + "(define-type (T :a :b :c) (T (:a -> :b :c))) + (define-struct S (x Integer)) + (define-type-alias A1 (Tuple Integer)) + (define-type-alias A2 (T S A1 Integer))") + + (check-coalton-types + "(define-type-alias (A :a :b) (Tuple :a (Tuple :b :b))) + (declare f ((A Integer Integer) -> Integer)) + (define (f (Tuple a (Tuple b c))) (+ a (+ b c)))")) + +(deftest test-parametric-type-alias-the () + + (check-coalton-types + "(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)")) + + (check-coalton-types + "(define-type-alias Index UFix) + (define-type-alias Collection List) + + (define l (the (Collection Index) (make-list 1 2 3 4)))" + + '("l" . "(List UFix)"))) + +(deftest test-parametric-type-alias-declare () + + (check-coalton-types + "(define-type-alias (UnaryOperator :a) (:a -> :a)) + + (declare f (UnaryOperator Integer)) + (define f 1+)" + + '("f" . "(Integer -> Integer)")) + + + (check-coalton-types + "(define-type-alias (FoldFunc :a :b) (:a -> :b -> :a)) + + (declare f (FoldFunc (List Integer) Integer)) + (define (f xs x) (Cons x xs))" + + '("f" . "((List Integer) -> Integer -> (List Integer))")) + + (check-coalton-types + "(define-type-alias (UnaryOperator :a) (:a -> :a)) + + (declare f ((Num :a) => (UnaryOperator :a))) + (define f 1+)")) + +(deftest test-parametric-type-alias-constructors () + + (check-coalton-types + "(define-type-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-type-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)"))) diff --git a/tests/utilities.lisp b/tests/utilities.lisp index 6e0682485..477fc904a 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))