Add while-let

src/codegen/ast.lisp

@@ -58,6 +58,11 @@
    #:make-node-while                    ; CONSTRUCTOR
    #:node-while-expr                    ; ACCESSOR
    #:node-while-body                    ; ACESSOR
+   #:node-while-let                     ; STRUCT
+   #:make-node-while-let                ; CONSTRUCTOR
+   #:node-while-let-pattern             ; ACCESSPR 
+   #:node-while-let-expr                ; ACCESSOR
+   #:node-while-let-body                ; ACESSOR
    #:node-seq                           ; STRUCT
    #:make-node-seq                      ; CONSTRUCTOR
    #:node-seq-nodes                     ; ACCESSOR
@@ -174,6 +179,12 @@
   (expr (util:required 'expr) :type node :read-only t)
   (body (util:required 'body) :type node :read-only t))
 
+(defstruct (node-while-let (:include node))
+  "A looping construct. Executes a body until a pattern match fails."
+  (pattern  (util:required  'pattern)  :type  pattern  :read-only  t)
+  (expr     (util:required  'expr)     :type  node     :read-only  t)
+  (body     (util:required  'body)     :type  node     :read-only  t))
+
 (defstruct (node-seq (:include node))
   "A series of statements to be executed sequentially"
   (nodes (util:required 'nodes) :type node-list :read-only t))
@@ -342,6 +353,11 @@ both CL namespaces appearing in NODE"
     (declare (values parser:identifier-list &optional))
     (nconc (node-variables-g (node-while-expr node) :variable-namespace-only variable-namespace-only)
            (node-variables-g (node-while-body node) :variable-namespace-only variable-namespace-only)))
+
+  (:method ((node node-while-let) &key variable-namespace-only)
+    (declare (values parser:identifier-list &optional))
+    (nconc (node-variables-g (node-while-let-expr node) :variable-namespace-only variable-namespace-only)
+           (node-variables-g (node-while-let-body node) :variable-namespace-only variable-namespace-only)))
 
   (:method ((node node-seq) &key variable-namespace-only)
     (declare (values parser:identifier-list &optional))

src/codegen/codegen-expression.lisp

@@ -115,6 +115,27 @@
           (body-expr (codegen-expression (node-while-body expr) current-function env)))
       `(loop :while ,pred-expr
              :do ,body-expr)))
+
+  (:method ((expr node-while-let) current-function env)
+    (declare (type tc:environment env)
+             (type (or null symbol) current-function))
+
+    (let ((match-expr (codegen-expression (node-while-let-expr expr) current-function env))
+          (body-expr (codegen-expression (node-while-let-body expr) current-function env))
+          (match-var (gensym "MATCH")))
+
+      (multiple-value-bind (pred bindings)
+          (codegen-pattern (node-while-let-pattern expr) match-var env)
+
+        `(loop
+           :for ,match-var := ,(if settings:*emit-type-annotations*
+                                   `(the ,(tc:lisp-type (node-type (node-while-let-expr expr)) env) ,match-expr)
+                                   match-expr)
+           :while ,pred
+           :do ,(cond ((null bindings) body-expr)
+                      (t `(let ,bindings
+                            (declare (ignorable ,@(mapcar #'car bindings)))
+                            ,body-expr)))))))
 
   (:method ((expr node-match) current-function env)
     (declare (type tc:environment env)

src/codegen/transformations.lisp

@@ -127,6 +127,16 @@
              :expr (traverse (node-while-expr node) funs bound-variables)
              :body (traverse (node-while-body node) funs bound-variables))))
       (call-if node :while funs bound-variables)))
+
+  (:method ((node node-while-let) funs bound-variables)
+    (declare (type util:symbol-list bound-variables))
+    (let ((node
+            (make-node-while-let
+             :type (node-type node)
+             :pattern (node-while-let-pattern node)
+             :expr (traverse (node-while-let-expr node) funs bound-variables)
+             :body (traverse (node-while-let-body node) funs bound-variables))))
+      (call-if node :while-let funs bound-variables)))
 
   (:method ((node node-seq) funs bound-variables)
     (declare (type util:symbol-list bound-variables))

src/codegen/translate-expression.lisp

@@ -560,6 +560,16 @@ Returns a `node'.")
      :expr (translate-expression (tc:node-while-expr expr) ctx env)
      :body (translate-expression (tc:node-while-body expr) ctx env)))
 
+  (:method ((expr tc:node-while-let) ctx env)
+    (declare (type pred-context ctx)
+             (type tc:environment env)
+             (values node))
+    (make-node-while-let
+     :type tc:*unit-type*
+     :pattern (translate-pattern (tc:node-while-let-pattern expr))
+     :expr (translate-expression (tc:node-while-let-expr expr) ctx env)
+     :body (translate-expression (tc:node-while-let-body expr) ctx env)))
+
   (:method ((expr tc:node-cond) ctx env)
     (declare (type pred-context ctx)
              (type tc:environment env)

src/codegen/typecheck-node.lisp

@@ -113,6 +113,18 @@
                 (setf subs (tc:unify subs subexpr-ty type))))
       type))
 
+  (:method ((expr node-while) env)
+    (declare (type tc:environment env)
+             (values tc:ty))
+    (typecheck-node (node-while-expr expr) env)
+    (typecheck-node (node-while-body expr) env))
+
+  (:method ((expr node-while-let) env)
+    (declare (type tc:environment env)
+             (values tc:ty))
+    (typecheck-node (node-while-let-expr expr) env)
+    (typecheck-node (node-while-let-body expr) env))
+
   (:method ((expr node-seq) env)
     (declare (type tc:environment env)
              (values tc:ty))

src/package.lisp

@@ -74,6 +74,7 @@
    #:if
    #:when
    #:while
+   #:while-let
    #:unless
    #:and
    #:or

src/parser/collect.lisp

@@ -232,6 +232,16 @@ in expressions. May not include all bound variables."
     (declare (values node-variable-list))
     (mapcan #'collect-variables-generic% (node-cond-clauses node)))
 
+  (:method ((node node-while))
+    (declare (values node-variable-list))
+    (nconc (collect-variables-generic% (node-while-expr node))
+           (collect-variables-generic% (node-while-body node))))
+
+  (:method ((node node-while-let))
+    (declare (values node-variable-list))
+    (nconc (collect-variables-generic% (node-while-let-expr node))
+           (collect-variables-generic% (node-while-let-body node))))
+
   (:method ((node node-do-bind))
     (declare (values node-variable-list &optional))
     (collect-variables-generic% (node-do-bind-expr node)))

src/parser/expression.lisp

@@ -132,6 +132,11 @@
    #:make-node-while                    ; CONSTRUCTOR
    #:node-while-expr                    ; ACCESSOR
    #:node-while-body                    ; ACCESSOR
+   #:node-while-let                     ; STRUCT
+   #:make-node-while-let                ; CONSTRUCTOR
+   #:node-while-let-pattern             ; ACCESSOR
+   #:node-while-let-expr                ; ACCESSOR
+   #:node-while-let-body                ; ACCESSOR
    #:make-node-do                       ; CONSTRUCTOR
    #:node-do-nodes                      ; ACCESSOR
    #:node-do-last-node                  ; ACCESSOR
@@ -472,6 +477,13 @@
   (expr (util:required 'expr) :type node      :read-only t)
   (body (util:required 'body) :type node-body :read-only t))
 
+(defstruct (node-while-let
+            (:include node)
+            (:copier nil))
+  (pattern  (util:required  'pattern)  :type  pattern    :read-only  t)
+  (expr     (util:required  'expr)     :type  node       :read-only  t)
+  (body     (util:required  'body)     :type  node-body  :read-only  t))
+
 
 (defun parse-expression (form file)
   (declare (type cst:cst form)
@@ -890,6 +902,10 @@
           (eq 'coalton:while (cst:raw (cst:first form))))
      (parse-while form file))
 
+    ((and (cst:atom (cst:first form))
+          (eq 'coalton:while-let (cst:raw (cst:first form))))
+     (parse-while-let form file))
+
     ;;
     ;; Macros
     ;;
@@ -1365,9 +1381,9 @@
                  :file file
                  :highlight :end
                  :message "Malformed while expression"
-                 :primary-note "expected predicate")))
+                 :primary-note "expected match")))
 
-  ;; (while pred)
+  ;; (while match)
   (unless (cst:consp (cst:rest (cst:rest form)))
     (error 'parse-error
            :err (coalton-error
@@ -1382,6 +1398,41 @@
    :expr (parse-expression (cst:second form) file)
    :body (parse-body (cst:rest (cst:rest form)) form file)))
 
+(defun parse-while-let (form file)
+  (declare (type cst:cst form)
+           (type coalton-file file)
+           (values node-while-let))
+  (macrolet ((while-let-error (note)
+               `(error 'parse-error
+                      :err (coalton-error
+                            :span (cst:source form)
+                            :file file
+                            :highlight :end
+                            :message "Malformed while-let expression"
+                            :primary-note ,note))))
+
+    ;; (while-let)
+    (unless (cst:consp (cst:nthrest 1 form))
+      (while-let-error "expected match pattern")) 
+
+    ;; (while-let expr)
+    (unless (cst:consp (cst:nthrest 2 form))
+      (while-let-error "expected ="))
+
+    ;; (when-let expr =)
+    (unless (cst:consp (cst:nthrest 3 form))
+      (while-let-error "expected match expression"))
+
+    ;; (when-let expr = pattern)
+    (unless (cst:consp (cst:nthrest 4 form))
+      (while-let-error "exptected body")))
+
+  (make-node-while-let
+   :source (cst:source form)
+   :pattern (parse-pattern (cst:second form) file) 
+   :expr (parse-expression (cst:fourth form) file)
+   :body (parse-body (cst:nthrest 4 form) form  file)))
+
 (defun parse-let-declare (form file)
   (declare (type cst:cst form)
            (type coalton-file file)

src/parser/renamer.lisp

@@ -288,6 +288,17 @@
       :body (rename-variables-generic% (node-while-body node) ctx)
       :source (node-source node))
      ctx))
+
+  (:method ((node node-while-let) ctx)
+    (declare (type algo:immutable-map ctx)
+             (values node algo:immutable-map))
+    (values
+     (make-node-while-let
+      :pattern (rename-variables-generic% (node-while-let-pattern node) ctx)
+      :expr (rename-variables-generic% (node-while-let-expr node) ctx)
+      :body (rename-variables-generic% (node-while-let-body node) ctx)
+      :source (node-source node))
+     ctx))
 
   (:method ((node node-unless) ctx)
     (declare (type algo:immutable-map ctx)

src/typechecker/define.lisp

@@ -1268,6 +1268,58 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)")
                                                (tc:apply-substitution subs body-ty)
                                                (tc:apply-substitution subs expected-type)))))))))
 
+  (:method ((node parser:node-while-let) expected-type subs env file)
+    (declare (type tc:ty expected-type)
+             (type tc:substitution-list subs)
+             (type tc-env env)
+             (type coalton-file file)
+             (values tc:ty tc:ty-predicate-list accessor-list node-while-let tc:substitution-list))
+
+    (multiple-value-bind (expr-ty preds accessors expr-node subs)
+        (infer-expression-type (parser:node-while-let-expr node)
+                               (tc:make-variable) 
+                               subs
+                               env
+                               file)
+
+      (multiple-value-bind (pat-ty pat-node subs)
+          (infer-pattern-type (parser:node-while-let-pattern node) expr-ty subs env file)
+        (declare (ignore pat-ty))
+
+        (multiple-value-bind (body-ty preds_ accessors_ body-node subs)
+            (infer-expression-type (parser:node-while-let-body node)
+                                   tc:*unit-type*
+                                   subs
+                                   env
+                                   file)
+
+          (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-while-let
+                  :type (tc:qualify nil tc:*unit-type*)
+                  :source (parser:node-source node)
+                  :pattern pat-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))))))))))
+
   (:method ((node parser:node-cond-clause) expected-type subs env file)
     (declare (type tc:ty expected-type)
              (type tc:substitution-list subs)

src/typechecker/expression.lisp

@@ -115,6 +115,11 @@
    #:make-node-while                    ; CONSTRUCTOR
    #:node-while-expr                    ; ACCESSOR
    #:node-while-body                    ; ACCESSOR
+   #:node-while-let                     ; STRUCT
+   #:make-node-while-let                ; CONSTRUCTOR
+   #:node-while-let-pattern             ; ACCESSOR 
+   #:node-while-let-expr                ; ACCESSOR
+   #:node-while-let-body                ; ACCESSOR
    #:node-cond-clause                   ; STRUCT
    #:make-node-cond-clause              ; CONSTRUCTOR
    #:node-cond-clause-expr              ; ACCESSOR
@@ -312,6 +317,13 @@
   (expr (util:required 'expr) :type node      :read-only t)
   (body (util:required 'body) :type node-body :read-only t))
 
+(defstruct (node-while-let
+            (:include node)
+            (:copier nil))
+  (pattern  (util:required  'pattern)  :type  pattern    :read-only  t)
+  (expr     (util:required  'expr)     :type  node       :read-only  t)
+  (body     (util:required  'body)     :type  node-body  :read-only  t))
+
 (defstruct (node-cond-clause
             (:copier nil))
   (expr   (util:required 'expr)   :type node      :read-only t)
@@ -537,6 +549,16 @@
    :expr (tc:apply-substitution subs (node-while-expr node))
    :body (tc:apply-substitution subs (node-while-body node))))
 
+(defmethod tc:apply-substitution (subs (node node-while-let))
+  (declare (type tc:substitution-list subs)
+           (values node-while-let))
+  (make-node-while-let
+   :type (tc:apply-substitution subs (node-type node))
+   :source (node-source node)
+   :pattern (tc:apply-substitution subs (node-while-let-pattern node))
+   :expr (tc:apply-substitution subs (node-while-let-expr node))
+   :body (tc:apply-substitution subs (node-while-let-body node))))
+
 (defmethod tc:apply-substitution (subs (node node-cond-clause))
   (declare (type tc:substitution-list subs)
            (values node-cond-clause))

src/typechecker/traverse.lisp

@@ -34,6 +34,8 @@
   (unless          #'identity :type function :read-only t)
   (cond-clause     #'identity :type function :read-only t)
   (cond            #'identity :type function :read-only t)
+  (while           #'identity :type function :read-only t)
+  (while-let       #'identity :type function :read-only t)
   (do-bind         #'identity :type function :read-only t)
   (do              #'identity :type function :read-only t))
 
@@ -270,6 +272,29 @@
       :source (node-source node)
       :clauses (traverse (node-cond-clauses node) block))))
 
+  (:method ((node node-while) block)
+    (declare (type traverse-block block)
+             (values node &optional))
+    (funcall
+     (traverse-while block)
+     (make-node-while
+      :type (node-type node)
+      :source (node-source node)
+      :expr (traverse (node-while-expr node) block)
+      :body (traverse (node-while-body node) block))))
+
+  (:method ((node node-while-let) block)
+    (declare (type traverse-block block)
+             (values node &optional))
+    (funcall
+     (traverse-while block)
+     (make-node-while-let
+      :type (node-type node)
+      :source (node-source node)
+      :pattern (node-while-let-pattern node)
+      :expr (traverse (node-while-let-expr node) block)
+      :body (traverse (node-while-let-body node) block))))
+
   (:method ((node node-do-bind) block)
     (declare (type traverse-block block)
              (values node-do-bind &optional))