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

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