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#>> ] sort-with ] { } 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 forget-quot { fatal? initial: t } ;
  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 SYMBOL: error-types
  27
  28 error-types [ V{ } clone ] initialize
  29
  30 : define-error-type ( error-type -- )
  31     dup type>> error-types get set-at ;
  32
  33 : error-icon-path ( type -- icon )
  34     error-types get at icon>> ;
  35
  36 : error-counts ( -- alist )
  37     error-types get
  38     [ nip dup quot>> call( -- seq ) length ] assoc-map
  39     [ [ fatal?>> ] [ 0 > ] bi* and ] assoc-filter ;
  40
  41 : error-summary ( -- )
  42     error-counts [
  43         over
  44         [ word>> write ]
  45         [ " - show " write number>string write bl ]
  46         [ plural>> print ] tri*
  47     ] assoc-each ;
  48
  49 : all-errors ( -- errors )
  50     error-types get values
  51     [ quot>> call( -- seq ) ] map
  52     concat ;
  53
  54 GENERIC: errors-changed ( observer -- )
  55
  56 SYMBOL: error-observers
  57
  58 [ V{ } clone error-observers set-global ] "source-files.errors" add-init-hook
  59
  60 : add-error-observer ( observer -- ) error-observers get push ;
  61
  62 : remove-error-observer ( observer -- ) error-observers get delq ;
  63
  64 : notify-error-observers ( -- ) error-observers get [ errors-changed ] each ;
  65
  66 : delete-file-errors ( seq file type -- )
  67     [
  68         [ swap file>> = ] [ swap error-type = ]
  69         bi-curry* bi and not
  70     ] 2curry filter-here
  71     notify-error-observers ;
  72
  73 : delete-definition-errors ( definition -- )
  74     error-types get [
  75         second forget-quot>> dup
  76         [ call( definition -- ) ] [ 2drop ] if
  77     ] with each ;