basis/tools/deprecation/deprecation.factor

   1 ! (c)2009 Joe Groff bsd license
   2 USING: accessors arrays assocs combinators.short-circuit
   3 compiler.units debugger init io sets
   4 io.streams.null kernel namespaces prettyprint sequences
   5 source-files.errors summary tools.crossref
   6 tools.crossref.private tools.errors words ;
   7 IN: tools.deprecation
   8
   9 SYMBOL: +deprecation-note+
  10 SYMBOL: deprecation-notes
  11
  12 deprecation-notes [ H{ } clone ] initialize
  13
  14 TUPLE: deprecation-note-error < source-file-error ;
  15
  16 M: deprecation-note-error error-type drop +deprecation-note+ ;
  17
  18 TUPLE: deprecated-usages asset usages ;
  19
  20 : :deprecations ( -- )
  21     deprecation-notes get-global values errors. ;
  22
  23 T{ error-type-holder
  24     { type +deprecation-note+ }
  25     { word ":deprecations" }
  26     { plural "deprecated word usages" }
  27     { icon "vocab:ui/tools/error-list/icons/deprecation-note.tiff" }
  28     { quot [ deprecation-notes get values ] }
  29     { forget-quot [ deprecation-notes get delete-at ] }
  30     { fatal? f }
  31 } define-error-type
  32
  33 : <deprecation-note-error> ( error word -- deprecation-note )
  34     \ deprecation-note-error <definition-error> ;
  35
  36 : deprecation-note ( word usages -- )
  37     [ deprecated-usages boa ]
  38     [ drop <deprecation-note-error> ]
  39     [ drop deprecation-notes get-global set-at ] 2tri ;
  40
  41 : clear-deprecation-note ( word -- )
  42     deprecation-notes get-global delete-at ;
  43
  44 : check-deprecations ( usage -- )
  45     dup word? [
  46         dup { [ "forgotten" word-prop ] [ deprecated? ] } 1||
  47         [ clear-deprecation-note ] [
  48             dup def>> uses [ deprecated? ] filter
  49             [ clear-deprecation-note ] [ >array deprecation-note ] if-empty
  50         ] if
  51     ] [ drop ] if ;
  52
  53 M: deprecated-usages summary
  54     drop "Deprecated words used" ;
  55
  56 M: deprecated-usages error.
  57     "The definition of " write
  58     dup asset>> pprint
  59     " uses these deprecated words:" write nl
  60     usages>> [ "    " write pprint nl ] each ;
  61
  62 SINGLETON: deprecation-observer
  63
  64 : initialize-deprecation-notes ( -- )
  65     [
  66         get-crossref [ drop deprecated? ] assoc-filter
  67         values [ keys [ check-deprecations ] each ] each
  68     ] with-null-writer ;
  69
  70 M: deprecation-observer definitions-changed
  71     drop members [ word? ] filter
  72     dup [ deprecated? ] any? not
  73     [ [ check-deprecations ] each ]
  74     [ drop initialize-deprecation-notes ] if ;
  75
  76 [ \ deprecation-observer add-definition-observer ]
  77 "tools.deprecation" add-startup-hook
  78
  79 initialize-deprecation-notes