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 ;
   5 IN: source-files.errors
   6
   7 TUPLE: source-file-error error asset file line# ;
   8
   9 : sort-errors ( errors -- alist )
  10     [ [ [ line#>> ] compare ] sort ] { } assoc-map-as sort-keys ;
  11
  12 : group-by-source-file ( errors -- assoc )
  13     H{ } clone [ [ push-at ] curry [ dup file>> ] prepose each ] keep ;
  14
  15 TUPLE: error-type type word plural icon quot ;
  16
  17 GENERIC: error-type ( error -- type )
  18
  19 : <definition-error> ( error definition class -- source-file-error )
  20     new
  21         swap
  22         [ >>asset ]
  23         [ where [ first2 [ >>file ] [ >>line# ] bi* ] when* ] bi
  24         swap >>error ; inline
  25
  26 : delete-file-errors ( seq file type -- )
  27     [
  28         [ swap file>> = ] [ swap error-type = ]
  29         bi-curry* bi and not
  30     ] 2curry filter-here ;
  31
  32 SYMBOL: error-types
  33
  34 error-types [ V{ } clone ] initialize
  35
  36 : define-error-type ( error-type -- )
  37     dup type>> error-types get set-at ;
  38
  39 : error-icon-path ( type -- icon )
  40     error-types get at icon>> ;
  41
  42 : error-counts ( -- alist )
  43     error-types get [ nip dup quot>> call( -- seq ) length ] assoc-map ;
  44
  45 : error-summary ( -- )
  46     error-counts
  47     [ nip 0 > ] assoc-filter
  48     [
  49         over
  50         [ word>> write ]
  51         [ " - show " write number>string write bl ]
  52         [ plural>> print ] tri*
  53     ] assoc-each ;
  54
  55 : all-errors ( -- errors )
  56     error-types get values
  57     [ quot>> call( -- seq ) ] map
  58     concat ;
  59
  60 GENERIC: errors-changed ( observer -- )
  61
  62 SYMBOL: error-observers
  63
  64 [ V{ } clone error-observers set-global ] "source-files.errors" add-init-hook
  65
  66 : add-error-observer ( observer -- ) error-observers get push ;
  67
  68 : remove-error-observer ( observer -- ) error-observers get delq ;
  69
  70 : notify-error-observers ( -- ) error-observers get [ errors-changed ] each ;