Refactor error code so that error types are registered; listener prints a summary of errors

basis/bootstrap/stage2.factor

@@ -81,13 +81,11 @@ SYMBOL: bootstrap-time
         "none" require
     ] if
 
-    [
+    load-components
-        load-components
 
-        millis over - core-bootstrap-time set-global
+    millis over - core-bootstrap-time set-global
 
-        run-bootstrap-init
+    run-bootstrap-init
-    ] with-compiler-errors
 
     f error set-global
     f error-continuation set-global

basis/compiler/codegen/codegen.factor

@@ -380,7 +380,7 @@ TUPLE: no-such-library name ;
 M: no-such-library summary
     drop "Library not found" ;
 
-M: no-such-library source-file-error-type drop +linkage-error+ ;
+M: no-such-library error-type drop +linkage-error+ ;
 
 : no-such-library ( name -- )
     \ no-such-library boa
@@ -391,7 +391,7 @@ TUPLE: no-such-symbol name ;
 M: no-such-symbol summary
     drop "Symbol not found" ;
 
-M: no-such-symbol source-file-error-type drop +linkage-error+ ;
+M: no-such-symbol error-type drop +linkage-error+ ;
 
 : no-such-symbol ( name -- )
     \ no-such-symbol boa

basis/compiler/compiler.factor

@@ -53,11 +53,18 @@ SYMBOLS: +optimized+ +unoptimized+ ;
     f swap compiler-error ;
 
 : ignore-error? ( word error -- ? )
-    [ [ inline? ] [ macro? ] bi or ]
+    [
-    [ source-file-error-type +compiler-warning+ eq? ] bi* and ;
+        {
+            [ inline? ]
+            [ macro? ]
+            [ "transform-quot" word-prop ]
+            [ "no-compile" word-prop ]
+            [ "special" word-prop ]
+        } 1||
+    ] [ error-type +compiler-warning+ eq? ] bi* and ;
 
 : fail ( word error -- * )
-    [ 2dup ignore-error? [ 2drop ] [ swap compiler-error ] if ]
+    [ 2dup ignore-error? [ drop f ] when swap compiler-error ]
     [
         drop
         [ compiled-unxref ]
@@ -122,6 +129,8 @@ t compile-dependencies? set-global
 : compile-call ( quot -- )
     [ dup infer define-temp ] with-compilation-unit execute ;
 
+\ compile-call t "no-compile" set-word-prop
+
 SINGLETON: optimizing-compiler
 
 M: optimizing-compiler recompile ( words -- alist )

basis/help/lint/checks/checks.factor

@@ -124,11 +124,11 @@ SYMBOL: vocab-articles
 : check-class-description ( word element -- )
     [ class? not ]
     [ { $class-description } swap elements empty? not ] bi* and
-    [ "A word that is not a class has a $class-description" throw ] when ;
+    [ "A word that is not a class has a $class-description" simple-lint-error ] when ;
 
 : check-article-title ( article -- )
     article-title first LETTER?
-    [ "Article title must begin with a capital letter" throw ] unless ;
+    [ "Article title must begin with a capital letter" simple-lint-error ] unless ;
 
 : check-elements ( element -- )
     {

basis/help/lint/lint.factor

@@ -3,7 +3,7 @@
 USING: assocs continuations fry help help.lint.checks
 help.topics io kernel namespaces parser sequences
 source-files.errors tools.vocabs vocabs words classes
-locals ;
+locals tools.errors ;
 FROM: help.lint.checks => all-vocabs ;
 IN: help.lint
 
@@ -15,11 +15,15 @@ TUPLE: help-lint-error < source-file-error ;
 
 SYMBOL: +help-lint-failure+
 
-+help-lint-failure+
+T{ error-type
-"vocab:ui/tools/error-list/icons/help-lint-error.tiff"
+   { type +help-lint-failure+ }
-[ lint-failures get values ] define-error-type
+   { word ":lint-failures" }
+   { plural "help lint failures" }
+   { icon "vocab:ui/tools/error-list/icons/help-lint-error.tiff" }
+   { quot [ lint-failures get values ] }
+} define-error-type
 
-M: help-lint-error source-file-error-type drop +help-lint-failure+ ;
+M: help-lint-error error-type drop +help-lint-failure+ ;
 
 <PRIVATE
 
@@ -66,8 +70,7 @@ PRIVATE>
 
 : check-vocab ( vocab -- )
     "Checking " write dup write "..." print
-    vocab
+    [ vocab check-about ]
-    [ check-about ]
     [ words [ check-word ] each ]
     [ vocab-articles get at [ check-article ] each ]
     tri ;
@@ -84,6 +87,8 @@ PRIVATE>
 
 : help-lint-all ( -- ) "" help-lint ;
 
+: :lint-failures ( -- ) lint-failures get errors. ;
+
 : unlinked-words ( words -- seq )
     all-word-help [ article-parent not ] filter ;
 

basis/listener/listener.factor

@@ -4,7 +4,7 @@ USING: arrays hashtables io kernel math math.parser memory
 namespaces parser lexer sequences strings io.styles
 vectors words generic system combinators continuations debugger
 definitions compiler.units accessors colors prettyprint fry
-sets vocabs.parser ;
+sets vocabs.parser source-files.errors ;
 IN: listener
 
 GENERIC: stream-read-quot ( stream -- quot/f )
@@ -68,6 +68,8 @@ SYMBOL: max-stack-items
 
 10 max-stack-items set-global
 
+SYMBOL: error-summary-hook
+
 <PRIVATE
 
 : title. ( string -- )
@@ -105,8 +107,10 @@ SYMBOL: max-stack-items
     "( " in get auto-use? get [ " - auto" append ] when " )" 3append
     H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ;
 
+[ error-summary ] error-summary-hook set-global
+
 : listen ( -- )
-    visible-vars. stacks. prompt.
+    error-summary-hook get call( -- ) visible-vars. stacks. prompt.
     [ read-quot [ [ call-error-hook ] recover ] [ bye ] if* ]
     [ dup lexer-error? [ call-error-hook ] [ rethrow ] if ] recover ;
 

basis/memoize/memoize.factor

@@ -61,3 +61,5 @@ M: memoized reset-word
 
 : invalidate-memoized ( inputs... word -- )
     [ stack-effect in>> packer call ] [ "memoize" word-prop delete-at ] bi ;
+
+\ invalidate-memoized t "no-compile" set-word-prop

basis/stack-checker/errors/errors.factor

@@ -11,7 +11,7 @@ IN: stack-checker.errors
 
 TUPLE: inference-error error type word ;
 
-M: inference-error source-file-error-type type>> ;
+M: inference-error error-type type>> ;
 
 : (inference-error) ( ... class type -- * )
     [ boa ] dip

basis/stack-checker/known-words/known-words.factor

@@ -218,9 +218,6 @@ M: object infer-call*
     alien-callback
 } [ t "special" set-word-prop ] each
 
-{ call execute dispatch load-locals get-local drop-locals }
-[ t "no-compile" set-word-prop ] each
-
 : non-inline-word ( word -- )
     dup called-dependency depends-on
     {

basis/tools/errors/errors-docs.factor

@@ -15,18 +15,11 @@ $nl
 "Words to view warnings and errors:"
 { $subsection :errors }
 { $subsection :warnings }
-{ $subsection :linkage }
+{ $subsection :linkage } ;
-"Words such as " { $link require } " use a combinator which counts errors and prints a report at the end:"
-{ $subsection with-compiler-errors } ;
 
 HELP: compiler-error
 { $values { "error" "an error" } { "word" word } }
-{ $description "If inside a " { $link with-compiler-errors } ", saves the error for future persual via " { $link :errors } ", " { $link :warnings } " and " { $link :linkage } ". If not inside a " { $link with-compiler-errors } ", ignores the error." } ;
+{ $description "Saves the error for future persual via " { $link :errors } ", " { $link :warnings } " and " { $link :linkage } "." } ;
-
-HELP: with-compiler-errors
-{ $values { "quot" quotation } }
-{ $description "Calls the quotation and collects any compiler warnings and errors. Compiler warnings and errors are summarized at the end and can be viewed with " { $link :errors } ", " { $link :warnings } ", and " { $link :linkage } "." }
-{ $notes "Nested calls to " { $link with-compiler-errors } " are ignored, and only the outermost call collects warnings and errors." } ;
 
 HELP: :errors
 { $description "Prints all serious compiler errors from the most recent compile to " { $link output-stream } "." } ;

basis/tools/test/test.factor

@@ -13,13 +13,19 @@ TUPLE: test-failure < source-file-error continuation ;
 
 SYMBOL: +test-failure+
 
-M: test-failure source-file-error-type drop +test-failure+ ;
+M: test-failure error-type drop +test-failure+ ;
 
 SYMBOL: test-failures
 
 test-failures [ V{ } clone ] initialize
 
-+test-failure+ "vocab:ui/tools/error-list/icons/unit-test-error.tiff" [ test-failures get ] define-error-type
+T{ error-type
+   { type +test-failure+ }
+   { word ":test-failures" }
+   { plural "unit test failures" }
+   { icon "vocab:ui/tools/error-list/icons/unit-test-error.tiff" }
+   { quot [ test-failures get ] }
+} define-error-type
 
 <PRIVATE
 
@@ -130,12 +136,9 @@ M: test-failure error. ( error -- )
     [ traceback-button. ]
     bi ;
 
-: :failures ( -- ) test-failures get errors. ;
+: :test-failures ( -- ) test-failures get errors. ;
 
 : test ( prefix -- )
-    [ child-vocabs [ run-vocab-tests ] each ] with-compiler-errors
+    child-vocabs [ run-vocab-tests ] each ;
-    test-failures get [
-        ":failures - show " write length pprint " failing tests." print
-    ] unless-empty ;
 
 : test-all ( -- ) "" test ;

basis/tools/vocabs/vocabs.factor

@@ -78,7 +78,7 @@ SYMBOL: failures
             recover
         ] each
         failures get
-    ] with-compiler-errors ;
+    ] with-scope ;
 
 : source-modified? ( path -- ? )
     dup source-files get at [

basis/ui/tools/error-list/error-list.factor

@@ -26,7 +26,7 @@ MEMO: error-icon ( type -- image-name )
 
 : <error-toggle> ( -- model gadget )
     #! Linkage errors are not shown by default.
-    error-types [ dup +linkage-error+ eq? not <model> ] { } map>assoc
+    error-types get keys [ dup +linkage-error+ eq? not <model> ] { } map>assoc
     [ [ [ error-icon ] dip ] assoc-map <checkboxes> ]
     [ <mapping> ] bi ;
 
@@ -75,7 +75,7 @@ SINGLETON: error-renderer
 M: error-renderer row-columns
     drop [
         {
-            [ source-file-error-type error-icon ]
+            [ error-type error-icon ]
             [ line#>> number>string ]
             [ asset>> unparse-short ]
             [ error>> summary ]
@@ -142,7 +142,7 @@ error-display "toolbar" f {
     [ <toolbar> ] [ error-toggle>> "Show errors:" label-on-left add-gadget ] bi ;
 
 : <error-model> ( visible-errors model -- model' )
-    [ swap '[ source-file-error-type _ at ] filter ] <smart-arrow> ;
+    [ swap '[ error-type _ at ] filter ] <smart-arrow> ;
 
 :: <error-list-gadget> ( model -- gadget )
     vertical error-list-gadget new-track
@@ -193,3 +193,9 @@ M: updater definitions-changed
 : error-list-window ( -- )
     compiler-error-model get-global <error-list-gadget>
     "Errors" open-status-window ;
+
+: show-error-list ( -- )
+    [ error-list-gadget? ] find-window
+    [ raise-window ] [ error-list-window ] if* ;
+
+\ show-error-list H{ { +nullary+ t } } define-command

basis/ui/tools/listener/listener.factor

@@ -1,10 +1,10 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs calendar combinators locals
-colors.constants combinators.short-circuit compiler.units
+source-files.errors colors.constants combinators.short-circuit
-help.tips concurrency.flags concurrency.mailboxes continuations
+compiler.units help.tips concurrency.flags concurrency.mailboxes
-destructors documents documents.elements fry hashtables help
+continuations destructors documents documents.elements fry hashtables
-help.markup io io.styles kernel lexer listener math models
+help help.markup io io.styles kernel lexer listener math models
 models.delay models.arrow namespaces parser prettyprint quotations
 sequences strings threads tools.vocabs vocabs vocabs.loader
 vocabs.parser words debugger ui ui.commands ui.pens.solid ui.gadgets
@@ -13,7 +13,7 @@ ui.gadgets.labeled ui.gadgets.panes ui.gadgets.scrollers
 ui.gadgets.status-bar ui.gadgets.tracks ui.gadgets.borders ui.gestures
 ui.operations ui.tools.browser ui.tools.common ui.tools.debugger
 ui.tools.listener.completion ui.tools.listener.popups
-ui.tools.listener.history ;
+ui.tools.listener.history ui.tools.error-list ;
 IN: ui.tools.listener
 
 ! If waiting is t, we're waiting for user input, and invoking
@@ -356,10 +356,17 @@ interactor "completion" f {
     { T{ key-down f { C+ } "r" } history-completion-popup }
 } define-command-map
 
+: ui-error-summary ( -- )
+    all-errors empty? [
+        { "Press " { $command tool "common" show-error-list } " to view errors." }
+        print-element nl
+    ] unless ;
+
 : listener-thread ( listener -- )
     dup listener-streams [
         [ com-browse ] help-hook set
         '[ [ _ input>> ] 2dip debugger-popup ] error-hook set
+        [ ui-error-summary ] error-summary-hook set
         tip-of-the-day. nl
         listener
     ] with-streams* ;

basis/ui/tools/tools.factor

@@ -30,4 +30,5 @@ tool "common" f {
     { T{ key-down f { A+ } "w" } close-window }
     { T{ key-down f { A+ } "q" } com-exit }
     { T{ key-down f f "F2" } refresh-all }
+    { T{ key-down f f "F3" } show-error-list }
 } define-command-map

core/compiler/errors/errors-docs.factor

@@ -2,7 +2,4 @@ IN: compiler.errors
 USING: help.markup help.syntax vocabs.loader words io
 quotations words.symbol ;
 
-HELP: compiler-errors
-{ $var-description "Global variable holding an assoc mapping words to compiler errors. This variable is set by " { $link with-compiler-errors } "." } ;
-
 ABOUT: "compiler-errors"

core/compiler/errors/errors.factor

@@ -1,13 +1,11 @@
 ! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces make assocs io sequences
+USING: accessors source-files.errors kernel namespaces assocs ;
-continuations math math.parser accessors definitions
-source-files.errors ;
 IN: compiler.errors
 
 TUPLE: compiler-error < source-file-error ;
 
-M: compiler-error source-file-error-type error>> source-file-error-type ;
+M: compiler-error error-type error>> error-type ;
 
 SYMBOL: compiler-errors
 
@@ -15,34 +13,34 @@ compiler-errors [ H{ } clone ] initialize
 
 SYMBOLS: +compiler-error+ +compiler-warning+ +linkage-error+ ;
 
-+compiler-error+ "vocab:ui/tools/error-list/icons/compiler-error.tiff" [ compiler-errors get values ] define-error-type
-+compiler-warning+ "vocab:ui/tools/error-list/icons/compiler-warning.tiff" [ f ] define-error-type
-+linkage-error+ "vocab:ui/tools/error-list/icons/linkage-error.tiff" [ f ] define-error-type
-
-SYMBOL: with-compiler-errors?
-
 : errors-of-type ( type -- assoc )
     compiler-errors get-global
-    swap [ [ nip source-file-error-type ] dip eq? ] curry
+    swap [ [ nip error-type ] dip eq? ] curry
     assoc-filter ;
 
-: (compiler-report) ( what type word -- )
+T{ error-type
-    over errors-of-type assoc-empty? [ 3drop ] [
+   { type +compiler-error+ }
-        [
+   { word ":errors" }
-            ":" %
+   { plural "compiler errors" }
-            %
+   { icon "vocab:ui/tools/error-list/icons/compiler-error.tiff" }
-            " - print " %
+   { quot [ +compiler-error+ errors-of-type values ] }
-            errors-of-type assoc-size #
+} define-error-type
-            " " %
-            %
-            "." %
-        ] "" make print
-    ] if ;
 
-: compiler-report ( -- )
+T{ error-type
-    "compiler errors" +compiler-error+ "errors" (compiler-report)
+   { type +compiler-warning+ }
-    "compiler warnings" +compiler-warning+ "warnings" (compiler-report)
+   { word ":warnings" }
-    "linkage errors" +linkage-error+ "linkage" (compiler-report) ;
+   { plural "compiler warnings" }
+   { icon "vocab:ui/tools/error-list/icons/compiler-warning.tiff" }
+   { quot [ +compiler-warning+ errors-of-type values ] }
+} define-error-type
+
+T{ error-type
+   { type +linkage-error+ }
+   { word ":linkage" }
+   { plural "linkage errors" }
+   { icon "vocab:ui/tools/error-list/icons/linkage-error.tiff" }
+   { quot [ +linkage-error+ errors-of-type values ] }
+} define-error-type
 
 : <compiler-error> ( error word -- compiler-error )
     \ compiler-error <definition-error> ;
@@ -50,11 +48,3 @@ SYMBOL: with-compiler-errors?
 : compiler-error ( error word -- )
     compiler-errors get-global pick
     [ [ [ <compiler-error> ] keep ] dip set-at ] [ delete-at drop ] if ;
-
-: with-compiler-errors ( quot -- )
-    with-compiler-errors? get "quiet" get or [ call ] [
-        [
-            with-compiler-errors? on
-            [ compiler-report ] [ ] cleanup
-        ] with-scope
-    ] if ; inline

core/parser/parser.factor

@@ -281,11 +281,9 @@ print-use-hook [ [ ] ] initialize
 
 : parse-file ( file -- quot )
     [
-        [
+        [ parsing-file ] keep
-            [ parsing-file ] keep
+        [ utf8 <file-reader> ] keep
-            [ utf8 <file-reader> ] keep
+        parse-stream
-            parse-stream
-        ] with-compiler-errors
     ] [
         over parse-file-restarts rethrow-restarts
         drop parse-file

core/source-files/errors/errors.factor

@@ -12,7 +12,9 @@ TUPLE: source-file-error error asset file line# ;
 : group-by-source-file ( errors -- assoc )
     H{ } clone [ [ push-at ] curry [ dup file>> ] prepose each ] keep ;
 
-GENERIC: source-file-error-type ( error -- type )
+TUPLE: error-type type word plural icon quot ;
+
+GENERIC: error-type ( error -- type )
 
 : <definition-error> ( error definition class -- source-file-error )
     new
@@ -26,36 +28,31 @@ GENERIC: source-file-error-type ( error -- type )
 
 : delete-file-errors ( seq file type -- )
     [
-        [ swap file>> = ] [ swap source-file-error-type = ]
+        [ swap file>> = ] [ swap error-type = ]
         bi-curry* bi and not
     ] 2curry filter-here ;
 
-SYMBOL: source-file-error-types
+SYMBOL: error-types
 
-source-file-error-types [ V{ } clone ] initialize
+error-types [ V{ } clone ] initialize
 
-: error-types ( -- seq ) source-file-error-types get keys ;
+: define-error-type ( error-type -- )
-
+    dup type>> error-types get set-at ;
-: define-error-type ( type icon quot -- )
-    2array swap source-file-error-types get set-at ;
 
 : error-icon-path ( type -- icon )
-    source-file-error-types get at first ;
+    error-types get at icon>> ;
 
 : error-summary ( -- )
-    source-file-error-types get [
+    error-types get [ nip dup quot>> call( -- seq ) length ] assoc-map
-        [ name>> "+" ?head drop "+" ?tail drop ]
-        [ second call length ] bi*
-    ] assoc-map
     [ nip 0 > ] assoc-filter
     [
         over
-        [ ":" write write ]
+        [ word>> write ]
-        [ " - print " write number>string write bl ]
+        [ " - show " write number>string write bl ]
-        [ { { CHAR: - CHAR: \s } } substitute write "s" print ] tri*
+        [ plural>> print ] tri*
     ] assoc-each ;
 
 : all-errors ( -- errors )
-    source-file-error-types get
+    error-types get values
-    [ second second call( -- seq ) ] map
+    [ quot>> call( -- seq ) ] map
     concat ;

core/vocabs/loader/loader.factor

@@ -80,11 +80,11 @@ SYMBOL: load-help?
 PRIVATE>
 
 : require ( vocab -- )
-    [ load-vocab drop ] with-compiler-errors ;
+    load-vocab drop ;
 
 : reload ( name -- )
     dup vocab
-    [ [ [ load-source ] [ load-docs ] bi ] with-compiler-errors ]
+    [ [ load-source ] [ load-docs ] bi ]
     [ require ]
     ?if ;
 
@@ -125,9 +125,7 @@ PRIVATE>
 [
     dup vocab-name blacklist get at* [ rethrow ] [
         drop dup find-vocab-root
-        [ [ (load-vocab) ] with-compiler-errors ]
+        [ (load-vocab) ] [ dup vocab [ ] [ no-vocab ] ?if ] if
-        [ dup vocab [ ] [ no-vocab ] ?if ]
-        if
     ] if
 ] load-vocab-hook set-global