Add define-type-alias

coalton.asd

@@ -256,6 +256,7 @@
                (:file "recursive-let-tests")
                (:file "class-tests")
                (:file "struct-tests")
+               (:file "alias-tests")
                (:file "list-tests")
                (:file "lisparray-tests")
                (:file "red-black-tests")

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.

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
 

src/debug.lisp

@@ -173,9 +173,24 @@
   "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: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))))
+    (tc:with-pprint-variable-context ()
+        (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"

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-aliases program)
                                  env)
 
       (let ((all-instances (append instances (parser:program-instances program))))

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-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.)")
 

src/package.lisp

@@ -23,6 +23,7 @@
    #:declare
    #:define
    #:define-type
+   #:define-alias
    #:define-struct
    #:define-class
    #:define-instance
@@ -108,6 +109,8 @@
    #:lookup-class
    #:lookup-fundeps
    #:type-of
+   #:describe-type-of
+   #:describe-alias
    #:kind-of)
 
   (:intern

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)))
@@ -106,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)))

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,24 @@
        :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))
+
+    (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)
              (values struct-field))

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-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
    #: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-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-alias := "(" "define-alias" identifier ty docstring? ")"
+;;;;                        | "(" "define-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-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-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))
@@ -466,6 +493,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)
@@ -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-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)))
@@ -858,6 +887,27 @@ 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))
+       t))
+
     ((coalton:define-struct)
      (let* ((struct (parse-define-struct form source))
             (repr (consume-repr attributes struct "when parsing define-struct")))
@@ -1107,6 +1157,97 @@ 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
+        name
+        variables)
+
+    ;; (define-alias)
+    (unless (cst:consp (cst:rest form))
+      (parse-error "Malformed alias definition"
+                   (note source form "expected body")))
+
+    (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 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 ...)
+    (when (and docstring
+               (cst:consp (cst:nthrest 4 form)))
+      (parse-error "Malformed alias definition"
+                   (note source (cst:fifth form)
+                         "unexpected trailing form")))
+
+    (make-toplevel-define-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))