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
7 GENERIC: error-file ( error -- file )
8 GENERIC: error-line ( error -- line )
10 M: object error-file drop f ;
11 M: object error-line drop f ;
13 M: condition error-file error>> error-file ;
14 M: condition error-line error>> error-line ;
16 TUPLE: source-file-error error asset file line# ;
18 M: source-file-error error-file [ error>> error-file ] [ file>> ] bi or ;
19 M: source-file-error error-line [ error>> error-line ] [ line#>> ] bi or ;
20 M: source-file-error compute-restarts error>> compute-restarts ;
22 : sort-errors ( errors -- alist )
23 [ [ line#>> 0 or ] sort-with ] { } assoc-map-as sort-keys ;
25 : group-by-source-file ( errors -- assoc )
26 H{ } clone [ [ push-at ] curry [ dup file>> ] prepose each ] keep ;
28 TUPLE: error-type-holder type word plural icon quot forget-quot { fatal? initial: t } ;
30 GENERIC: error-type ( error -- type )
32 : <definition-error> ( error definition class -- source-file-error )
36 [ where [ first2 [ >>file ] [ >>line# ] bi* ] when* ] bi
41 error-types [ V{ } clone ] initialize
43 : define-error-type ( error-type -- )
44 dup type>> error-types get set-at ;
46 : error-icon-path ( type -- icon )
47 error-types get at icon>> ;
49 : error-counts ( -- alist )
51 [ nip dup quot>> call( -- seq ) length ] assoc-map
52 [ [ fatal?>> ] [ 0 > ] bi* and ] assoc-filter ;
54 : error-summary ( -- )
58 [ " - show " write number>string write bl ]
59 [ plural>> print ] tri*
62 : all-errors ( -- errors )
63 error-types get values
64 [ quot>> call( -- seq ) ] map
67 GENERIC: errors-changed ( observer -- )
69 SYMBOL: error-observers
72 V{ } clone error-observers set-global
73 ] "source-files.errors" add-startup-hook
75 : add-error-observer ( observer -- )
76 error-observers get push ;
78 : remove-error-observer ( observer -- )
79 error-observers get remove-eq! drop ;
81 : notify-error-observers ( -- )
82 error-observers get [ errors-changed ] each ;
84 : delete-file-errors ( seq file type -- )
86 [ swap file>> = ] [ swap error-type = ]
89 notify-error-observers ;
91 : delete-definition-errors ( definition -- )
93 second forget-quot>> dup
94 [ call( definition -- ) ] [ 2drop ] if