First official version of aps, including sweet-macros and supporting PLT Scheme

14 files changed, 397 insertions, 35 deletions

diff --git a/scheme/Makefile b/scheme/Makefile
new file mode 100644
index 0000000..0fe7bd0
--- /dev/null
+++ b/scheme/Makefile
@@ -0,0 +1,4 @@
+upload:
+	python make_sweet_macros.py
+	zip -r aps aps/README.txt sweet-macros aps/compat.ikarus.sls aps/compat.ypsilon.sls aps/cut.sls aps/test-utils.sls aps/list-utils.sls aps/repeat.sls
+	#scp aps.zip merlin.phyast.pitt.edu:public_html/scheme
diff --git a/scheme/aps/README.txt b/scheme/aps/README.txt
new file mode 100644
index 0000000..33f24d4
--- /dev/null
+++ b/scheme/aps/README.txt
@@ -0,0 +1,63 @@
+:Title: The Adventures of a Pythonista in Schemeland
+:Version: 0.1
+:Author: Michele Simionato
+:Email: michele.simionato@gmail.com
+:Date: 28-Feb-2009
+:Licence: BSD
+
+The ``aps`` library is a collection of R6RS modules which have been
+developed as a companion to my long running series
+`The Adventures of a Pythonista in Schemeland`_.
+To check that the library works, unzip the distribution 
+in a directory in your Scheme path and run the tests::
+
+ $ cd <DIRECTORY-IN-MY-SCHEME-PATH>
+ $ unzip aps.zip
+ $ scheme-script aps/test-all.ss
+
+Currently all the tests pass with the latest development version of Ikarus.
+They also pass with the latest development version of Ypsilon and with
+PLT Scheme version 4, except for
+the test "zip-with-error". However, this is an expected failure, since the
+error messages are different between Ikarus, Ypsilon and PLT Scheme.
+Ypsilon is easy enough to support, and I use it, so I think I will
+keep supporting it in the future.
+
+On the other hand, currently PLT Scheme is only partially supported.
+I would like to support it better, and I will accept patches from PLT
+experts willing to help me; the nontrivial part is supporting
+``sweet-macros`` fully.
+
+Larceny Scheme is not supported since it does not support the ``.IMPL.sls``
+convention. When it does, it could be supported as well, expecially if I
+get some help from my readers.
+
+You should consider the libraries here in *alpha* status and subject to
+change, at least until I will conclude the series.
+ 
+.. _The Adventures of a Pythonista in Schemeland: http://www.artima.com/weblogs/viewpost.jsp?thread=238789
+
+License
+-----------
+
+The library is distributed under a liberal BSD new-style licence::
+
+   Redistributions of source code must retain the above copyright 
+   notice, this list of conditions and the following disclaimer.
+   Redistributions in bytecode form must reproduce the above copyright
+   notice, this list of conditions and the following disclaimer in
+   the documentation and/or other materials provided with the
+   distribution. 
+
+   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+   HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+   INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
+   BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
+   OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
+   ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR
+   TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
+   USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
+   DAMAGE.
diff --git a/scheme/aps/compat.ikarus.sls b/scheme/aps/compat.ikarus.sls
new file mode 100644
index 0000000..44c5055
--- /dev/null
+++ b/scheme/aps/compat.ikarus.sls
@@ -0,0 +1,4 @@
+(library (aps compat)
+(export printf format gensym pretty-print)
+(import (rnrs) (ikarus))
+)
diff --git a/scheme/aps/compat.mzscheme.sls b/scheme/aps/compat.mzscheme.sls
new file mode 100644
index 0000000..b08f3f0
--- /dev/null
+++ b/scheme/aps/compat.mzscheme.sls
@@ -0,0 +1,7 @@
+#!r6rs
+(library (aps compat)
+(export (rename (mzscheme:printf printf)
+                (mzscheme:format format)
+                (mzscheme:gensym gensym)
+                (mzscheme:pretty-print pretty-print)))
+(import (rnrs) (prefix (scheme) mzscheme:)))
diff --git a/scheme/aps/compat.ypsilon.sls b/scheme/aps/compat.ypsilon.sls
new file mode 100644
index 0000000..5c5dee3
--- /dev/null
+++ b/scheme/aps/compat.ypsilon.sls
@@ -0,0 +1,10 @@
+(library (aps compat)
+(export printf
+        (rename (ypsilon:format format)
+                (ypsilon:gensym gensym)
+                (ypsilon:pretty-print pretty-print)))
+(import (rnrs) (prefix (core) ypsilon:))
+
+(define (printf format-string . args)
+  (display (apply ypsilon:format format-string args)))
+)
diff --git a/scheme/aps/cut.sls b/scheme/aps/cut.sls
index ad66b5e..e2ea8ff 100644
--- a/scheme/aps/cut.sls
+++ b/scheme/aps/cut.sls
@@ -1,9 +1,8 @@
-; REFERENCE IMPLEMENTATION FOR SRFI-26 "CUT"
-; ==========================================
-;
-; michele.simionato@gmail.com, 25-Oct-2008
-; adapted from the posting by Al Petrofsky <al@petrofsky.org>
-; placed in the public domain
+#!r6rs
+;; REFERENCE IMPLEMENTATION FOR SRFI-26 "CUT"
+;; ==========================================
+;; adapted from the posting by Al Petrofsky <al@petrofsky.org>
+;; placed in the public domain
 
 (library (aps cut)
 (export cut cute)
diff --git a/scheme/aps/list-utils.sls b/scheme/aps/list-utils.sls
index 67afdfe..3358407 100644
--- a/scheme/aps/list-utils.sls
+++ b/scheme/aps/list-utils.sls
@@ -1,12 +1,8 @@
+#!r6rs
 (library (aps list-utils)
-;;; Version: 0.1
-;;; Author: Michele Simionato
-;;; Email: michele.simionato@gmail.com
-;;; Date: 31-Jan-2009
-;;; Licence: BSD
 (export range enumerate zip transpose distinct? let+ perm
-        remove-dupl append-unique fold list-of)
-(import (rnrs) (sweet-macros) (aps list-match) (aps cut))
+        remove-dupl append-unique fold flatten list-of)
+(import (rnrs) (sweet-macros) (aps cut))
 
 ;;; macros
 
@@ -86,7 +82,7 @@
  (define (transpose llist)
    (if (and (list? llist) (for-all list? llist))
        (apply map list llist)
-       (error 'transpose "Not a list of lists" llist)))
+       (error 'transpose "not a list of lists" llist)))
 ;;END
 
 ;;ENUMERATE
@@ -157,6 +153,6 @@
    (else; multi-element list 
     (list-of (cons el ls)
              (el in lst)
-             (ls in (perm eq? (remp (lambda (e) (eq? el e)) lst)))))))
+             (ls in (perm eq? (remp (cut eq? el <>) lst)))))))
 ;;END
 )
diff --git a/scheme/aps/test-all.ss b/scheme/aps/test-all.ss
new file mode 100644
index 0000000..f051422
--- /dev/null
+++ b/scheme/aps/test-all.ss
@@ -0,0 +1,119 @@
+(import (rnrs) (aps test-utils) (aps list-utils))
+
+(define (test-range-zip-transpose-enumerate)
+  (list
+   (test "range1"
+         (range 3)
+         '(0 1 2))
+   
+   (test "range2"
+         (range 0 3)
+         '(0 1 2))
+   
+   (test "range3"
+         (range 6 0 -2)
+         '(6 4 2))
+   
+   (test "zip"
+         (zip '(a b c) '(1 2 3))
+         '((a 1) (b 2) (c 3)))
+   
+   (test "zip-with-error"
+         (catch-error (zip '(a b c) '(1 2)))
+         "length mismatch")
+   
+   (test "zip3"
+         (zip '(a b) '(1 2) '(X Y))
+         '((a 1 X) (b 2 Y)))
+
+   (test "transpose"
+         (transpose '((x y) (1 2)))
+         '((x 1) (y 2)))
+   
+   (test "transpose-error"
+         (catch-error (transpose '((x y) 1)))
+         "not a list of lists")
+
+   (test "enumerate"
+         (enumerate '(a b c))
+         '((0 a) (1 b) (2 c)))
+   ))
+
+(define (test-distinct)
+  (define (eq1? a b)
+    (eq? (car a) (car b)))
+  (list
+   (test "distinct-true"
+         (distinct? eq? '(a b c))
+         #t)
+   
+   (test "distinct-false"
+         (distinct? eq? '(a b c c))
+         #f)
+   
+   (test "distinct-alist"
+         (distinct? eq1? '((a 1) (b 2) (a 3)))
+         #f)
+   
+   (test "remove-dupl"
+         (remove-dupl eq1? '((a 1) (b 2) (a 3)))
+         '((a 1) (b 2)))
+
+   (test "append-unique-1"
+         (append-unique eq? '(1 2 3) '(1 5 2 4))
+         '(1 2 3 5 4))
+   
+   (test "append-unique-2"
+         (append-unique eq1? '((a 1) (b 2) (a 3)) '((d 4)) '((b 5) (d 2)))
+         '((a 1) (b 2) (d 4)))
+
+   (test "perm-1"
+         (perm eq? '(1 2 3))
+         '((1 2 3) (1 3 2) (2 1 3) (2 3 1) (3 1 2) (3 2 1)))
+   
+   (test "perm-2"
+         (perm eq1? '((a 1) (b 2)))
+         '(((a 1) (b 2)) ((b 2) (a 1))))
+   
+   (test "perm-with-dupl"
+         (perm eq? '(a b a c))
+         '((a b c) (a c b) (b a c) (b a c) (a b c) (a c b) (c a b) (c a b)))
+   
+   (test "flatten-empty"
+         (flatten '())
+         '())
+
+   (test "flatten-flat"
+         (flatten '(1 2 3))
+         '(1 2 3))
+
+   (test "flatten-nested"
+         (flatten '(1 (2 3) (4 (5 6 (7 8)))))
+         '(1 2 3 4 5 6 7 8))
+   ))
+
+(define (test-let+comprehension)
+  (list
+   (test "let+1"
+         (let+ (x 1) x)
+         1)
+   
+   (test "let+2"
+         (let+ ((x y) '(1 2)) y)
+         2)
+   
+   (test "let+3"
+         (let+ ((x (y z)) '(1 (2 3))) z)
+         3)
+   
+   (test "list-of"
+         (list-of (cons i x) ((i x) in (enumerate '(a b c))) (even? i))
+         '((0 . a) (2 . c)))
+
+   ))
+   
+(apply run (append (test-range-zip-transpose-enumerate)
+                   (test-distinct)
+                   (test-let+comprehension)
+                   ))
+   
diff --git a/scheme/aps/test-utils.sls b/scheme/aps/test-utils.sls
index 615285c..9e206c3 100644
--- a/scheme/aps/test-utils.sls
+++ b/scheme/aps/test-utils.sls
@@ -1,12 +1,21 @@
+#!r6rs
 (library (aps test-utils)
-;;; Version: 0.5
-;;; Author: Michele Simionato
-;;; Email: michele.simionato@gmail.com
-;;; Date: 31-Jan-2009
-;;; Licence: BSD
-(export test run-tests runner run print-nothing print-dot print-msg)
-(import (rnrs) (only (ikarus) printf) (sweet-macros))
+(export catch-error test run-tests runner run)
+(import (rnrs) (aps compat) (sweet-macros))
 
+;; helper macro
+(def-syntax (catch-error body body* ...)
+  #'(let*
+        ((error-message #f)
+         (result
+          (guard (err ;; as a side effect, set! the error message if any
+                  ((or (assertion-violation? err) (error? err))
+                   (set! error-message (condition-message err))))
+                 body body* ...)))
+      (if error-message error-message
+          (error 'catch-error "Expected error, got none!"
+                 '(body body* ...) '=> result))))
+ 
 ;; test macro
 (def-syntax (test description expr expected)
   #'(lambda (cmd)
@@ -16,17 +25,21 @@
         ((run) (equal? expr expected))
         (else (error 'test "Invalid command" cmd)))))
 
-;; three helper functions
+;; four helper functions
 (define (print-nothing descr expected evalued-expr expr)
   (display ""))
 
-(define (print-dot descr expected expr evalued-expr)
+(define (print-dot descr expected evalued-expr expr)
   (display "."))
 
-(define (print-msg descr expected expr evalued-expr)
-  (printf "\n'~a' failed. Expected ~a, got ~a for ~a\n"
-          descr expected expr evalued-expr))
+(define (print-msg descr expected evalued-expr expr)
+  (printf "\n~s failed\nExpected ~s, got ~s\nExpression was ~a\n"
+          descr expected evalued-expr expr))
 
+(define (print-stats successes failures)
+  (define total (+ successes failures))
+  (printf "\nRun ~a tests. ~a passed, ~a failed\n" total successes failures))
+ 
 ;; full runner
 (define (run-tests print-success print-failure . tests)
   (let loop ((tests tests) (success 0) (failure 0))
@@ -43,10 +56,12 @@
                 (loop (cdr tests) success (+ 1 failure))))))))
 
 ;; runner factory
-(define (runner print-success print-failure)
-  (lambda tests (apply run-tests print-success print-failure tests)))
+(define (runner print-success print-failure print-stats)
+  (lambda tests
+    (define succ-fail (apply run-tests print-success print-failure tests))
+    (apply print-stats succ-fail)))
 
 ;; default runner
-(define run (runner print-dot print-msg))
+(define run (runner print-dot print-msg print-stats))
 
 )
diff --git a/scheme/make_sweet_macros.py b/scheme/make_sweet_macros.py
new file mode 100644
index 0000000..96c6d1b
--- /dev/null
+++ b/scheme/make_sweet_macros.py
@@ -0,0 +1,51 @@
+import os, sys, shutil
+from scheme2rst import SNIPPET
+
+code = file('sweet-macros/main.sls').read()
+
+# LOCAL, GUARDED-SYNTAX-CASE, SYNTAX-MATCH, DEF-SYNTAX, SYNTAX-EXPAND
+snippets = [s.groups() for s in SNIPPET.finditer(code)]
+snippet = dict(snippets)
+
+helper1 = '''#!r6rs
+(library (sweet-macros helper1)
+(export local guarded-syntax-case)
+(import (rnrs))
+
+%(LOCAL)s
+
+%(GUARDED-SYNTAX-CASE)s
+)
+'''
+
+helper2 = '''#!r6rs
+(library (sweet-macros helper2)
+(export local guarded-syntax-case syntax-match)
+(import (rnrs) (for (sweet-macros helper1) run expand))
+
+%(SYNTAX-MATCH)s
+)
+'''
+
+main = '''#!r6rs
+(library (sweet-macros)
+(export local guarded-syntax-case syntax-match def-syntax syntax-expand)
+(import (rnrs) (for (sweet-macros helper2) run expand))
+
+%(DEF-SYNTAX)s
+
+%(SYNTAX-EXPAND)s
+)
+'''
+
+def makefiles(name, snippet):
+    file(name + '/helper1.mzscheme.sls', 'w').write(helper1 % snippet)
+    file(name + '/helper2.mzscheme.sls', 'w').write(helper2 % snippet)
+    file(name + '/main.mzscheme.sls', 'w').write(main % snippet)
+    #os.system('zip -r %s %s' % (name, name))
+    
+if __name__ == '__main__':
+    #plt_home = os.path.expanduser('~/.plt-scheme')
+    #collects = os.path.join(plt_home, max(os.listdir(plt_home)), 'collects')
+    makefiles('sweet-macros', snippet)
+  
diff --git a/scheme/sweet-macros/helper1.mzscheme.sls b/scheme/sweet-macros/helper1.mzscheme.sls
new file mode 100644
index 0000000..7c58613
--- /dev/null
+++ b/scheme/sweet-macros/helper1.mzscheme.sls
@@ -0,0 +1,42 @@
+#!r6rs
+(library (sweet-macros helper1)
+(export local guarded-syntax-case)
+(import (rnrs))
+
+(define-syntax local
+  (lambda (x)
+    (syntax-case x (syntax-match)
+      ((local expr)
+       #'expr)
+      ((local (let-form name value) ... (syntax-match rest ...))
+       #'(syntax-match (local (let-form name value) ...) rest ...))
+      ((local (let-form name value) (l n v) ... expr)
+       #'(let-form ((name value)) (local (l n v) ... expr))))
+    ))
+
+(define-syntax guarded-syntax-case
+  (let ((add-clause
+         (lambda (clause acc)
+           (syntax-case clause ()
+             ((pattern skeleton . rest)
+                (syntax-case #'rest ()
+                  ((cond? else1 else2 ...)
+                   (cons*
+                    #'(pattern cond? skeleton)
+                    #'(pattern (begin else1 else2 ...))
+                    acc))
+                  ((cond?)
+                   (cons #'(pattern cond? skeleton) acc))
+                  (()
+                   (cons #'(pattern skeleton) acc))
+                  ))))))
+    (lambda (x)
+      (syntax-case x ()
+        ((guarded-syntax-case () (literal ...) clause ...)
+         #'(lambda (y) (guarded-syntax-case y (literal ...) clause ...)))
+        ((guarded-syntax-case y (literal ...) clause ...)
+         (with-syntax
+             (((c ...) (fold-right add-clause '() #'(clause ...))))
+           #'(syntax-case y (literal ...) c ...)))
+        ))))
+)
diff --git a/scheme/sweet-macros/helper2.mzscheme.sls b/scheme/sweet-macros/helper2.mzscheme.sls
new file mode 100644
index 0000000..e1c14cc
--- /dev/null
+++ b/scheme/sweet-macros/helper2.mzscheme.sls
@@ -0,0 +1,34 @@
+#!r6rs
+(library (sweet-macros helper2)
+(export local guarded-syntax-case syntax-match)
+(import (rnrs) (for (sweet-macros helper1) run expand))
+
+(define-syntax syntax-match
+  (guarded-syntax-case () (sub local)
+    ((self (local (let-form name value) ...) (literal ...)
+           (sub patt skel . rest) ...)
+     #'(local (let-form name value) ...
+         (guarded-syntax-case ()
+           (<literals> <patterns> <source> <transformer> literal ...)
+           ((ctx <literals>)
+            #''((... (... literal)) ...))
+           ((ctx <patterns>)
+            #''((... (... patt)) ...))
+           ((ctx <source>)
+            #''(self (local (let-form name value) ...) ((... (... literal)) ...)
+                     (... (... (sub patt skel . rest))) ...))
+           ((ctx <transformer>)
+            #'(self (local (let-form name value) ...) ((... (... literal)) ...)
+                    (... (... (sub patt skel . rest))) ...))
+           (patt skel . rest) ...))
+     (for-all identifier? #'(literal ...))
+     (syntax-violation 'syntax-match "Found non identifier" #'(literal ...)
+                       (remp identifier? #'(literal ...))))
+    
+    ((self (literal ...) (sub patt skel . rest) ...)
+     #'(self (local)(literal ...) (sub patt skel . rest) ...))
+
+    ((self x (literal ...) (sub patt skel . rest) ...)
+     #'(guarded-syntax-case x (literal ...) (patt skel . rest) ...))
+    ))
+)
diff --git a/scheme/sweet-macros/main.mzscheme.sls b/scheme/sweet-macros/main.mzscheme.sls
new file mode 100644
index 0000000..488e291
--- /dev/null
+++ b/scheme/sweet-macros/main.mzscheme.sls
@@ -0,0 +1,23 @@
+#!r6rs
+(library (sweet-macros)
+(export local guarded-syntax-case syntax-match def-syntax syntax-expand)
+(import (rnrs) (for (sweet-macros helper2) run expand))
+
+(define-syntax def-syntax
+  (syntax-match (extends local)
+    (sub (def-syntax name (extends parent)
+       (local loc ...) (literal ...) 
+       clause ...)
+     #'(define-syntax name
+         (syntax-match (local loc ...) (literal ...)
+           clause ...
+           (sub x ((parent <transformer>) #'x)))))
+    (sub (def-syntax (name . args) skel . rest)
+     #'(define-syntax name (syntax-match () (sub (name . args) skel . rest))))
+    (sub (def-syntax name transformer)
+     #'(define-syntax name transformer))
+    ))
+
+(def-syntax (syntax-expand (macro . args))
+  #'(syntax->datum ((macro <transformer>) #'(... (... (macro . args))))))
+)
diff --git a/scheme/sweet-macros.sls b/scheme/sweet-macros/main.sls
index bc90e70..8d9e632 100644
--- a/scheme/sweet-macros.sls
+++ b/scheme/sweet-macros/main.sls
@@ -1,9 +1,4 @@
 (library (sweet-macros)
-;;; Version: 0.5
-;;; Author: Michele Simionato
-;;; Email: michele.simionato@gmail.com
-;;; Date: 07-Feb-2009
-;;; Licence: BSD
 (export syntax-match def-syntax syntax-expand local)
 (import (rnrs))