Unit elision feature in when and unless body

coalton-lang · Sep 26, 2023 · a155db3 · a155db3
1 parent 1a9b00b
commit a155db3
Show file tree

Hide file tree

Showing 2 changed files with 50 additions and 52 deletions.
diff --git a/src/codegen/translate-expression.lisp b/src/codegen/translate-expression.lisp
@@ -500,7 +500,17 @@ Returns a `node'.")
     (let* ((coalton-package (find-package "COALTON"))
            (true-value (util:find-symbol "TRUE" coalton-package))
            (false-value (util:find-symbol "FALSE" coalton-package))
-           (unit-value (util:find-symbol "UNIT" coalton-package)))
+           (unit-value (util:find-symbol "UNIT" coalton-package))
+           (translated-body (translate-expression (tc:node-when-body expr) ctx env)))
+
+      (unless (equalp tc:*unit-type* (node-type translated-body))
+        (setf translated-body
+              (make-node-seq
+               :type tc:*unit-type*
+               :nodes (list translated-body
+                            (make-node-variable
+                             :type tc:*unit-type*
+                             :value unit-value)))))
 
       (make-node-match
        :type tc:*unit-type*
@@ -511,7 +521,7 @@ Returns a `node'.")
                              :type tc:*boolean-type*
                              :name true-value
                              :patterns nil)
-                   :body (translate-expression (tc:node-when-body expr) ctx env))
+                   :body translated-body)
                   (make-match-branch
                    :pattern (make-pattern-constructor
                              :type tc:*boolean-type*
@@ -529,7 +539,17 @@ Returns a `node'.")
     (let* ((coalton-package (find-package "COALTON"))
            (true-value (util:find-symbol "TRUE" coalton-package))
            (false-value (util:find-symbol "FALSE" coalton-package))
-           (unit-value (util:find-symbol "UNIT" coalton-package)))
+           (unit-value (util:find-symbol "UNIT" coalton-package))
+           (translated-body (translate-expression (tc:node-unless-body expr) ctx env)))
+
+      (unless (equalp tc:*unit-type* (node-type translated-body))
+        (setf translated-body
+              (make-node-seq
+               :type tc:*unit-type*
+               :nodes (list translated-body
+                            (make-node-variable
+                             :type tc:*unit-type*
+                             :value unit-value)))))
 
       (make-node-match
        :type tc:*unit-type*
@@ -538,13 +558,13 @@ Returns a `node'.")
                   (make-match-branch
                    :pattern (make-pattern-constructor
                              :type tc:*boolean-type*
-                             :name false-value
+                             :name true-value
                              :patterns nil)
-                   :body (translate-expression (tc:node-unless-body expr) ctx env))
+                   :body translated-body)
                   (make-match-branch
                    :pattern (make-pattern-constructor
                              :type tc:*boolean-type*
-                             :name true-value
+                             :name false-value
                              :patterns nil)
                    :body (make-node-variable
                           :type tc:*unit-type*

diff --git a/src/typechecker/define.lisp b/src/typechecker/define.lisp
@@ -1144,35 +1144,24 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)")
 
       (multiple-value-bind (body-ty preds_ accessors_ body-node subs)
           (infer-expression-type (parser:node-when-body node)
-                                 tc:*unit-type*
+                                 (tc:make-variable)
                                  subs
                                  env
                                  file)
+        (declare (ignore body-ty))
         (setf preds (append preds preds_))
         (setf accessors (append accessors accessors_))
 
-        (handler-case
-            (progn
-              (setf subs (tc:unify subs body-ty expected-type))
-              (values
-               tc:*unit-type*
-               preds
-               accessors
-               (make-node-when
-                :type (tc:qualify nil tc:*unit-type*)
-                :source (parser:node-source node)
-                :expr expr-node
-                :body body-node)
-               subs))
-          (error:coalton-internal-type-error ()
-            (error 'tc-error
-                   :err (coalton-error
-                         :span (parser:node-source node)
-                         :file file
-                         :message "Type mismatch"
-                         :primary-note (format nil "Expected type '~S' but got '~S'"
-                                               (tc:apply-substitution subs body-ty)
-                                               (tc:apply-substitution subs expected-type)))))))))
+        (values
+         tc:*unit-type*
+         preds
+         accessors
+         (make-node-when
+          :type (tc:qualify nil tc:*unit-type*)
+          :source (parser:node-source node)
+          :expr expr-node
+          :body body-node)
+         subs))))
 
   (:method ((node parser:node-unless) expected-type subs env file)
     (declare (type tc:ty expected-type)
@@ -1191,35 +1180,24 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)")
 
       (multiple-value-bind (body-ty preds_ accessors_ body-node subs)
           (infer-expression-type (parser:node-unless-body node)
-                                 tc:*unit-type*
+                                 (tc:make-variable)
                                  subs
                                  env
                                  file)
+        (declare (ignore body-ty))
         (setf preds (append preds preds_))
         (setf accessors (append accessors accessors_))
 
-        (handler-case
-            (progn
-              (setf subs (tc:unify subs body-ty expected-type))
-              (values
-               tc:*unit-type*
-               preds
-               accessors
-               (make-node-unless
-                :type (tc:qualify nil tc:*unit-type*)
-                :source (parser:node-source node)
-                :expr expr-node
-                :body body-node)
-               subs))
-          (error:coalton-internal-type-error ()
-            (error 'tc-error
-                   :err (coalton-error
-                         :span (parser:node-source node)
-                         :file file
-                         :message "Type mismatch"
-                         :primary-note (format nil "Expected type '~S' but got '~S'"
-                                               (tc:apply-substitution subs body-ty)
-                                               (tc:apply-substitution subs expected-type)))))))))
+        (values
+         tc:*unit-type*
+         preds
+         accessors
+         (make-node-unless
+          :type (tc:qualify nil tc:*unit-type*)
+          :source (parser:node-source node)
+          :expr expr-node
+          :body body-node)
+         subs))))
 
   (:method ((node parser:node-cond-clause) expected-type subs env file)
     (declare (type tc:ty expected-type)