core/source-files/errors/errors.factor

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs continuations definitions io
   4 kernel math math.parser namespaces sequences sorting ;
   5 IN: source-files.errors
   6
   7 GENERIC: error-file ( error -- file )
   8 GENERIC: error-line ( error -- line )
   9
  10 M: object error-file drop f ;
  11 M: object error-line drop f ;
  12
  13 M: condition error-file error>> error-file ;
  14 M: condition error-line error>> error-line ;
  15
  16 TUPLE: source-file-error error asset path line# ;
  17
  18 M: source-file-error error-file [ error>> error-file ] [ path>> ] 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 ;
  21
  22 : new-source-file-error ( error asset class -- source-file-error )
  23     new
  24         swap
  25         [ >>asset ]
  26         [ where [ first2 [ >>path ] [ >>line# ] bi* ] when* ] bi
  27         swap >>error ; inline
  28
  29 : sort-errors ( errors -- alist )
  30     [ [ line#>> 0 or ] sort-with ] { } assoc-map-as sort-keys ;
  31
  32 : group-by-source-file ( errors -- assoc )
  33     [ path>> ] collect-by ;
  34
  35 TUPLE: error-type-holder type word plural icon quot forget-quot { fatal? initial: t } ;
  36
  37 GENERIC: error-type ( error -- type )
  38
  39 SYMBOL: error-types
  40
  41 error-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
  67 GENERIC: errors-changed ( observer -- )
  68
  69 SYMBOL: error-observers
  70
  71 STARTUP-HOOK: [ V{ } clone error-observers set-global ]
  72
  73 : add-error-observer ( observer -- )
  74     error-observers get push ;
  75
  76 : remove-error-observer ( observer -- )
  77     error-observers get remove-eq! drop ;
  78
  79 : notify-error-observers ( -- )
  80     error-observers get [ errors-changed ] each ;
  81
  82 : delete-file-errors ( seq file type -- )
  83     [
  84         [ swap path>> = ] [ swap error-type = ]
  85         bi-curry* bi and not
  86     ] 2curry filter! drop
  87     notify-error-observers ;
  88
  89 : delete-definition-errors ( definition -- )
  90     error-types get [
  91         second forget-quot>> dup
  92         [ call( definition -- ) ] [ 2drop ] if
  93     ] with each ;