Refactor seal-clause macro. Change uses accordingly

diff --git a/src/thales/compile.scm b/src/thales/compile.scm
index ac9a2e391c6a1ab1382aa23e30ec7177f8de546a..6a70e23b2750e02b328dcf2886461d929a82bfd2 100644 (file)
--- a/src/thales/compile.scm
+++ b/src/thales/compile.scm
@@ -41,15 +41,15 @@
     path)
 
 (sealed modname->relative-filename
-       (& '(foo bar) => "foo/bar.scm")
-       (& '(baz baf) #:extension ".go" => "baz/baf.go"))
+       ([& '(foo bar)] => "foo/bar.scm")
+       ([& '(baz baf) #:extension ".go"] => "baz/baf.go"))
 
 (define* (modname->relative-filename module #:key (extension ".scm"))
     (string-append (string-join (map symbol->string module) "/")
                   extension))
 
 (sealed relative-to
-       (& "/home/kaction" "thales" => "/home/kaction/thales"))
+       ([& "/home/kaction" "thales"] => "/home/kaction/thales"))
 (define (relative-to basename fname)
     (format #f "~a/~a" basename fname))
 

diff --git a/src/thales/prepare.scm b/src/thales/prepare.scm
index 5b175d5d98686d99cb9e8381c92fdca31aa5e172..25d4f76c97dd4f43ef73f34a1a6966c9fc4e2c9d 100644 (file)
--- a/src/thales/prepare.scm
+++ b/src/thales/prepare.scm
@@ -14,9 +14,9 @@
 (use-modules (thales seal))
 
 (sealed string-starts-with
-       (& "foo" "fo" => #t)
-       (& "fo" "foo" => #f)
-       (& "f" #\c   -->))
+       ([& "foo" "fo"] => #t)
+       ([& "fo" "foo"] => #f)
+       ([& "f" #\c]   !-->))
 
 (define (string-starts-with str prefix)
     (define prefix-length (string-length prefix))
@@ -24,8 +24,8 @@
         (equal? prefix (substring str 0 prefix-length))))
 
 (sealed string-strip-prefix
-       (& "foo" "f" => "oo")
-       (& "bar" "f" => "bar"))
+       ([& "foo" "f"] => "oo")
+       ([& "bar" "f"] => "bar"))
 
 (define (string-strip-prefix str prefix)
     (if (string-starts-with str prefix)
@@ -33,13 +33,13 @@
        str))
 
 (sealed string-empty?
-       (& "fo" => #f)
-       (& ""   => #t))
+       ([& "fo"] => #f)
+       ([& ""]   => #t))
 (define (string-empty? str) (equal? str ""))
 
 (sealed relpath->module-name
-       (& "/foo/bar/baz.scm" => (foo bar baz))
-       (& "foo/bar/baz"      => (foo bar baz)))
+       ([& "/foo/bar/baz.scm"] => '(foo bar baz))
+       ([& "foo/bar/baz"]      => '(foo bar baz)))
 (define* (relpath->module-name path)
     (map (compose string->symbol #[basename <> ".scm"])
         (filter (negate string-empty?) (string-split path #\/))))
@@ -50,8 +50,8 @@
     (eq? (stat:type st) 'regular))
 
 (sealed have-extension?
-       (& "foo.foo" ".foo" => #t)
-       (& "barfoo"  ".foo" => #f))
+       ([& "foo.foo" ".foo"] => #t)
+       ([& "barfoo"  ".foo"] => #f))
 
 (define (have-extension? str ext)
     (not (equal? str (basename str ext))))

diff --git a/src/thales/seal.scm b/src/thales/seal.scm
index df0e9f2a34449d088c34bc514e9fa463a7d98898..71c4d2a781dd3f0012ce59f10234139dcf9c9ac1 100644 (file)
--- a/src/thales/seal.scm
+++ b/src/thales/seal.scm
@@ -1,15 +1,10 @@
 (define-module (thales seal)
     #:export (sealed))
+(use-modules (thales syntax))
 (use-modules (ice-9 match))
 (use-modules (srfi srfi-1))
 (use-modules (srfi srfi-26))
 
-(eval-when (eval load compile)
-    (read-hash-extend #\[
-        (lambda (ch stream)
-            (unread-char ch stream)
-            (cons 'cute (read stream)))))
-
 (define-syntax push
     (syntax-rules ()
         ((_ val list)
@@ -45,47 +40,96 @@ Eval: ~a\nExpect: ~a\nReceived: ~a\n" form expect result)
                      (unless throw-handler-called
                              (apply <on-values> args))))))))
 
-(define-syntax seal-clause
-    (syntax-rules (=> -->)
-        ((_ <form>) (seal-clause <form> => #t))
-        ((_ <form> => <val> <vals> ... )
-         (let ((expected (cons 'values '(<val> <vals> ...))))
-             (call-and-catch <form>
+(define-syntax seal-clause-expect-values
+    (syntax-rules ()
+       ([_ <form> (<val> ...)]
+        (let* ((expected (list 'values <val> ...))
+               (error:handle #[error:broken-seal '<form> expected]))
+            (call-and-catch <form>
+                (lambda args
+                    (unless (equal? args (cdr expected))
+                        (error:handle (cons 'values args))))
+                (lambda throw-args
+                    (error:handle (cons 'throw throw-args))))))))
+
+(define-syntax seal-clause-expect-throw
+    (syntax-rules ()
+       ([_ <form> (<val> ...)]
+        (let* ((expected (list 'throw <val> ...))
+               (error:handle #[error:broken-seal '<form>
+                                    (append expected '(....))]))
+            (call-and-catch <form>
                  (lambda args
-                     (unless (equal? args (cdr expected))
-                             (error:broken-seal '<form>
-                                                expected
-                                                (cons 'values args))))
-                 (lambda throw-args
-                     (error:broken-seal '<form>
-                                        expected
-                                        (cons 'throw throw-args))))))
-        ((_ <form> <forms> ... => <val> <vals> ...)
-         (seal-clause (<form> <forms> ...) => <val> <vals> ...))
-        ((_ <form> --> <val> ...)
-         (let ((expected (cons 'throw '(<val> ...))))
-             (call-and-catch <form>
-                (lambda args
-                    (error:broken-seal '<form>
-                                       (append expected '(....))
-                                       (cons 'values args)))
-                (lambda throw-args
-                    (unless (and (<= (length (cdr expected)) (length throw-args))
-                                 (every equal? (cdr expected) throw-args))
-                            (error:broken-seal '<form>
-                                               (append expected '(....))
-                                               (cons 'throw throw-args)))))))
-        ((_ <form> <forms> ... --> <val> ...)
-         (seal-clause (<form> <forms> ...) --> <val> ...))
-        ((_ obj ...)
-         (error "Macro seal-clause usage:
-Assert, that evaluation of EXPR returns value(s).
-    (seal-clause expr => value [values])
-Assert, that evaluation of EXPR is #t
-    (seal-clause expr)
-Assert, that evaluation of EXPR throws with argument list, starting with value(s)
-    (seal-clause expr --> value [values])
-In particular, (seal-clause expr -->) asserts, that EXPR throws something."))))
+                    (error:handle (cons 'values args)))
+                (lambda throw-args
+                    (define (throw-args-match expected-args actual-args)
+                        (and (<= (length expected-args) (length actual-args))
+                             (every equal? expected-args actual-args)))
+                    (unless (throw-args-match (cdr expected) throw-args)
+                        (error:handle (cons 'throw throw-args)))))))))
+
+;; (define-syntax paaqqck-forms
+;;     (syntax-rules ()
+;;     (_ <form>)
+;; )
+;; )
+(define-syntax seal-clause
+    (syntax-rules (=> !-->)
+       ([_ <form> => <val> ...]
+        (seal-clause-expect-values <form> (<val> ...)))
+       ([_ <form> !--> <val> ...]
+        (seal-clause-expect-throw <form> (<val> ...)))
+       ([_ <form>]
+        (seal-clause-expect-values <form> (#t)))))
+
+;; (define-syntax seal-clause
+;;     (syntax-rules (=> !-->)
+;;         ((_ <form> => <val> <vals> ... )
+;;          (let ((expected (cons 'values '(<val> <vals> ...))))
+;;          'CLAUSE-1
+;;              (call-and-catch <form>
+;;                  (lambda args
+;;                      (unless (equal? args (cdr expected))
+;;                              (error:broken-seal '<form>
+;;                                                 expected
+;;                                                 (cons 'values args))))
+;;                  (lambda throw-args
+;;                      (error:broken-seal '<form>
+;;                                         expected
+;;                                         (cons 'throw throw-args))))))
+;;         ((_ <form> <forms> ... => <val> <vals> ...)
+;;          (seal-clause (<form> <forms> ...) => <val> <vals> ...))
+;;         ((_ <form> !--> <val> ...)
+;;          (let ((expected (cons 'throw '(<val> ...))))
+;;          'CLAUSE-2
+;;              (call-and-catch <form>
+;;                 (lambda args
+;;                     (error:broken-seal '<form>
+;;                                        (append expected '(....))
+;;                                        (cons 'values args)))
+;;                 (lambda throw-args
+;;                     (unless (and (<= (length (cdr expected)) (length throw-args))
+;;                                  (every equal? (cdr expected) throw-args))
+;;                             (error:broken-seal '<form>
+;;                                                (append expected '(....))
+;;                                                (cons 'throw throw-args)))))))
+;;         ((_ <form> ... !--> <val> <vals> ...)
+;;      #f
+;;      ;; (let ('CLAUSE-X)
+;;      ;;     (seal-clause (<form> ...) !--> <val> ...))
+;; )
+;;;    ((_ <form> ...) (seal-clause <form> ... => #t))
+;;         ((_ obj ...)
+;;          (error "Macro seal-clause usage:
+;; Assert, that evaluation of EXPR returns value(s).
+;;     (seal-clause expr => value [values])
+;; Assert, that evaluation of EXPR is #t
+;;     (seal-clause expr)
+;; Assert, that evaluation of EXPR throws with argument list, starting with value(s)
+;;     (seal-clause expr --> value [values])
+;; In particular, (seal-clause expr -->) asserts, that EXPR throws something."))
+
+;; ))
 
 
 (define-syntax sealed

diff --git a/src/thales/solver.scm b/src/thales/solver.scm
index 943355b2702ddeb5decf16277b3d6082d05e9288..a5c79ba4f7a7fcfeca7d4f617bae8b3eccc6b0ef 100644 (file)
--- a/src/thales/solver.scm
+++ b/src/thales/solver.scm
@@ -47,34 +47,38 @@
 (use-modules (thales syntax))
 
 (sealed version-compatible?
-    (& '(1 2) '(1 2 0) => #t)
-    (& '(1 2 3) '(1 2 2) => #t))
+       ([& '(1 2) '(1 2 0)] => #t)
+       ([& '(1 2 3) '(1 2 2)] => #t))
 
 (define (version-compatible? v1 v2)
     "Version is compatible, if major versions is equal
 and minor is no less."
     (and (=  (car v1)  (car v2))
         (<= (cadr v1) (cadr v2))))
+(define-match (version-interchangeble? [major1 minor1 _ ...]
+                                      [major2 minor2 _ ...])
+    (and (= major1 major2)
+       (= minor1 minor2)))
 
 (sealed satisfy
-       (& '(foo ? (1 0))
-          '(foo (1 0 0))
-          => #t)
-       (& '(foo ? (2 0))
-          '(foo (1 2 3))
-          => #f)
-       (& '(foo ? (1 0))
-          '(foo (1 2 3))
-          => #t)
-       (& '(foo ? (1 0) (2 0))
-          '(foo   (1 2 3))
-          => #t)
-       (& '(foo = (1 2 3))
-          '(foo   (1 2 3))
-          => #t)
-       (& '(foo = (1 2 4) (1 2 7))
-          '(foo   (1 2 5))
-          => #f))
+       [(& '(foo ? (1 0))
+           '(foo (1 0 0)))
+        => #t]
+       [(& '(foo ? (2 0))
+           '(foo (1 2 3)))
+        => #f]
+       [(& '(foo ? (1 0))
+           '(foo (1 2 3)))
+        => #t]
+       [(& '(foo ? (1 0) (2 0))
+           '(foo   (1 2 3)))
+        => #t]
+       [(& '(foo = (1 2 3))
+           '(foo   (1 2 3)))
+        => #t]
+       [(& '(foo = (1 2 4) (1 2 7))
+            '(foo   (1 2 5)))
+        => #f])
 
 (define version-equal? equal?)