Add define-type-alias

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

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.

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-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))))
+```
+
+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
+#.(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
 

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-type-aliases* t)
+        (type (tc:lookup-value-type entry:*global-environment* symbol)))
+    (format t "~S~%" type)
+    type))
+
+(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))
+
 (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-type-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-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.)")
 

src/package.lisp

@@ -23,6 +23,7 @@
    #:declare
    #:define
    #:define-type
+   #:define-type-alias
    #:define-struct
    #:define-class
    #:define-instance
@@ -108,6 +109,8 @@
    #:lookup-class
    #:lookup-fundeps
    #:type-of
+   #:describe-type-of
+   #:describe-type-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-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)))

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

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