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 ;
   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 GENERIC: source-file-error-type ( error -- type )
  16
  17 : <definition-error> ( error definition class -- source-file-error )
  18     new
  19         swap
  20         [ >>asset ]
  21         [
  22             where [ first2 ] [ "<unknown file>" 0 ] if*
  23             [ >>file ] [ >>line# ] bi*
  24         ] bi
  25         swap >>error ; inline
  26
  27 : delete-file-errors ( seq file type -- )
  28     [
  29         [ swap file>> = ] [ swap source-file-error-type = ]
  30         bi-curry* bi and not
  31     ] 2curry filter-here ;
  32
  33 SYMBOL: source-file-error-types
  34
  35 source-file-error-types [ V{ } clone ] initialize
  36
  37 : error-types ( -- seq ) source-file-error-types get keys ;
  38
  39 : define-error-type ( type icon quot -- )
  40     2array swap source-file-error-types get set-at ;
  41
  42 : error-icon-path ( type -- icon )
  43     source-file-error-types get at first ;
  44
  45 : error-summary ( -- )
  46     source-file-error-types get [
  47         [ name>> "+" ?head drop "+" ?tail drop ]
  48         [ second call length ] bi*
  49     ] assoc-map
  50     [ nip 0 > ] assoc-filter
  51     [
  52         over
  53         [ ":" write write ]
  54         [ " - print " write number>string write bl ]
  55         [ { { CHAR: - CHAR: \s } } substitute write "s" print ] tri*
  56     ] assoc-each ;
  57
  58 : all-errors ( -- errors )
  59     source-file-error-types get
  60     [ second second call( -- seq ) ] map
  61     concat ;