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 kernel math.order sorting sequences definitions
   4 namespaces arrays splitting io math.parser math init continuations ;
   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 file line# ;
  17
  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
  21 : sort-errors ( errors -- alist )
  22     [ [ line#>> ] sort-with ] { } assoc-map-as sort-keys ;
  23
  24 : group-by-source-file ( errors -- assoc )
  25     H{ } clone [ [ push-at ] curry [ dup file>> ] prepose each ] keep ;
  26
  27 TUPLE: error-type type word plural icon quot forget-quot { fatal? initial: t } ;
  28
  29 GENERIC: error-type ( error -- type )
  30
  31 : <definition-error> ( error definition class -- source-file-error )
  32     new
  33         swap
  34         [ >>asset ]
  35         [ where [ first2 [ >>file ] [ >>line# ] bi* ] when* ] bi
  36         swap >>error ; inline
  37
  38 SYMBOL: error-types
  39
  40 error-types [ V{ } clone ] initialize
  41
  42 : define-error-type ( error-type -- )
  43     dup type>> error-types get set-at ;
  44
  45 : error-icon-path ( type -- icon )
  46     error-types get at icon>> ;
  47
  48 : error-counts ( -- alist )
  49     error-types get
  50     [ nip dup quot>> call( -- seq ) length ] assoc-map
  51     [ [ fatal?>> ] [ 0 > ] bi* and ] assoc-filter ;
  52
  53 : error-summary ( -- )
  54     error-counts [
  55         over
  56         [ word>> write ]
  57         [ " - show " write number>string write bl ]
  58         [ plural>> print ] tri*
  59     ] assoc-each ;
  60
  61 : all-errors ( -- errors )
  62     error-types get values
  63     [ quot>> call( -- seq ) ] map
  64     concat ;
  65
  66 GENERIC: errors-changed ( observer -- )
  67
  68 SYMBOL: error-observers
  69
  70 [ V{ } clone error-observers set-global ] "source-files.errors" add-init-hook
  71
  72 : add-error-observer ( observer -- ) error-observers get push ;
  73
  74 : remove-error-observer ( observer -- ) error-observers get delq ;
  75
  76 : notify-error-observers ( -- ) error-observers get [ errors-changed ] each ;
  77
  78 : delete-file-errors ( seq file type -- )
  79     [
  80         [ swap file>> = ] [ swap error-type = ]
  81         bi-curry* bi and not
  82     ] 2curry filter-here
  83     notify-error-observers ;
  84
  85 : delete-definition-errors ( definition -- )
  86     error-types get [
  87         second forget-quot>> dup
  88         [ call( definition -- ) ] [ 2drop ] if
  89     ] with each ;