wip typeclasses

Author: stylewarning

coalton.asd

@@ -29,6 +29,8 @@
                (:file "toplevel-declare")
                (:file "toplevel-define-type")
                (:file "toplevel-define")
+               (:file "toplevel-define-class")
+               (:file "toplevel-define-instance")
                (:file "coalton")
                (:file "faux-macros")
                (:file "impl-debug-routines")

src/faux-macros.lisp

@@ -30,6 +30,12 @@
 (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-class (name &body definition)
+  "TODO (Coalton top-level operator.)")
+
+(define-coalton-editor-macro coalton:define-instance (name &body definition)
+  "TODO (Coalton top-level operator.)")
+
 (define-coalton-editor-macro coalton:declare (var type)
   "Declare the type of a variable. (Coalton top-level operator.)")
 

src/hindley-milner.lisp

@@ -198,5 +198,3 @@
                     ;; Return the type of the entire expression.
                     result-ty))))))
     (analyze value nil nil)))
-
-

src/library.lisp

@@ -124,6 +124,30 @@
   (define-comparators = /= > < >= <=)
   (define-predicates evenp oddp plusp minusp zerop))
 
+
+#+igno
+(coalton-toplevel
+  (define-class (Eq a)
+    (== (fn a a -> Boolean)))
+
+  ;; (fn (Eq a) => a a -> Boolean)
+  (define (/= a b) (not (== a b)))
+
+  (define-instance (Eq Boolean)
+    (define (== a b)
+      (or (and a       b)
+          (and (not a) (not b)))))
+
+  (define-instance ((Eq a) => (Eq (Maybe a)))
+    (define (== a b)
+      (match a
+        ((Just x) (match b
+                    ((Just y) (== x y))
+                    (Nothing  coalton:False)))
+        (Nothing  (match b
+                    ((Just _) coalton:False)
+                    (Nothing  coalton:True)))))))
+
 ;;; Arithmetic
 (coalton-toplevel
   (declare + (fn Integer Integer -> Integer))

src/package.lisp

@@ -10,8 +10,12 @@
    #:coalton
    #:define
    #:define-type-alias
-   #:define-type)
+   #:define-type
+   #:define-class
+   #:define-instance)
   (:export
+   #:for
+   #:=>
    #:->
    #:void
    #:integer

src/parse-type.lisp

@@ -4,12 +4,25 @@
 
 ;;; Grammar:
 ;;;
+;;;    <type> := <type alias>                            ; TODO!
+;;;            | <type expr>
+;;;            | (for <constraint>* => <type expr>)
+;;;
+;;;    <constraint> := (<class name> <type variable>)
+;;;
 ;;;    <type expr> := <type alias>                       ; TODO!
 ;;;                 | <type variable>
 ;;;                 | <nullary type constructor>
 ;;;                 | (fn <type expr>* -> <type-expr>)
 ;;;                 | (<type constructor> <type expr>*)
 
+(defun parse-arrow (arrow list &key error)
+  (let ((arrow-position (position arrow list)))
+    (when (null arrow-position)
+      (funcall error))
+    (values (subseq list 0 arrow-position)
+            (subseq list (1+ arrow-position)))))
+
 (defun parse-type-expression (whole-expr &key variable-assignments
                                               extra-tycons)
   "Parse the type expression WHOLE-EXPR. Return two values:
@@ -42,19 +55,20 @@ EXTRA-TYCONS is a list of tycons that are perhaps not globally defined yet. Thes
                (tyapp (find-it expr)))
 
              (parse-function (expr)
-               (let ((arrow (position 'coalton:-> expr)))
-                 (when (null arrow)
-                   (error-parsing whole-expr "Invalid function type because it lacks an arrow: ~S" expr))
-                 (let ((from (subseq expr 1 arrow)) ; exclude FN symbol
-                       (to   (subseq expr (1+ arrow))))
-                   (cond
-                     ((null to) (error-parsing whole-expr "Can't have an empty return type in function type: ~S" expr))
-                     ((not (null (rest to))) (error-parsing whole-expr "Can't have more than one return type in function type: ~S" expr)))
-                   ;; parse out the input and output types
-                   (setf from (mapcar #'parse from))
-                   (setf to   (parse (first to)))
-                   ;; return the parsed type
-                   (tyfun from to))))
+               (multiple-value-bind (from to)
+                   (parse-arrow 'coalton:-> (rest expr) ; exclude FN symbol
+                                :error (lambda ()
+                                         (error-parsing whole-expr "Invalid function type ~
+                                                                    because it lacks an ~
+                                                                    arrow: ~S" expr)))
+                 (cond
+                   ((null to) (error-parsing whole-expr "Can't have an empty return type in function type: ~S" expr))
+                   ((not (null (rest to))) (error-parsing whole-expr "Can't have more than one return type in function type: ~S" expr)))
+                 ;; parse out the input and output types
+                 (setf from (mapcar #'parse from))
+                 (setf to   (parse (first to)))
+                 ;; return the parsed type
+                 (tyfun from to)))
 
              (parse-application (expr)
                (cond
@@ -65,6 +79,10 @@ EXTRA-TYCONS is a list of tycons that are perhaps not globally defined yet. Thes
                  ;; New syntax for doing function types.
                  ((eq 'coalton:fn (first expr)) (parse-function expr))
 
+                 ;; Constrained types aren't valid here.
+                 ((eq 'coalton:for (first expr))
+                  (error-parsing whole-expr "Constrained types can't be embedded in a larger type."))
+
                  ;; Other applications.
                  (t
                   (destructuring-bind (tycon &rest args) expr
@@ -77,6 +95,35 @@ EXTRA-TYCONS is a list of tycons that are perhaps not globally defined yet. Thes
                            (find-it tycon)
                            (mapcar #'parse args))))))
 
+             (parse-constrained-type (expr)
+               (multiple-value-bind (from to)
+                   (parse-arrow 'coalton:=> (rest expr) ; exclude FOR symbol
+                                :error (lambda ()
+                                         (error-parsing whole-expr "Invalid constrained type ~
+                                                                    because it lacks an ~
+                                                                    arrow '=>': ~S" expr)))
+                 (cond
+                   ((null to) (error-parsing whole-expr "Constrained type requires a type to constrain: ~S" expr))
+                   ((not (null (rest to))) (error-parsing whole-expr "Only one type can be constrained: ~S" expr)))
+
+                 (if (endp from)
+                     (parse (first to))
+                     (make-cty (parse (first to)) :constraints (mapcar #'parse-constraint from)))))
+
+             (parse-constraint (constraint)
+               (unless (and (alexandria:proper-list-p constraint)
+                            (= 2 (length constraint)))
+                 (error-parsing whole-expr "Invalid constraint: ~S" constraint))
+               (destructuring-bind (class-name-expr variable-expr) constraint
+                 ;; Check that the class name is a symbol
+                 (unless (symbolp class-name-expr)
+                   (error-parsing whole-expr "Invalud constraint: ~S" constraint))
+                 (let ((class-name class-name-expr)
+                       (var        (parse variable-expr)))
+                   (unless (typep var 'tyvar)
+                     (error-parsing whole-expr "Invalid constraint: ~S" constraint))
+                   (cx class-name var))))
+
              (parse (expr)
                (typecase expr
                  ;; TODO: Allow () for something useful?
@@ -93,5 +140,10 @@ EXTRA-TYCONS is a list of tycons that are perhaps not globally defined yet. Thes
 
                  (t
                   (error-parsing whole-expr "Invalid type expression: ~S" expr)))))
-      (values (parse whole-expr)
+      ;; A constrained type can only be at the "top level".
+      (values (if (and (alexandria:proper-list-p whole-expr)
+                       (not (endp whole-expr))
+                       (eq 'coalton:for (first whole-expr)))
+                  (parse-constrained-type whole-expr)
+                  (parse whole-expr))
               (alexandria:hash-table-alist table)))))

src/toplevel-define-class.lisp

@@ -0,0 +1,8 @@
+;;;; toplevel-define-class.lisp
+
+(in-package #:coalton-impl)
+
+;;; Handling of COALTON:TOPLEVEL-DEFINE-CLASS
+
+(defun process-toplevel-class-definitions (defclass-forms)
+  nil)

src/toplevel-define-instance.lisp

@@ -0,0 +1,7 @@
+;;;; toplevel-define-instance.lisp
+
+(in-package #:coalton-impl)
+
+;;; Handling of COALTON:TOPLEVEL-DEFINE-INSTANCE
+
+

src/types.lisp

@@ -2,6 +2,11 @@
 
 (in-package #:coalton-impl)
 
+(defstruct (cx (:constructor cx (class variable)))
+  "A constraint (abbreviated CX), also known as a \"predicate\"."
+  (class    nil :type symbol :read-only t)
+  (variable nil :type tyvar  :read-only t))
+
 ;;; A type constructor is not a constructor for a value, but a
 ;;; constructor for a *type*! Get with the program!
 (defstruct tycon
@@ -79,6 +84,11 @@ If NAME is not known, it will be made known to the global type database."
           :do (return tycon)
         :finally (return nil)))
 
+(defstruct (cty (:constructor make-cty (expr &key constraints)))
+  "A type with constraints on quantified variables."
+  (constraints nil :type list :read-only t) ; List of CX
+  (expr        nil :type ty   :read-only t))
+
 ;;; TY is forward declared in node.lisp
 
 (defstruct (tyvar (:include ty)
@@ -216,9 +226,36 @@ Types are equivalent when the structure (TYAPP and TYFUN) matches and there exis
   (or (tyvar-name v)
       (setf (tyvar-name v) (gensym "T"))))
 
+(defun extract-variables (ty)
+  "Extract variables from the type expression TY."
+  (let ((vars '()))
+    (labels ((descend (ty)
+               (etypecase ty
+                 (tyvar
+                  (push ty vars))
+
+                 (tyapp
+                  (mapc #'descend (tyapp-types ty)))
+
+                 (tyfun
+                  (mapc #'descend (tyfun-from ty))
+                  (descend (tyfun-to ty))))))
+      (descend ty))
+    vars))
+
 (defun unparse-type (ty)
   "Convert a type TY back into an S-expression representation (which could be parsed back again with PARSE-TYPE)."
   (etypecase ty
+    ;; Constrained types
+    (cty
+     `(coalton:for ,@(mapcar #'unparse-type (cty-constraints ty))
+                   coalton:=>
+                   ,(unparse-type (cty-expr ty))))
+
+    (cx
+     `(,(cx-class ty) ,(unparse-type (cx-variable ty))))
+
+    ;; TY substructures
     (tyvar
      (if (tyvar-instance ty)
          (unparse-type (tyvar-instance ty))