descriptive: add make-descriptive word to enable this functionality to be used as...

diff --git a/extra/descriptive/descriptive-docs.factor b/extra/descriptive/descriptive-docs.factor
index dc02f8bd9d04e4eddb1838f6d12c46f67fc2f7fc..6ced201c13a51918c324ed54dd53ce94f8d3c82d 100755 (executable)
--- a/extra/descriptive/descriptive-docs.factor
+++ b/extra/descriptive/descriptive-docs.factor
@@ -1,20 +1,28 @@
-USING: help.syntax help.markup ;\r
+USING: help.syntax help.markup words ;\r
 IN: descriptive\r
 \r
 HELP: DESCRIPTIVE:\r
 { $syntax "DESCRIPTIVE: word ( inputs -- outputs ) definition ;" }\r
-{ $description "Defines a word such that, if an error is thrown from within it, that error is wrapped in a descriptive tag including the arguments to that word." } ;\r
+{ $description "Defines a word such that, if an error is thrown from within it, that error is wrapped in a " { $link descriptive-error } " with the arguments to that word." } ;\r
 \r
 HELP: DESCRIPTIVE::\r
 { $syntax "DESCRIPTIVE:: word ( inputs -- outputs ) definition ;" }\r
-{ $description "Defines a word which uses locals such that, if an error is thrown from within it, that error is wrapped in a descriptive tag including the arguments to that word." } ;\r
+{ $description "Defines a word which uses locals such that, if an error is thrown from within it, that error is wrapped in a " { $link descriptive-error } " with the arguments to that word." } ;\r
 \r
-HELP: descriptive\r
-{ $class-description "The class of errors wrapping another error (in the underlying slot) which were thrown in a word (in the word slot) with a given set of arguments (in the args slot)." } ;\r
+HELP: descriptive-error\r
+{ $error-description "The class of errors wrapping another error (in the underlying slot) which were thrown in a word (in the word slot) with a given set of arguments (in the args slot)." } ;\r
+\r
+HELP: make-descriptive\r
+{ $values { "word" word } }\r
+{ $description "Makes the word wrap errors in " { $link descriptive-error } " instances." } ;\r
 \r
 ARTICLE: "descriptive" "Descriptive errors"\r
-"This vocabulary defines automatic descriptive errors. Using it, you can define a word which acts as normal, except when it throws an error, the error is wrapped in a special descriptor declaring that an error was thrown from inside that word, and including the arguments given to that word. The error is of the following class:"\r
-{ $subsection descriptive }\r
+"This vocabulary defines automatic descriptive errors. Using it, you can define a word which acts as normal, except when it throws an error, the error is wrapped in an instance of a class:"\r
+{ $subsection descriptive-error }\r
+"The wrapper contains the word itself, the input parameters, as well as the original error."\r
+$nl\r
+"To annotate an existing word with descriptive error checking:"\r
+{ $subsection make-descriptive }\r
 "To define words which throw descriptive errors, use the following words:"\r
 { $subsection POSTPONE: DESCRIPTIVE: }\r
 { $subsection POSTPONE: DESCRIPTIVE:: } ;\r

diff --git a/extra/descriptive/descriptive.factor b/extra/descriptive/descriptive.factor
index ceadc9fe6e311d09294d9523703f8c3f2d8193ba..9af94aa4ed47fa6b181f96a36ca81af2abc762f7 100755 (executable)
--- a/extra/descriptive/descriptive.factor
+++ b/extra/descriptive/descriptive.factor
@@ -1,6 +1,9 @@
-USING: words kernel sequences locals locals.parser
+! Copyright (c) 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: words kernel sequences locals locals.parser fry
 locals.definitions accessors parser namespaces continuations
-summary definitions generalizations arrays prettyprint debugger io ;
+summary definitions generalizations arrays prettyprint debugger io
+effects tools.annotations ;
 IN: descriptive
 
 ERROR: descriptive-error args underlying word ;
@@ -23,6 +26,10 @@ M: descriptive-error error.
 
 PRIVATE>
 
+: make-descriptive ( word -- )
+    dup [ ] [ def>> ] [ stack-effect ] tri [descriptive]
+    '[ drop _ ] annotate-methods ;
+
 : define-descriptive ( word def effect -- )
     [ drop "descriptive-definition" set-word-prop ]
     [ [ [ dup ] 2dip [descriptive] ] keep define-declared ]