[honu] add list comprehensions

collects/honu/core/main.rkt

@@ -21,6 +21,8 @@
                      [honu-> >] [honu-< <]
                      [honu->= >=] [honu-<= <=]
                      [honu-= =]
+                     [literal:honu-<- <-]
+                     [honu-map map]
                      [honu-flow \|]
                      [honu-dot |.|]
                      [honu-cons ::]

collects/honu/core/private/honu2.rkt

@@ -149,5 +149,6 @@
 (define-binary-operator honu-and 0.5 'left and)
 (define-binary-operator honu-or 0.5 'left or)
 (define-binary-operator honu-cons 0.1 'right cons)
+(define-binary-operator honu-map 0.09 'left map)
 
 (define-unary-operator honu-not 0.7 'left not)

collects/honu/core/private/literals.rkt

@@ -19,6 +19,7 @@
                 honu-&= honu-^= honu-\|= honu-<<= honu->>= honu->>>=
                 honu->> honu-<< honu->>> honu-< honu-> honu-<= honu->=
                 honu-!= honu-==
+                honu-<-
                 honu-literal
                 honu-then
                 honu-? honu-: honu-comma honu-. #%braces #%brackets #%parens colon
@@ -27,4 +28,4 @@
                 honu-for-syntax
                 honu-for-template)
 
-(define-literal-set cruft (#%parens #%brackets #%braces semicolon colon honu-comma))
+(define-literal-set cruft (#%parens #%brackets #%braces semicolon colon honu-comma honu-<-))

collects/honu/core/private/parse2.rkt

@@ -225,17 +225,26 @@
                          (do-parse #'(rest ...) precedence left #'x))]
                      ;; [1, 2, 3] -> (list 1 2 3)
                      [(#%brackets stuff ...)
-                      (define value (with-syntax ([(data ...)
+                      (syntax-parse #'(stuff ...) #:literal-sets (cruft)
-                                                   (parse-comma-expression #'(stuff ...))])
+                        [(work:honu-expression colon (~seq variable:id honu-<- list:honu-expression (~optional honu-comma)) ...)
-                                      #'(list data ...)))
+                         (define comprehension #'(for/list ([variable list.result]
-                      (define lookup (with-syntax ([(data ...)
+                                                            ...)
-                                                    (parse-comma-expression #'(stuff ...))]
+                                                   work.result))
-                                                   [current current])
+                         (if current
-                                       #'(do-lookup current data ...)))
+                           (error 'parse "a list comprehension cannot follow an expression")
-                      (if current
+                           (do-parse #'(rest ...) precedence left comprehension))]
-                         ;; (values (left current) stream)
+                        [else
-                         (do-parse #'(rest ...) precedence left lookup)
+                          (define value (with-syntax ([(data ...)
-                         (do-parse #'(rest ...) precedence left value))]
+                                                       (parse-comma-expression #'(stuff ...))])
+                                          #'(list data ...)))
+                          (define lookup (with-syntax ([(data ...)
+                                                        (parse-comma-expression #'(stuff ...))]
+                                                       [current current])
+                                           #'(do-lookup current data ...)))
+                          (if current
+                            ;; (values (left current) stream)
+                            (do-parse #'(rest ...) precedence left lookup)
+                            (do-parse #'(rest ...) precedence left value))])]
                      ;; block of code
                      [(#%braces stuff ...)
                       (if current

collects/honu/core/read.rkt

@@ -34,7 +34,7 @@
                                          (:~ #\")))
 (define-lex-abbrev string (:: #\" (:* string-character) #\"))
 (define-lex-abbrev operator (:or "+" "=" "*" "/" "-" "^" "||" "|" "&&" "<="
-                                 ">=" "<" ">" "!" "::"))
+                                 ">=" "<-" "<" ">" "!" "::"))
 (define-lex-abbrev block-comment (:: "/*"
                                      (complement (:: any-string "*/" any-string))
                                      "*/"))

collects/honu/main.rkt

@@ -21,6 +21,7 @@
          number? symbol?
          null
          null?
+         length
          (rename-out [honu-cond cond]
                      [null empty]
                      [racket:empty? empty?]

collects/honu/tests/list.rkt

@@ -0,0 +1,5 @@
+#lang honu
+
+[x + 2: x <- [1, 2, 3]];
+
+[x + y: x <- [1, 2, 3], y <- [5, 6, 7]]

collects/honu/tests/map.rkt

@@ -0,0 +1,3 @@
+#lang honu
+
+function(x){ x + 1 } map 1 :: 2 :: 3 :: null;

collects/honu/tests/test.rkt

@@ -39,7 +39,9 @@
   (apply string-append "" (append stuff (list "\n"))))
 
 (define (test input output)
-  (same? (run-honu input) output))
+  (define final (run-honu input))
+  (when (not (same? final output))
+    (printf "Not the same!\n'~a'\nvs\n'~a'\n" final output)))
 
 (define (input . stuff)
   (apply string-append "#lang honu\n" stuff))
@@ -94,3 +96,12 @@
 
   @output{1
   })
+
+(test
+  @input{
+  [x + 1: x <- [1, 2, 3]];
+  [x + y: x <- [1, 2, 3], y <- [4, 5, 6]]
+  }
+
+  @output{'(2 3 4)
+  '(5 7 9)})