Adds looping forms to coalton

The looping forms added include:

- `while`
- `while-let`
- `for`
- `loop`

Also included are `break` and `continue`

And the new particle `in`.

coalton.asd

@@ -32,6 +32,7 @@
                (:file "settings")
                (:file "utilities")
                (:file "global-lexical")
+               (:file "constants")
                (:module "algorithm"
                 :serial t
                 :components ((:file "tarjan-scc")
@@ -324,4 +325,5 @@
                (:file "red-black-tests")
                (:file "seq-tests")
                (:file "unused-variables")
-               (:file "pattern-matching-tests")))
+               (:file "pattern-matching-tests")
+               (:file "looping-native-tests")))

docs/intro-to-coalton.md

@@ -311,6 +311,123 @@ Structs can also be parametric:
     (second :a)))
 ```
 
+## Looping & Iteration
+
+Coalton supports infinite looping, conditional looping, and `for`-loop styled iteration. 
+
+### `loop`, `while`, `while-let`, and `for`
+
+You can loop forever 
+
+```lisp
+(loop (trace "hi"))
+```
+
+You can loop while some condition is true
+
+```lisp
+(coalton
+ (let ((counter (cell:new 0))
+       (limit 10))
+   (while (< (cell:read counter) limit)
+     (trace "hi") 
+     (cell:increment! counter))))
+```
+
+You can loop so long as a pattern matches 
+
+```lisp
+(coalton
+ (let ((xs (vector:make 4 3 2 1)))
+   (while-let (Some x) = (vector:pop! xs)
+              (traceobject "x" x))))
+```
+
+You can loop over instances of `IntoIterator`
+
+```lisp
+(coalton
+ (for x in "coalton"
+      (traceobject "x" x)))
+```
+
+
+### `break` and `continue`
+
+Each of the above looping forms supports `break` and `continue`.
+
+The `break` form immediately terminates iteration.  The following
+prints out `c`, `o`, and `a` and then terminates.
+
+```lisp
+(coalton
+ (for x in "coalton"
+      (when (== x #\l)
+        (break))
+      (traceobject "x" x)))
+```
+
+The `continue` form skips the remainder of the loop's body and starts
+on its next iteration. The following prints out `c`, `o`, `a`, `t`,
+`o`, and `n`, having skipped the printing of `l`.
+
+```lisp
+(coalton
+ (for x in "coalton"
+      (when (== x #\l)
+        (continue))
+      (traceobject "x" x)))
+```
+
+
+### Loop Labels
+
+Each of the above looping forms takes an optional loop label
+keyword. These labels can be used in conjunction with `break` and
+`continue` to acheive complex control flow.
+
+For each of the looping forms, a label may immediately follow the
+opening term of the loop:
+
+```lisp 
+
+(loop :outer (do-stuff))
+
+(while :a-label (is-true?) (do-stuff))
+
+(while-let :another-label 
+   (Some thing) = (get-something)
+   (do-stuff thing))
+
+(for :iter word in words 
+   (do-stuff-with word))
+
+```
+
+In the following entirely artificial example, the outermost loop is
+labelled `:outer`. This label is passed to `break` from inside the
+inner `while` loop to terminate iteration whenever the sum of the
+accumulator and the counter exceeds 500.  Without the `:outer` label,
+`break` would have only broken out of the inner `while` loop.
+
+```lisp
+(coalton 
+  (let ((counter (cell:new 0))
+        (acc (cell:new Nil)))
+    (loop :outer
+          (while (< (cell:increment! counter) 10)
+            (let x = (fold + (cell:read counter) (cell:read acc)))
+            (when (< 500 x)
+              (break :outer))
+            (when (== 0 (mod (cell:read counter) 3)) 
+              (continue))
+            (cell:push! acc x))
+          (when (< (length (cell:read acc)) 500)
+            (cell:swap! counter 0)
+            Unit))
+    (cell:read acc)))
+```
+
 ## Numbers
 
 Coalton supports a few numeric types. The main ones are `Integer`, `Single-Float`, and `Double-Float`.

examples/thih/src/thih.lisp

@@ -556,15 +556,15 @@
 
   (declare simplify (ClassEnv -> (List Pred) -> (List Pred)))
   (define (simplify ce xs)
-    (let ((loop (fn (rs xs)
-                  (match xs
-                    ((Nil)
-                     rs)
-                    ((Cons p ps)
-                     (if (entail ce (append rs ps) p)
-                         (loop rs ps)
-                         (loop (Cons p rs) ps)))))))
-      (loop Nil xs)))
+    (let ((rec (fn (rs xs)
+                 (match xs
+                   ((Nil)
+                    rs)
+                   ((Cons p ps)
+                    (if (entail ce (append rs ps) p)
+                        (rec rs ps)
+                        (rec (Cons p rs) ps)))))))
+      (rec Nil xs)))
 
   (declare reduce (MonadFail :m => (ClassEnv -> (List Pred) -> (:m (List Pred)))))
   (define (reduce ce ps)

src/codegen/ast.lisp

@@ -54,6 +54,27 @@
    #:make-node-match                    ; CONSTRUCTOR
    #:node-match-expr                    ; ACCESSOR
    #:node-match-branches                ; ACCESSOR
+   #:node-while                         ; STRUCT
+   #:make-node-while                    ; CONSTRUCTOR
+   #:node-while-label                   ; ACCESSOR
+   #:node-while-expr                    ; ACCESSOR
+   #:node-while-body                    ; ACESSOR
+   #:node-while-let                     ; STRUCT
+   #:make-node-while-let                ; CONSTRUCTOR
+   #:node-while-let-label               ; ACESSOR
+   #:node-while-let-pattern             ; ACCESSPR 
+   #:node-while-let-expr                ; ACCESSOR
+   #:node-while-let-body                ; ACESSOR
+   #:node-loop                          ; STRUCT
+   #:make-node-loop                     ; CONSTRUCTOR
+   #:node-loop-body                     ; ACCESSOR
+   #:node-loop-label                    ; ACCESSOR 
+   #:node-break                         ; STRUCT
+   #:make-node-break                    ; CONSTRUCTOR
+   #:node-break-label                   ; ACCESSOR
+   #:node-continue                      ; STRUCT
+   #:make-node-continue                 ; CONSTRUCTOR
+   #:node-continue-label                ; ACCESSOR
    #:node-seq                           ; STRUCT
    #:make-node-seq                      ; CONSTRUCTOR
    #:node-seq-nodes                     ; ACCESSOR
@@ -165,6 +186,33 @@
   (expr (util:required 'expr) :type node :read-only t)
   (branches (util:required 'branches) :type branch-list :read-only t))
 
+(defstruct (node-while (:include node))
+  "A looping construct. Executes a body until an expression is false."
+  (label (util:required 'label) :type keyword :read-only t)
+  (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."
+  (label   (util:required 'label)   :type keyword :read-only t)
+  (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-loop (:include node))
+  "A labelled looping construct. Loops forever until broken out of by a
+call to (break)."
+  (label (util:required 'label) :type keyword :read-only t)
+  (body  (util:required 'body)  :type node    :read-only t))
+
+(defstruct (node-break (:include node))
+  "A break statment used to exit a loop."
+  (label (util:required 'label) :type keyword :read-only t))
+
+(defstruct (node-continue (:include node))
+  "A continue statment used to skip to the next iteration of a loop."
+  (label (util:required 'label) :type keyword :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))
@@ -329,6 +377,28 @@ both CL namespaces appearing in NODE"
         (node-variables-g node :variable-namespace-only variable-namespace-only))
       (node-match-branches node))))
 
+  (:method ((node node-while) &key variable-namespace-only)
+    (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-loop) &key variable-namespace-only)
+    (declare (values parser:identifier-list &optional))
+    (node-variables-g (node-loop-body node) :variable-namespace-only variable-namespace-only))
+
+  (:method ((node node-break) &key variable-namespace-only)
+    (declare (values parser:identifier-list &optional))
+    nil)
+
+  (:method ((node node-continue) &key variable-namespace-only)
+    (declare (values parser:identifier-list &optional))
+    nil)
+
   (:method ((node node-seq) &key variable-namespace-only)
     (declare (values parser:identifier-list &optional))
     (mapcan

src/codegen/codegen-expression.lisp

@@ -13,13 +13,22 @@
    (#:settings #:coalton-impl/settings)
    (#:util #:coalton-impl/util)
    (#:rt #:coalton-impl/runtime)
-   (#:tc #:coalton-impl/typechecker))
+   (#:tc #:coalton-impl/typechecker)
+   (#:const #:coalton-impl/constants))
   (:export
    #:codegen-expression                 ; FUNCTION
    ))
 
 (in-package #:coalton-impl/codegen/codegen-expression)
 
+(defun continue-label (lаbеl)
+  (declare (type symbol lаbеl))
+  (alexandria:format-symbol :keyword "~a-CONTINUE" lаbеl))
+
+(defun break-label (lаbеl)
+  (declare (type symbol lаbеl))
+  (alexandria:format-symbol :keyword "~a-BREAK" lаbеl))
+
 (defgeneric codegen-expression (node current-function env)
   (:method ((node node-literal) current-function env)
     (declare (type tc:environment env)
@@ -107,10 +116,65 @@
                 ,inner)
           inner)))
 
-  (:method ((expr node-match) current-function env)
+  (:method ((expr node-while) current-function env)
     (declare (type tc:environment env)
              (type (or null symbol) current-function))
 
+    (let ((pred-expr (codegen-expression (node-while-expr expr) current-function env))
+          (body-expr (codegen-expression (node-while-body expr) current-function env))
+          (label (node-while-label expr)))
+      `(loop
+         :named ,(break-label label)
+         :while ,pred-expr
+         :do
+            (block ,(continue-label label) ,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))
+          (label (node-while-let-label expr))
+          (match-var (gensym "MATCH")))
+
+      (multiple-value-bind (pred bindings)
+          (codegen-pattern (node-while-let-pattern expr) match-var env)
+        `(loop
+           :named ,(break-label label)
+           :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 (block ,(continue-label label)
+                 ,(cond ((null bindings) body-expr)
+                        (t `(let ,bindings
+                              (declare (ignorable ,@(mapcar #'car bindings)))
+                              ,body-expr))))))))
+
+  (:method ((expr node-loop) current-function env)
+    (declare (type tc:environment env)
+             (type (or null symbol) current-function))
+    (let ((body-expr (codegen-expression (node-loop-body expr) current-function env))
+          (label (node-loop-label expr)))
+      `(loop :named  ,(break-label label)
+             :do (block ,(continue-label label)
+                   ,body-expr))))
+
+  (:method ((expr node-break) current-function env)
+    (declare (type tc:environment env)
+             (type (or null symbol) current-function))
+    `(return-from ,(break-label (node-break-label expr))))
+
+  (:method ((expr node-continue) current-function env)
+    (declare (type tc:environment env)
+             (type (or null symbol) current-function))
+    `(return-from ,(continue-label (node-continue-label expr))))
+
+  (:method ((expr node-match) current-function env)
+    (declare (type tc:environment env)
+             (type (or null symbol) current-function))
     ;; If possible codegen a cl:if instead of a trivia:match
     (when (and (equalp (node-type (node-match-expr expr)) tc:*boolean-type*)
                (= 2 (length (node-match-branches expr)))

src/codegen/pattern.lisp

@@ -6,7 +6,7 @@
    (#:tc #:coalton-impl/typechecker))
   (:export
    #:pattern                            ; STRUCT
-   #:pattern-source                     ; ACCESSOR
+   #:pattern-type                       ; ACCESSOR
    #:pattern-list                       ; TYPE
    #:pattern-var                        ; STRUCT
    #:make-pattern-var                   ; ACCESSOR

src/codegen/transformations.lisp

@@ -119,6 +119,44 @@
                         (node-match-branches node)))))
       (call-if node :match funs bound-variables)))
 
+  (:method ((node node-while) funs bound-variables)
+    (declare (type util:symbol-list bound-variables))
+    (let ((node
+            (make-node-while
+             :type (node-type node)
+             :label (node-while-label node)
+             :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 tc:*unit-type*
+             :label (node-while-let-label 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-loop) funs bound-variables)
+    (declare (type util:symbol-list bound-variables))
+    (let ((node
+            (make-node-loop
+             :type tc:*unit-type*
+             :label (node-loop-label node)
+             :body (traverse (node-loop-body node) funs bound-variables))))
+      (call-if node :loop funs bound-variables)))
+
+  (:method ((node node-break) funs bound-variables)
+    (declare (type util:symbol-list bound-variables))
+    (call-if node :break funs bound-variables))
+
+  (:method ((node node-continue) funs bound-variables)
+    (declare (type util:symbol-list bound-variables))
+    (call-if node :continue funs bound-variables))
+
   (:method ((node node-seq) funs bound-variables)
     (declare (type util:symbol-list bound-variables))
     (let ((node