/core/source-files/errors/errors.factor

http://github.com/abeaumont/factor · Factor · 90 lines · 63 code · 25 blank · 2 comment · 11 complexity · 9718e4dcbe42c1926826a03e2997bca4 MD5 · raw file

  1. ! Copyright (C) 2009 Slava Pestov.
  2. ! See http://factorcode.org/license.txt for BSD license.
  3. USING: accessors assocs continuations definitions init io
  4. kernel math math.parser namespaces sequences sorting ;
  5. IN: source-files.errors
  6. GENERIC: error-file ( error -- file )
  7. GENERIC: error-line ( error -- line )
  8. M: object error-file drop f ;
  9. M: object error-line drop f ;
  10. M: condition error-file error>> error-file ;
  11. M: condition error-line error>> error-line ;
  12. TUPLE: source-file-error error asset file line# ;
  13. M: source-file-error error-file [ error>> error-file ] [ file>> ] bi or ;
  14. M: source-file-error error-line [ error>> error-line ] [ line#>> ] bi or ;
  15. M: source-file-error compute-restarts error>> compute-restarts ;
  16. : sort-errors ( errors -- alist )
  17. [ [ line#>> 0 or ] sort-with ] { } assoc-map-as sort-keys ;
  18. : group-by-source-file ( errors -- assoc )
  19. H{ } clone [ [ push-at ] curry [ dup file>> ] prepose each ] keep ;
  20. TUPLE: error-type type word plural icon quot forget-quot { fatal? initial: t } ;
  21. GENERIC: error-type ( error -- type )
  22. : <definition-error> ( error definition class -- source-file-error )
  23. new
  24. swap
  25. [ >>asset ]
  26. [ where [ first2 [ >>file ] [ >>line# ] bi* ] when* ] bi
  27. swap >>error ; inline
  28. SYMBOL: error-types
  29. error-types [ V{ } clone ] initialize
  30. : define-error-type ( error-type -- )
  31. dup type>> error-types get set-at ;
  32. : error-icon-path ( type -- icon )
  33. error-types get at icon>> ;
  34. : error-counts ( -- alist )
  35. error-types get
  36. [ nip dup quot>> call( -- seq ) length ] assoc-map
  37. [ [ fatal?>> ] [ 0 > ] bi* and ] assoc-filter ;
  38. : error-summary ( -- )
  39. error-counts [
  40. over
  41. [ word>> write ]
  42. [ " - show " write number>string write bl ]
  43. [ plural>> print ] tri*
  44. ] assoc-each ;
  45. : all-errors ( -- errors )
  46. error-types get values
  47. [ quot>> call( -- seq ) ] map
  48. concat ;
  49. GENERIC: errors-changed ( observer -- )
  50. SYMBOL: error-observers
  51. [ V{ } clone error-observers set-global ] "source-files.errors" add-startup-hook
  52. : add-error-observer ( observer -- ) error-observers get push ;
  53. : remove-error-observer ( observer -- ) error-observers get remove-eq! drop ;
  54. : notify-error-observers ( -- ) error-observers get [ errors-changed ] each ;
  55. : delete-file-errors ( seq file type -- )
  56. [
  57. [ swap file>> = ] [ swap error-type = ]
  58. bi-curry* bi and not
  59. ] 2curry filter! drop
  60. notify-error-observers ;
  61. : delete-definition-errors ( definition -- )
  62. error-types get [
  63. second forget-quot>> dup
  64. [ call( definition -- ) ] [ 2drop ] if
  65. ] with each ;