help.lint.checks: check for disposable leaks and print more details when $values are wrong

basis/help/lint/checks/checks-docs.factor

@@ -0,0 +1,18 @@
+USING: help.markup help.syntax sequences words ;
+IN: help.lint.checks
+
+HELP: check-example
+{ $values { "element" sequence } }
+{ $description "Throws an error if the expected output from the $example is different from the expected, or if it leaks disposables." } ;
+
+HELP: check-values
+{ $values { "word" word } { "element" sequence } }
+{ $description "Throws an error if the $values pair doesnt match the declared stack effect." }
+{ $examples
+  { $unchecked-example
+    "USING: help.lint.checks math ;"
+    ": foo ( x -- y ) ;"
+    "\\ foo { $values { \"a\" number } { \"b\" number } } check-values"
+    "$values don't match stack effect; expected { \"x\" \"y\" }, got { \"a\" \"b\" }\n\nType :help for debugging help."
+    }
+} ;

basis/help/lint/checks/checks.factor

@@ -1,11 +1,11 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs classes classes.tuple combinators
-combinators.short-circuit debugger definitions effects eval fry
+combinators.short-circuit debugger definitions effects eval
-grouping help help.markup help.topics io io.streams.string
+formatting fry grouping help help.markup help.topics io io.streams.string
-kernel macros namespaces sequences sequences.deep sets splitting
+kernel macros math namespaces sequences sequences.deep sets splitting
-strings summary unicode.categories vocabs vocabs.loader words
+strings summary threads tools.destructors unicode.categories vocabs vocabs.loader
-words.constant words.symbol ;
+words words.constant words.symbol ;
 FROM: sets => members ;
 IN: help.lint.checks
 
@@ -20,14 +20,18 @@ SYMBOL: all-vocabs
 SYMBOL: vocab-articles
 
 : check-example ( element -- )
-    '[
+    [
-        _ rest [
+        '[
-            but-last "\n" join
+            _ rest [
-            [ (eval>string) ] call( code -- output )
+                but-last "\n" join
-            "\n" ?tail drop
+                [ (eval>string) ] call( code -- output )
-        ] keep
+                "\n" ?tail drop
-        last assert=
+            ] keep
-    ] vocabs-quot get call( quot -- ) ;
+            last assert=
+        ] vocabs-quot get call( quot -- )
+    ] leaks members length [
+        "%d disposable(s) leaked in example" sprintf simple-lint-error
+    ] unless-zero ;
 
 : check-examples ( element -- )
     \ $example swap elements [ check-example ] each ;
@@ -39,7 +43,7 @@ SYMBOL: vocab-articles
 
 : extract-value-effects ( element -- seq )
     \ $values swap elements dup empty? [
-        first rest [ 
+        first rest [
             \ $quotation swap elements dup empty? [ drop f ] [
                 first second
             ] if
@@ -77,18 +81,17 @@ SYMBOL: vocab-articles
         [ constant? ]
     } 1|| ;
 
+: skip-check-values? ( word element -- ? )
+    [ don't-check-word? ] [ contains-funky-elements? ] bi* or ;
+
 : check-values ( word element -- )
-    {
+    2dup skip-check-values? [ 2drop ] [
-        [
+        [ effect-values ] [ extract-values ] bi* 2dup
-            [ don't-check-word? ]
+        sequence= [ 2drop ] [
-            [ contains-funky-elements? ]
+            "$values don't match stack effect; expected %u, got %u" sprintf
-            bi* or
+            simple-lint-error
-        ] [
+        ] if
-            [ effect-values ]
+    ] if ;
-            [ extract-values ]
-            bi* sequence=
-        ]
-    } 2|| [ "$values don't match stack effect" simple-lint-error ] unless ;
 
 : check-value-effects ( word element -- )
     [ effect-effects ]

basis/tools/destructors/destructors-docs.factor

@@ -1,25 +1,34 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax help.tips quotations destructors ;
+USING: destructors help.markup help.syntax help.tips quotations sequences ;
 IN: tools.destructors
 
 HELP: disposables.
 { $description "Print the number of disposable objects of each class." } ;
 
-HELP: leaks
+HELP: leaks.
 { $values
     { "quot" quotation }
 }
 { $description "Runs a quotation, printing any increases in the number of disposable objects after the quotation returns. The " { $link debug-leaks? } " variable is also switched on while the quotation runs, recording the current continuation in every newly-created disposable object." } ;
 
-TIP: "Use the " { $link leaks } " combinator to track down resource leaks." ;
+HELP: leaks
+{ $values
+  { "quot" quotation }
+  { "disposables" sequence }
+}
+{ $description
+  "Runs the quotation and collects all disposables leaked by it. Used by " { $link leaks. } "."
+} ;
+
+TIP: "Use the " { $link leaks. } " combinator to track down resource leaks." ;
 
 ARTICLE: "tools.destructors" "Destructor tools"
 "The " { $vocab-link "tools.destructors" } " vocabulary provides words for tracking down resource leaks."
 { $subsections
     debug-leaks?
     disposables.
-    leaks
+    leaks.
 }
 { $see-also "destructors" } ;
 

basis/tools/destructors/destructors-tests.factor

@@ -3,11 +3,10 @@ IN: tools.destructors.tests
 
 f debug-leaks? set-global
 
-[ [ 3 throw ] leaks ] must-fail
+[ [ 3 throw ] leaks. ] must-fail
 
 [ f ] [ debug-leaks? get-global ] unit-test
 
-[ ] [ [ ] leaks ] unit-test
+[ ] [ [ ] leaks. ] unit-test
 
 [ f ] [ debug-leaks? get-global ] unit-test
-

basis/tools/destructors/destructors.factor

@@ -45,10 +45,13 @@ PRIVATE>
     [ disposables get members sort-disposables ] dip
     '[ _ instance? ] filter stack. ;
 
-: leaks ( quot -- )
+: leaks ( quot -- disposables )
     disposables get clone
     t debug-leaks? set-global
     [
         [ call disposables get clone ] dip
     ] [ f debug-leaks? set-global ] [ ] cleanup
-    diff (disposables.) ; inline
+    diff ; inline
+
+: leaks. ( quot -- )
+    leaks (disposables.) ; inline