--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors arrays assocs compiler.units
+debugger io kernel namespaces prettyprint sequences
+source-files.errors summary tools.crossref.private
+tools.errors words ;
+IN: deprecation
+
+SYMBOL: +deprecation-note+
+SYMBOL: deprecation-notes
+
+deprecation-notes [ H{ } clone ] initialize
+
+TUPLE: deprecation-note < source-file-error ;
+
+M: deprecation-note error-type drop +deprecation-note+ ;
+
+TUPLE: deprecated-usages asset usages ;
+
+: :deprecations ( -- )
+ deprecation-notes get-global values errors. ;
+
+T{ error-type
+ { type +deprecation-note+ }
+ { word ":deprecations" }
+ { plural "deprecated word usages" }
+ { icon "vocab:ui/tools/error-list/icons/deprecation-note.tiff" }
+ { quot [ deprecation-notes get values ] }
+ { forget-quot [ deprecation-notes get delete-at ] }
+} define-error-type
+
+: <deprecation-note> ( error word -- deprecation-note )
+ \ deprecation-note <definition-error> ;
+
+: deprecation-note ( word usages -- )
+ [ deprecated-usages boa ]
+ [ drop <deprecation-note> ]
+ [ drop deprecation-notes get-global set-at ] 2tri ;
+
+: clear-deprecation-note ( word -- )
+ deprecation-notes get-global delete-at ;
+
+: check-deprecations ( word -- )
+ dup "forgotten" word-prop
+ [ clear-deprecation-note ] [
+ dup def>> [ deprecated? ] filter
+ [ clear-deprecation-note ] [ >array deprecation-note ] if-empty
+ ] if ;
+
+M: deprecated-usages summary
+ drop "Deprecated words used" ;
+
+M: deprecated-usages error.
+ "The definition of " write
+ dup asset>> pprint
+ " uses these deprecated words:" write nl
+ usages>> [ " " write pprint nl ] each ;
+
+SINGLETON: deprecation-observer
+
+: initialize-deprecation-notes ( -- )
+ get-crossref [ drop deprecated? ] assoc-filter
+ values [ keys [ check-deprecations ] each ] each ;
+
+M: deprecation-observer definitions-changed
+ drop keys [ word? ] filter
+ dup [ deprecated? ] filter empty?
+ [ [ check-deprecations ] each ]
+ [ drop initialize-deprecation-notes ] if ;
+
+\ deprecation-observer add-definition-observer
+
+initialize-deprecation-notes
{ $description "Tests if an object is a delimiter word declared by " { $link POSTPONE: delimiter } "." }
{ $notes "Outputs " { $link f } " if the object is not a word." } ;
+HELP: deprecated?
+{ $values { "obj" object } { "?" "a boolean" } }
+{ $description "Tests if an object is " { $link POSTPONE: deprecated } "." }
+{ $notes "Outputs " { $link f } " if the object is not a word." } ;
+
+HELP: make-deprecated
+{ $values { "word" word } }
+{ $description "Declares a word as " { $link POSTPONE: deprecated } "." }
+{ $side-effects "word" } ;
+
HELP: make-flushable
{ $values { "word" word } }
{ $description "Declares a word as " { $link POSTPONE: flushable } "." }
: define-declared ( word def effect -- )
[ nip swap set-stack-effect ] [ drop define ] 3bi ;
+: make-deprecated ( word -- )
+ t "deprecated" set-word-prop ;
+
: make-inline ( word -- )
dup inline? [ drop ] [
[ t "inline" set-word-prop ]
{
"unannotated-def" "parsing" "inline" "recursive"
"foldable" "flushable" "reading" "writing" "reader"
- "writer" "delimiter"
+ "writer" "delimiter" "deprecated"
} reset-props ;
: reset-generic ( word -- )
: delimiter? ( obj -- ? )
dup word? [ "delimiter" word-prop ] [ drop f ] if ;
+: deprecated? ( obj -- ? )
+ dup word? [ "deprecated" word-prop ] [ drop f ] if ;
+
! Definition protocol
M: word where "loc" word-prop ;
M: word literalize <wrapper> ;
-INSTANCE: word definition
\ No newline at end of file
+INSTANCE: word definition