Merge branch 'smarter_error_list' of git://factorcode.org/git/factor into smarter_error_list

basis/bootstrap/stage2.factor

@@ -88,7 +88,6 @@ SYMBOL: bootstrap-time
 
         run-bootstrap-init
     ] with-compiler-errors
-    :errors
 
     f error set-global
     f error-continuation set-global

basis/bootstrap/tools/tools.factor

@@ -6,6 +6,7 @@ IN: bootstrap.tools
     "bootstrap.image"
     "tools.annotations"
     "tools.crossref"
+    "tools.errors"
     "tools.deploy"
     "tools.disassembler"
     "tools.memory"

basis/compiler/codegen/codegen.factor

@@ -5,6 +5,7 @@ kernel kernel.private layouts assocs words summary arrays
 combinators classes.algebra alien alien.c-types alien.structs
 alien.strings alien.arrays alien.complex sets libc alien.libraries
 continuations.private fry cpu.architecture
+source-files.errors
 compiler.errors
 compiler.alien
 compiler.cfg
@@ -379,8 +380,7 @@ TUPLE: no-such-library name ;
 M: no-such-library summary
     drop "Library not found" ;
 
-M: no-such-library compiler-error-type
+M: no-such-library source-file-error-type drop +linkage-error+ ;
-    drop +linkage+ ;
 
 : no-such-library ( name -- )
     \ no-such-library boa
@@ -391,8 +391,7 @@ TUPLE: no-such-symbol name ;
 M: no-such-symbol summary
     drop "Symbol not found" ;
 
-M: no-such-symbol compiler-error-type
+M: no-such-symbol source-file-error-type drop +linkage-error+ ;
-    drop +linkage+ ;
 
 : no-such-symbol ( name -- )
     \ no-such-symbol boa

basis/compiler/compiler.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel namespaces arrays sequences io words fry
 continuations vocabs assocs dlists definitions math graphs generic
-combinators deques search-deques macros io stack-checker
+combinators deques search-deques macros io source-files.errors stack-checker
 stack-checker.state stack-checker.inlining combinators.short-circuit
 compiler.errors compiler.units compiler.tree.builder
 compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
@@ -54,7 +54,7 @@ SYMBOLS: +optimized+ +unoptimized+ ;
 
 : ignore-error? ( word error -- ? )
     [ [ inline? ] [ macro? ] bi or ]
-    [ compiler-error-type +warning+ eq? ] bi* and ;
+    [ source-file-error-type +compiler-warning+ eq? ] bi* and ;
 
 : fail ( word error -- * )
     [ 2dup ignore-error? [ 2drop ] [ swap compiler-error ] if ]

basis/compiler/tree/builder/builder.factor

@@ -42,8 +42,10 @@ IN: compiler.tree.builder
 : check-cannot-infer ( word -- )
     dup "cannot-infer" word-prop [ cannot-infer-effect ] [ drop ] if ;
 
+TUPLE: do-not-compile word ;
+
 : check-no-compile ( word -- )
-    dup "no-compile" word-prop [ cannot-infer-effect ] [ drop ] if ;
+    dup "no-compile" word-prop [ do-not-compile inference-warning ] [ drop ] if ;
 
 : build-tree-from-word ( word -- nodes )
     [

basis/debugger/debugger.factor

@@ -9,7 +9,8 @@ combinators generic.math classes.builtin classes compiler.units
 generic.standard vocabs init kernel.private io.encodings
 accessors math.order destructors source-files parser
 classes.tuple.parser effects.parser lexer compiler.errors
-generic.parser strings.parser vocabs.loader vocabs.parser ;
+generic.parser strings.parser vocabs.loader vocabs.parser see
+source-files.errors ;
 IN: debugger
 
 GENERIC: error. ( error -- )
@@ -268,11 +269,6 @@ M: duplicate-slot-names summary
 M: invalid-slot-name summary
     drop "Invalid slot name" ;
 
-: file. ( file -- ) path>> <pathname> . ;
-
-M: source-file-error error.
-    [ file>> file. ] [ error>> error. ] bi ;
-
 M: source-file-error summary
     error>> summary ;
 
@@ -309,11 +305,23 @@ M: lexer-error compute-restarts
 M: lexer-error error-help
     error>> error-help ;
 
-M: object compiler-error. ( error word -- )
+M: source-file-error error.
-    nl
+    [
-    "While compiling " write pprint ": " print
+        [
-    nl
+            [
-    print-error ;
+                [ file>> [ % ": " % ] when* ]
+                [ line#>> [ # ": " % ] when* ]
+                [ summary % ] tri
+            ] "" make
+        ] [
+            [
+                presented set
+                bold font-style set
+            ] H{ } make-assoc
+        ] bi format nl
+    ] [ error>> error. ] bi ;
+
+M: compiler-error summary asset>> summary ;
 
 M: bad-effect summary
     drop "Bad stack effect declaration" ;

basis/editors/editors-docs.factor

@@ -1,4 +1,5 @@
-USING: help.markup help.syntax parser source-files vocabs.loader ;
+USING: help.markup help.syntax parser source-files
+source-files.errors vocabs.loader ;
 IN: editors
 
 ARTICLE: "editor" "Editor integration"

basis/editors/editors.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: parser lexer kernel namespaces sequences definitions
+USING: parser lexer kernel namespaces sequences definitions io.files
-io.files io.backend io.pathnames io summary continuations
+io.backend io.pathnames io summary continuations tools.crossref
-tools.crossref tools.vocabs prettyprint source-files assocs
+tools.vocabs prettyprint source-files source-files.errors assocs
 vocabs vocabs.loader splitting accessors debugger prettyprint
 help.topics ;
 IN: editors
@@ -81,6 +81,9 @@ M: object error-line
 : :edit ( -- )
     error get (:edit) ;
 
+: edit-error ( error -- )
+    [ file>> ] [ line#>> ] bi edit-location ;
+
 : edit-each ( seq -- )
     [
         [ "Editing " write . ]

basis/mime/multipart/multipart.factor

@@ -137,9 +137,6 @@ ERROR: no-content-disposition multipart ;
         [ no-content-disposition ]
     } case ;
 
-: assert-sequence= ( a b -- )
-    2dup sequence= [ 2drop ] [ assert ] if ;
-
 : read-assert-sequence= ( sequence -- )
     [ length read ] keep assert-sequence= ;
 

basis/models/arrow/smart/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/models/arrow/smart/smart-tests.factor

@@ -0,0 +1,4 @@
+IN: models.arrows.smart.tests
+USING: models.arrow.smart tools.test accessors models math kernel ;
+
+[ 7 ] [ 3 <model> 4 <model> [ + ] <smart-arrow> [ activate-model ] [ value>> ] bi ] unit-test

basis/models/arrow/smart/smart.factor

@@ -0,0 +1,9 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: models.arrow models.product stack-checker accessors fry
+generalizations macros kernel ;
+IN: models.arrow.smart
+
+MACRO: <smart-arrow> ( quot -- quot' )
+    [ infer in>> dup ] keep
+    '[ _ narray <product> [ _ firstn @ ] <arrow> ] ;

basis/models/search/search.factor

@@ -1,12 +1,10 @@
 ! Copyright (C) 2008, 2009 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays fry kernel models.product models.arrow
+USING: fry kernel models.arrow.smart sequences unicode.case ;
-sequences unicode.case ;
 IN: models.search
 
 : <search> ( values search quot -- model )
-    [ 2array <product> ] dip
+    '[ _ curry filter ] <smart-arrow> ; inline
-    '[ first2 _ curry filter ] <arrow> ;
 
 : <string-search> ( values search quot -- model )
-    '[ swap @ [ >case-fold ] bi@ subseq? ] <search> ;
+    '[ swap @ [ >case-fold ] bi@ subseq? ] <search> ; inline

basis/models/sort/sort.factor

@@ -1,8 +1,7 @@
-! Copyright (C) 2008 Slava Pestov
+! Copyright (C) 2009 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays fry kernel models.product models.arrow
+USING: sorting models.arrow.smart fry ;
-sequences sorting ;
 IN: models.sort
 
 : <sort> ( values sort -- model )
-    2array <product> [ first2 sort ] <arrow> ;
+    [ '[ _ call( obj1 obj2 -- <=> ) ] sort ] <smart-arrow> ; inline

basis/stack-checker/errors/errors.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel generic sequences io words arrays summary effects
 continuations assocs accessors namespaces compiler.errors
-stack-checker.values stack-checker.recursive-state ;
+stack-checker.values stack-checker.recursive-state
+source-files.errors compiler.errors ;
 IN: stack-checker.errors
 
 : pretty-word ( word -- word' )
@@ -10,7 +11,7 @@ IN: stack-checker.errors
 
 TUPLE: inference-error error type word ;
 
-M: inference-error compiler-error-type type>> ;
+M: inference-error source-file-error-type type>> ;
 
 : (inference-error) ( ... class type -- * )
     [ boa ] dip
@@ -18,10 +19,10 @@ M: inference-error compiler-error-type type>> ;
     \ inference-error boa rethrow ; inline
 
 : inference-error ( ... class -- * )
-    +error+ (inference-error) ; inline
+    +compiler-error+ (inference-error) ; inline
 
 : inference-warning ( ... class -- * )
-    +warning+ (inference-error) ; inline
+    +compiler-warning+ (inference-error) ; inline
 
 TUPLE: literal-expected what ;
 
@@ -81,3 +82,8 @@ TUPLE: unknown-primitive-error ;
 
 : unknown-primitive-error ( -- * )
     \ unknown-primitive-error inference-warning ;
+
+TUPLE: transform-expansion-error word error ;
+
+: transform-expansion-error ( word error -- * )
+    \ transform-expansion-error inference-error ;

basis/stack-checker/errors/prettyprint/prettyprint.factor

@@ -1,19 +1,26 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel prettyprint io debugger
-sequences assocs stack-checker.errors summary effects ;
+sequences assocs stack-checker.errors summary effects make ;
 IN: stack-checker.errors.prettyprint
 
+M: inference-error summary error>> summary ;
+
 M: inference-error error-help error>> error-help ;
 
 M: inference-error error.
     [ word>> [ "In word: " write . ] when* ] [ error>> error. ] bi ;
 
-M: literal-expected error.
+M: literal-expected summary
-    "Got a computed value where a " write what>> write " was expected" print ;
+    [ "Got a computed value where a " % what>> % " was expected" % ] "" make ;
+
+M: literal-expected error. summary print ;
+
+M: unbalanced-branches-error summary
+    drop "Unbalanced branches" ;
 
 M: unbalanced-branches-error error.
-    "Unbalanced branches:" print
+    dup summary print
     [ quots>> ] [ branches>> [ length <effect> ] { } assoc>map ] bi zip
     [ [ first pprint-short bl ] [ second effect>string print ] bi ] each ;
 
@@ -25,16 +32,18 @@ M: too-many-r> summary
     drop
     "Quotation pops retain stack elements which it did not push" ;
 
-M: missing-effect error.
+M: missing-effect summary
-    "The word " write
+    [
-    word>> pprint
+        "The word " %
-    " must declare a stack effect" print ;
+        word>> name>> %
+        " must declare a stack effect" %
+    ] "" make ;
 
-M: effect-error error.
+M: effect-error summary
-    "Stack effects of the word " write
+    [
-    [ word>> pprint " do not match." print ]
+        "Stack effect declaration of the word " %
-    [ "Inferred: " write inferred>> . ]
+        word>> name>> % " is wrong" %
-    [ "Declared: " write declared>> . ] tri ;
+    ] "" make ;
 
 M: recursive-quotation-error error.
     "The quotation " write
@@ -42,26 +51,40 @@ M: recursive-quotation-error error.
     " calls itself." print
     "Stack effect inference is undecidable when quotation-level recursion is permitted." print ;
 
-M: undeclared-recursion-error error.
+M: undeclared-recursion-error summary
-    "The inline recursive word " write
-    word>> pprint
-    " must be declared recursive" print ;
-
-M: diverging-recursion-error error.
-    "The recursive word " write
-    word>> pprint
-    " digs arbitrarily deep into the stack" print ;
-
-M: unbalanced-recursion-error error.
-    "The recursive word " write
-    word>> pprint
-    " leaves with the stack having the wrong height" print ;
-
-M: inconsistent-recursive-call-error error.
-    "The recursive word " write
-    word>> pprint
-    " calls itself with a different set of quotation parameters than were input" print ;
-
-M: unknown-primitive-error error.
     drop
-    "Cannot determine stack effect statically" print ;
+    "Inline recursive words must be declared recursive" ;
+
+M: diverging-recursion-error summary
+    [
+        "The recursive word " %
+        word>> name>> %
+        " digs arbitrarily deep into the stack" %
+    ] "" make ;
+
+M: unbalanced-recursion-error summary
+    [
+        "The recursive word " %
+        word>> name>> %
+        " leaves with the stack having the wrong height" %
+    ] "" make ;
+
+M: inconsistent-recursive-call-error summary
+    [
+        "The recursive word " %
+        word>> name>> %
+        " calls itself with a different set of quotation parameters than were input" %
+    ] "" make ;
+
+M: unknown-primitive-error summary
+    drop
+    "Cannot determine stack effect statically" ;
+
+M: transform-expansion-error summary
+    drop
+    "Compiler transform threw an error" ;
+
+M: transform-expansion-error error.
+    [ summary print ]
+    [ "Word: " write word>> . nl ]
+    [ error>> error. ] tri ;

basis/stack-checker/transforms/transforms-tests.factor

@@ -1,6 +1,6 @@
 IN: stack-checker.transforms.tests
 USING: sequences stack-checker.transforms tools.test math kernel
-quotations stack-checker accessors combinators words arrays
+quotations stack-checker stack-checker.errors accessors combinators words arrays
 classes classes.tuple ;
 
 : compose-n-quot ( word n -- quot' ) <repetition> >quotation ;
@@ -71,3 +71,10 @@ DEFER: curry-folding-test ( quot -- )
 
 [ f ] [ 1.0 member?-test ] unit-test
 [ t ] [ \ member?-test def>> first [ member?-test ] all? ] unit-test
+
+! Macro expansion should throw its own type of error
+: bad-macro ( -- ) ;
+
+\ bad-macro [ "OOPS" throw ] 0 define-transform
+
+[ [ bad-macro ] infer ] [ inference-error? ] must-fail-with

basis/stack-checker/transforms/transforms.factor

@@ -17,9 +17,14 @@ IN: stack-checker.transforms
         [ dup infer-word apply-word/effect ]
     } cond ;
 
+: call-transformer ( word stack quot -- newquot )
+    '[ _ _ with-datastack [ length 1 assert= ] [ first ] bi nip ]
+    [ transform-expansion-error ]
+    recover ;
+
 :: ((apply-transform)) ( word quot values stack rstate -- )
     rstate recursive-state
-    [ stack quot with-datastack first ] with-variable
+    [ word stack quot call-transformer ] with-variable
     [
         word inlined-dependency depends-on
         values [ length meta-d shorten-by ] [ #drop, ] bi

basis/tools/errors/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/tools/errors/errors-docs.factor

@@ -0,0 +1,40 @@
+IN: tools.errors
+USING: compiler.errors tools.errors help.markup help.syntax vocabs.loader
+words quotations io ;
+
+ARTICLE: "compiler-errors" "Compiler warnings and errors"
+"After loading a vocabulary, you might see messages like:"
+{ $code
+    ":errors - print 2 compiler errors."
+    ":warnings - print 50 compiler warnings."
+}
+"These warnings arise from the compiler's stack effect checker. Warnings are non-fatal conditions -- not all code has a static stack effect, so you try to minimize warnings but understand that in many cases they cannot be eliminated. Errors indicate programming mistakes, such as erroneous stack effect declarations."
+$nl
+"The precise warning and error conditions are documented in " { $link "inference-errors" } "."
+$nl
+"Words to view warnings and errors:"
+{ $subsection :errors }
+{ $subsection :warnings }
+{ $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." } ;
+
+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 } "." } ;
+
+HELP: :warnings
+{ $description "Prints all ignorable compiler warnings from the most recent compile to " { $link output-stream } "." } ;
+
+HELP: :linkage
+{ $description "Prints all C library interface linkage errors from the most recent compile to " { $link output-stream } "." } ;
+
+{ :errors :warnings } related-words

basis/tools/errors/errors.factor

@@ -0,0 +1,25 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs compiler.errors debugger io kernel sequences
+source-files.errors ;
+IN: tools.errors
+
+#! Tools for source-files.errors. Used by tools.tests and others
+#! for error reporting
+
+: errors. ( errors -- )
+    group-by-source-file sort-errors
+    [
+        [ nl "==== " write print nl ]
+        [ [ nl ] [ error. ] interleave ]
+        bi*
+    ] assoc-each ;
+
+: compiler-errors. ( type -- )
+    errors-of-type values errors. ;
+
+: :errors ( -- ) +compiler-error+ compiler-errors. ;
+
+: :warnings ( -- ) +compiler-warning+ compiler-errors. ;
+
+: :linkage ( -- ) +linkage-error+ compiler-errors. ;

basis/tools/profiler/profiler.factor

@@ -7,7 +7,7 @@ continuations generic compiler.units sets classes fry ;
 IN: tools.profiler
 
 : profile ( quot -- )
-    [ t profiling call ] [ f profiling ] [ ] cleanup ;
+    [ t profiling call ] [ f profiling ] [ ] cleanup ; inline
 
 : filter-counts ( alist -- alist' )
     [ second 0 > ] filter ;

basis/tools/test/test-docs.factor

@@ -3,33 +3,23 @@ IN: tools.test
 
 ARTICLE: "tools.test.write" "Writing unit tests"
 "Assert that a quotation outputs a specific set of values:"
-{ $subsection unit-test }
+{ $subsection POSTPONE: unit-test }
 "Assert that a quotation throws an error:"
-{ $subsection must-fail }
+{ $subsection POSTPONE: must-fail }
-{ $subsection must-fail-with }
+{ $subsection POSTPONE: must-fail-with }
 "Assert that a quotation or word has a specific static stack effect (see " { $link "inference" } "):"
-{ $subsection must-infer }
+{ $subsection POSTPONE: must-infer }
-{ $subsection must-infer-as } ;
+{ $subsection POSTPONE: must-infer-as } ;
 
 ARTICLE: "tools.test.run" "Running unit tests"
 "The following words run test harness files; any test failures are collected and printed at the end:"
 { $subsection test }
-{ $subsection test-all } ;
+{ $subsection test-all }
-
-ARTICLE: "tools.test.failure" "Handling test failures"
-"Most of the time the words documented in " { $link "tools.test.run" } " are used because they print all test failures in human-readable form. Some tools inspect the test failures and takes some kind of action instead, for example, " { $vocab-link "mason" } "."
-$nl
-"The following words output an association list mapping vocabulary names to sequences of failures; a failure is an array having the shape " { $snippet "{ error test continuation }" } ", and the elements are as follows:"
-{ $list
-    { { $snippet "error" } " - the error thrown by the unit test" }
-    { { $snippet "test" } " - a pair " { $snippet "{ output input }" } " containing expected output and a unit test quotation which didn't produce this output" }
-    { { $snippet "continuation" } " - the traceback at the point of the error" }
-}
-"The following words run test harness files and output failures:"
-{ $subsection run-tests }
-{ $subsection run-all-tests }
 "The following word prints failures:"
-{ $subsection test-failures. } ;
+{ $subsection :failures }
+"Unit test failurs are instances of a class, and are stored in a global variable:"
+{ $subsection test-failure }
+{ $subsection test-failures } ;
 
 ARTICLE: "tools.test" "Unit testing"
 "A unit test is a piece of code which starts with known input values, then compares the output of a word with an expected output, where the expected output is defined by the word's contract."
@@ -45,8 +35,7 @@ $nl
 $nl
 "If the test harness needs to define words, they should be placed in a vocabulary named " { $snippet { $emphasis "vocab" } ".tests" } " where " { $emphasis "vocab" } " is the vocab being tested."
 { $subsection "tools.test.write" }
-{ $subsection "tools.test.run" }
+{ $subsection "tools.test.run" } ;
-{ $subsection "tools.test.failure" } ;
 
 ABOUT: "tools.test"
 
@@ -78,17 +67,8 @@ HELP: test
 { $values { "prefix" "a vocabulary name" } }
 { $description "Runs unit tests for the vocabulary named " { $snippet "prefix" } " and all of its child vocabularies." } ;
 
-HELP: run-tests
-{ $values { "prefix" "a vocabulary name" } { "failures" "an association list of unit test failures" } }
-{ $description "Runs unit tests for the vocabulary named " { $snippet "prefix" } " and all of its child vocabularies. Outputs unit test failures as documented in " { $link "tools.test.failure" } "." } ;
-
 HELP: test-all
 { $description "Runs unit tests for all loaded vocabularies." } ;
 
-HELP: run-all-tests
+HELP: :failures
-{ $values { "failures" "an association list of unit test failures" } }
+{ $description "Prints all pending unit test failures." } ;
-{ $description "Runs unit tests for all loaded vocabularies and outputs unit test failures as documented in " { $link "tools.test.failure" } "." } ;
-
-HELP: test-failures.
-{ $values { "assoc" "an association list of unit test failures" } }
-{ $description "Prints unit test failures output by " { $link run-tests } " or " { $link run-all-tests } " to " { $link output-stream } "." } ;

basis/tools/test/test.factor

@@ -1,95 +1,138 @@
-! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2003, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces arrays prettyprint sequences kernel
+USING: accessors arrays assocs combinators compiler.units
-vectors quotations words parser assocs combinators continuations
+continuations debugger effects fry generalizations io io.files
-debugger io io.styles io.files vocabs vocabs.loader source-files
+io.styles kernel lexer locals macros math.parser namespaces
-compiler.units summary stack-checker effects tools.vocabs fry ;
+parser prettyprint quotations sequences source-files splitting
+stack-checker summary unicode.case vectors vocabs vocabs.loader words
+tools.vocabs tools.errors source-files.errors io.streams.string make
+compiler.errors ;
 IN: tools.test
 
-SYMBOL: failures
+TUPLE: test-failure < source-file-error continuation ;
 
-: <failure> ( error what -- triple )
+SYMBOL: +test-failure+
-    error-continuation get 3array ;
 
-: failure ( error what -- )
+M: test-failure source-file-error-type drop +test-failure+ ;
+
+SYMBOL: test-failures
+test-failures [ V{ } clone ] initialize
+
+<PRIVATE
+
+: <test-failure> ( error experiment file line# -- triple )
+    test-failure new
+        swap >>line#
+        swap >>file
+        swap >>asset
+        swap >>error
+        error-continuation get >>continuation ;
+
+: failure ( error experiment file line# -- )
     "--> test failed!" print
-    <failure> failures get push ;
+    <test-failure> test-failures get push ;
 
-SYMBOL: this-test
+SYMBOL: file
 
-: (unit-test) ( what quot -- )
+: file-failure ( error -- )
-    swap dup . flush this-test set
+    f file get f failure ;
-    failures get [
-        [ this-test get failure ] recover
-    ] [
-        call
-    ] if ; inline
 
-: unit-test ( output input -- )
+:: (unit-test) ( output input -- error ? )
-    [ 2array ] 2keep '[
+    [ { } input with-datastack output assert-sequence= f f ] [ t ] recover ; inline
-        _ { } _ with-datastack swap >array assert=
-    ] (unit-test) ;
 
 : short-effect ( effect -- pair )
     [ in>> length ] [ out>> length ] bi 2array ;
 
-: must-infer-as ( effect quot -- )
+:: (must-infer-as) ( effect quot -- error ? )
-    [ 1quotation ] dip '[ _ infer short-effect ] unit-test ;
+    [ quot infer short-effect effect assert= f f ] [ t ] recover ; inline
 
-: must-infer ( word/quot -- )
+:: (must-infer) ( word/quot -- error ? )
-    dup word? [ 1quotation ] when
+    word/quot dup word? [ '[ _ execute ] ] when :> quot
-    '[ _ infer drop ] [ ] swap unit-test ;
+    [ quot infer drop f f ] [ t ] recover ; inline
 
-: must-fail-with ( quot pred -- )
+TUPLE: did-not-fail ;
-    [ '[ @ f ] ] dip '[ _ _ recover ] [ t ] swap unit-test ;
+CONSTANT: did-not-fail T{ did-not-fail }
 
-: must-fail ( quot -- )
+M: did-not-fail summary drop "Did not fail" ;
-    [ drop t ] must-fail-with ;
 
-: (run-test) ( vocab -- )
+:: (must-fail-with) ( quot pred -- error ? )
+    [ quot call did-not-fail t ]
+    [ dup pred call [ drop f f ] [ t ] if ] recover ; inline
+
+:: (must-fail) ( quot -- error ? )
+    [ quot call did-not-fail t ] [ drop f f ] recover ; inline
+
+: experiment-title ( word -- string )
+    "(" ?head drop ")" ?tail drop { { CHAR: - CHAR: \s } } substitute >title ;
+
+MACRO: <experiment> ( word -- )
+    [ stack-effect in>> length dup ]
+    [ name>> experiment-title ] bi
+    '[ _ ndup _ narray _ prefix ] ;
+
+: experiment. ( seq -- )
+    [ first write ": " write ] [ rest . ] bi ;
+
+:: experiment ( word: ( -- error ? ) line# -- )
+    word <experiment> :> e
+    e experiment.
+    word execute [
+        file get [
+            e file get line# failure
+        ] [ rethrow ] if
+    ] [ drop ] if ; inline
+
+: parse-test ( accum word -- accum )
+    literalize parsed
+    lexer get line>> parsed
+    \ experiment parsed ; inline
+
+<<
+
+SYNTAX: TEST:
+    scan
+    [ create-in ]
+    [ "(" ")" surround search '[ _ parse-test ] ] bi
+    define-syntax ;
+
+>>
+
+: run-test-file ( path -- )
+    dup file [
+        test-failures get [ file>> file get = not ] filter-here
+        '[ _ run-file ] [ file-failure ] recover
+    ] with-variable ;
+
+: run-vocab-tests ( vocab -- )
     dup vocab source-loaded?>> [
-        vocab-tests [ run-file ] each
+        vocab-tests [ run-test-file ] each
     ] [ drop ] if ;
 
-: run-test ( vocab -- failures )
+: traceback-button. ( failure -- )
-    V{ } clone [
+    "[" write [ "Traceback" ] dip continuation>> write-object "]" print ;
-        failures [
-            [ (run-test) ] [ swap failure ] recover
-        ] with-variable
-    ] keep ;
 
-: failure. ( triple -- )
+PRIVATE>
-    dup second .
-    dup first print-error
-    "Traceback" swap third write-object ;
 
-: test-failures. ( assoc -- )
+TEST: unit-test
-    [
+TEST: must-infer-as
-        nl
+TEST: must-infer
-        [
+TEST: must-fail-with
-            "==== ALL TESTS PASSED" print
+TEST: must-fail
-        ] [
-            "==== FAILING TESTS:" print
-            [
-                swap vocab-heading.
-                [ failure. nl ] each
-            ] assoc-each
-        ] if-empty
-    ] [
-        "==== NOTHING TO TEST" print
-    ] if* ;
 
-: run-tests ( prefix -- failures )
+M: test-failure summary
-    child-vocabs [ f ] [
+    asset>> [ [ experiment. ] with-string-writer ] [ "Top-level form" ] if* ;
-        [ dup run-test ] { } map>assoc
+
-        [ second empty? not ] filter
+M: test-failure error. ( error -- )
-    ] if-empty ;
+    [ call-next-method ]
+    [ traceback-button. ]
+    bi ;
+
+: :failures ( -- ) test-failures get errors. ;
 
 : test ( prefix -- )
-    run-tests test-failures. ;
+    [ child-vocabs [ run-vocab-tests ] each ] with-compiler-errors
+    test-failures get [
+        ":failures - show " write length pprint " failing tests." print
+    ] unless-empty ;
 
-: run-all-tests ( -- failures )
+: test-all ( -- ) "" test ;
-    "" run-tests ;
-
-: test-all ( -- )
-    run-all-tests test-failures. ;

basis/ui/baseline-alignment/baseline-alignment.factor

@@ -24,35 +24,47 @@ TUPLE: gadget-metrics height ascent descent cap-height ;
     [ dup [ 2dup - ] [ f ] if ] dip
     gadget-metrics boa ; inline
 
+: ?supremum ( seq -- n/f )
+    sift [ f ] [ supremum ] if-empty ;
+
 : max-ascent ( seq -- n )
-    0 [ ascent>> [ max ] when* ] reduce ; inline
+    [ ascent>> ] map ?supremum ;
 
 : max-cap-height ( seq -- n )
-    0 [ cap-height>> [ max ] when* ] reduce ; inline
+    [ cap-height>> ] map ?supremum ;
 
 : max-descent ( seq -- n )
-    0 [ descent>> [ max ] when* ] reduce ; inline
+    [ descent>> ] map ?supremum ;
 
 : max-text-height ( seq -- y )
-    0 [ [ height>> ] [ ascent>> ] bi [ max ] [ drop ] if ] reduce ;
+    [ ascent>> ] filter [ height>> ] map ?supremum ;
 
 : max-graphics-height ( seq -- y )
-    0 [ [ height>> ] [ ascent>> ] bi [ drop ] [ max ] if ] reduce ;
+    [ ascent>> not ] filter [ height>> ] map ?supremum 0 or ;
-
-: (align-baselines) ( y max leading -- y' ) [ swap - ] dip + ;
 
 :: combine-metrics ( graphics-height ascent descent cap-height -- ascent' descent' )
+    ascent [
         cap-height 2 / :> mid-line 
         graphics-height 2 /
         [ ascent mid-line - max mid-line + >integer ]
-    [ descent mid-line + max mid-line - >integer ] bi ;
+        [ descent mid-line + max mid-line - >integer ] bi
+    ] [ f f ] if ;
+
+: (measure-metrics) ( children sizes -- graphics-height ascent descent cap-height )
+    [ <gadget-metrics> ] 2map
+    {
+        [ max-graphics-height ]
+        [ max-ascent ]
+        [ max-descent ]
+        [ max-cap-height ]
+    } cleave ;
 
 PRIVATE>
 
 :: align-baselines ( gadgets -- ys )
     gadgets [ dup pref-dim <gadget-metrics> ] map
-    dup max-ascent :> max-ascent
+    dup max-ascent 0 or :> max-ascent
-    dup max-cap-height :> max-cap-height
+    dup max-cap-height 0 or :> max-cap-height
     dup max-graphics-height :> max-graphics-height
     
     max-cap-height max-graphics-height + 2 /i :> critical-line
@@ -61,20 +73,12 @@ PRIVATE>
 
     [
         dup ascent>>
-        [ ascent>> max-ascent text-leading ]
+        [ ascent>> max-ascent swap - text-leading ]
-        [ height>> max-graphics-height graphics-leading ] if
+        [ height>> max-graphics-height swap - 2/ graphics-leading ] if +
-        (align-baselines)
     ] map ;
 
 : measure-metrics ( children sizes -- ascent descent )
-    [ <gadget-metrics> ] 2map
+    (measure-metrics) combine-metrics ;
-    {
-        [ max-graphics-height ]
-        [ max-ascent ]
-        [ max-descent ]
-        [ max-cap-height ]
-    } cleave
-    combine-metrics ;
 
 : measure-height ( children sizes -- height )
-    measure-metrics + ;
+    (measure-metrics) dup [ combine-metrics + ] [ 3drop ] if ;

basis/ui/gadgets/icons/icons.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors ui.images ui.pens
-ui.pens.image ui.gadgets ;
+ui.pens.image ui.gadgets ui.gadgets.labels ;
 IN: ui.gadgets.icons
 
 TUPLE: icon < gadget ;
@@ -10,3 +10,5 @@ TUPLE: icon < gadget ;
     icon new swap <image-pen> t >>fill? >>interior ;
 
 M: icon pref-dim* dup interior>> pen-pref-dim ;
+
+M: image-name >label <icon> ;

basis/ui/gadgets/packs/packs-tests.factor

@@ -91,3 +91,42 @@ IN: ui.gadgets.packs.tests
 [ ] [ "g" get prefer ] unit-test
 
 [ ] [ "g" get layout ] unit-test
+
+! Baseline alignment without any text gadgets should behave like align=1/2
+<shelf> +baseline+ >>align
+    <gadget> { 30 30 } >>dim add-gadget
+    <gadget> { 30 20 } >>dim add-gadget
+"g" set
+
+[ { 60 30 } ] [ "g" get pref-dim ] unit-test
+
+[ ] [ "g" get prefer ] unit-test
+
+[ ] [ "g" get layout ] unit-test
+
+[ V{ { 0 0 } { 30 5 } } ]
+[ "g" get children>> [ loc>> ] map ] unit-test
+
+<shelf> +baseline+ >>align
+<gadget> { 30 30 } >>dim add-gadget
+10 10 { 10 10 } <baseline-gadget> add-gadget
+"g" set
+
+[ ] [ "g" get prefer ] unit-test
+
+[ ] [ "g" get layout ] unit-test
+
+[ V{ { 0 0 } { 30 10 } } ]
+[ "g" get children>> [ loc>> ] map ] unit-test
+
+<shelf> +baseline+ >>align
+<shelf> <gadget> { 30 30 } >>dim add-gadget add-gadget
+10 10 { 10 10 } <baseline-gadget> add-gadget
+"g" set
+
+[ ] [ "g" get prefer ] unit-test
+
+[ ] [ "g" get layout ] unit-test
+
+[ V{ { 0 0 } { 30 10 } } ]
+[ "g" get children>> [ loc>> ] map ] unit-test

basis/ui/gadgets/packs/packs.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: sequences ui.gadgets ui.baseline-alignment kernel math
+USING: sequences ui.gadgets ui.baseline-alignment
-math.functions math.vectors math.order math.rectangles namespaces
+ui.baseline-alignment.private kernel math math.functions math.vectors
-accessors fry combinators arrays ;
+math.order math.rectangles namespaces accessors fry combinators arrays ;
 IN: ui.gadgets.packs
 
 TUPLE: pack < gadget
@@ -84,8 +84,7 @@ M: pack pref-dim*
     children>> dup pref-dims measure-metrics drop ;
 
 : pack-cap-height ( pack -- n )
-    children>> [ cap-height ] map sift
+    children>> [ cap-height ] map ?supremum ;
-    [ f ] [ supremum ] if-empty ;
 
 PRIVATE>
 

basis/ui/gadgets/panes/panes-tests.factor

@@ -2,7 +2,7 @@ USING: alien ui.gadgets.panes ui.gadgets namespaces
 kernel sequences io io.styles io.streams.string tools.test
 prettyprint definitions help help.syntax help.markup
 help.stylesheet splitting ui.gadgets.debug models math summary
-inspector accessors help.topics see ;
+inspector accessors help.topics see fry ;
 IN: ui.gadgets.panes.tests
 
 : #children ( -- n ) "pane" get children>> length ;
@@ -18,8 +18,9 @@ IN: ui.gadgets.panes.tests
 [ t ] [ #children "num-children" get = ] unit-test
 
 : test-gadget-text ( quot -- ? )
-    dup make-pane gadget-text dup print "======" print
+    '[ _ call( -- ) ]
-    swap with-string-writer dup print = ;
+    [ make-pane gadget-text dup print "======" print ]
+    [ with-string-writer dup print ] bi = ;
 
 [ t ] [ [ "hello" write ] test-gadget-text ] unit-test
 [ t ] [ [ "hello" pprint ] test-gadget-text ] unit-test

basis/ui/gadgets/search-tables/search-tables.factor

@@ -74,7 +74,7 @@ CONSULT: table-protocol search-table table>> ;
         dup field>> { 2 2 } <filled-border> f track-add
         values search 500 milliseconds <delay> quot <string-search>
         renderer <table> f >>takes-focus? >>table
-        dup table>> <scroller> 1 track-add ;
+        dup table>> <scroller> 1 track-add ; inline
 
 M: search-table model-changed
     nip field>> clear-search-field ;

basis/ui/gadgets/tables/tables.factor

@@ -59,14 +59,19 @@ focused? ;
 
 GENERIC: cell-width ( font cell -- x )
 GENERIC: cell-height ( font cell -- y )
+GENERIC: cell-padding ( cell -- y )
 GENERIC: draw-cell ( font cell -- )
 
 M: string cell-width text-width ;
 M: string cell-height text-height ceiling ;
+M: string cell-padding drop 0 ;
 M: string draw-cell draw-text ;
 
+CONSTANT: image-padding 2
+
 M: image-name cell-width nip image-dim first ;
 M: image-name cell-height nip image-dim second ;
+M: image-name cell-padding drop image-padding ;
 M: image-name draw-cell nip draw-image ;
 
 : table-rows ( table -- rows )
@@ -87,7 +92,7 @@ CONSTANT: column-title-background COLOR: light-gray
     if ;
 
 : row-column-widths ( table row -- widths )
-    [ font>> ] dip [ cell-width ] with map ;
+    [ font>> ] dip [ [ cell-width ] [ cell-padding ] bi + ] with map ;
 
 : compute-total-width ( gap widths -- total )
     swap [ column-offsets drop ] keep - ;
@@ -162,9 +167,10 @@ M: table layout*
         '[ [ 0 2array ] [ _ 2array ] bi gl-line ] each
     ] bi ;
 
-: column-loc ( font column width align -- loc )
+:: column-loc ( font column width align -- loc )
-    [ [ cell-width ] dip swap - ] dip
+    font column cell-width width swap - align * column cell-padding 2 / 1 align - * +
-    * >integer 0 2array ;
+    font column cell-height \ line-height get swap - 2 /
+    [ >integer ] bi@ 2array ;
 
 : translate-column ( width gap -- )
     + 0 2array gl-translate ;
@@ -203,6 +209,7 @@ M: table draw-line ( row index table -- )
 
 M: table draw-gadget*
     dup control-value empty? [ drop ] [
+        dup line-height \ line-height [
             {
                 [ draw-selected-row ]
                 [ draw-lines ]
@@ -210,11 +217,13 @@ M: table draw-gadget*
                 [ draw-focused-row ]
                 [ draw-moused-row ]
             } cleave
+        ] with-variable
     ] if ;
 
 M: table line-height ( table -- y )
     [ font>> ] [ renderer>> prototype-row ] bi
-    [ cell-height ] with [ max ] map-reduce ;
+    [ [ cell-height ] [ cell-padding ] bi + ] with
+    [ max ] map-reduce ;
 
 M: table pref-dim*
     [ compute-column-widths drop ] keep
@@ -379,6 +388,7 @@ TUPLE: column-headers < gadget table ;
         column-title-background <solid> >>interior ;
 
 : draw-column-titles ( table -- )
+    dup font>> font-metrics height>> \ line-height [
         {
             [ renderer>> column-titles ]
             [ column-widths>> ]
@@ -386,7 +396,8 @@ TUPLE: column-headers < gadget table ;
             [ font>> column-title-font ]
             [ gap>> ]
         } cleave
-    draw-columns ;
+        draw-columns
+    ] with-variable ;
 
 M: column-headers draw-gadget*
     table>> draw-column-titles ;

basis/ui/tools/browser/browser.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2006, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: debugger help help.topics help.crossref help.home kernel models
+USING: debugger classes help help.topics help.crossref help.home kernel models
 compiler.units assocs words vocabs accessors fry arrays
 combinators.short-circuit namespaces sequences models help.apropos
 combinators ui ui.commands ui.gadgets ui.gadgets.panes
@@ -91,6 +91,10 @@ M: browser-gadget focusable-child* search-field>> ;
 : browser-window ( -- )
     "help.home" (browser-window) ;
 
+: error-help-window ( error -- )
+    [ error-help ]
+    [ dup tuple? [ class ] [ drop "errors" ] if ] bi or (browser-window) ;
+
 \ browser-window H{ { +nullary+ t } } define-command
 
 : com-browse ( link -- )

basis/ui/tools/browser/popups/popups.factor

@@ -46,7 +46,7 @@ SLOT: model
 
 : show-links-popup ( browser-gadget quot title -- )
     [ dup model>> ] 2dip <links-popup>
-    [ hand-loc get { 0 0 } <rect> show-glass ] [ request-focus ] bi ;
+    [ hand-loc get { 0 0 } <rect> show-glass ] [ request-focus ] bi ; inline
 
 : com-show-outgoing-links ( browser-gadget -- )
     [ uses ] "Outgoing links" show-links-popup ;

basis/ui/tools/debugger/debugger.factor

@@ -8,7 +8,7 @@ ui.gadgets.buttons ui.gadgets.labels ui.gadgets.panes
 ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.tables
 ui.gadgets.tracks ui.gadgets.scrollers ui.gadgets.panes
 ui.gadgets.borders ui.gadgets.status-bar ui.tools.traceback
-ui.tools.inspector ;
+ui.tools.inspector ui.tools.browser ;
 IN: ui.tools.debugger
 
 TUPLE: debugger < track error restarts restart-hook restart-list continuation ;
@@ -86,9 +86,7 @@ debugger "gestures" f {
 
 : com-traceback ( debugger -- ) continuation>> traceback-window ;
 
-: com-help ( debugger -- ) error>> (:help) ;
+: com-help ( debugger -- ) error>> error-help-window ;
-
-\ com-help H{ { +listener+ t } } define-command
 
 : com-edit ( debugger -- ) error>> (:edit) ;
 

basis/ui/tools/error-list/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

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

@@ -0,0 +1,20 @@
+IN: ui.tools.error-list
+USING: help.markup help.syntax ;
+
+ARTICLE: "ui.tools.error-list" "UI error list tool"
+"The error list tool displays messages generated by tools which process source files and definitions."
+$nl
+"The different types of messages displayed:"
+{ $table
+    { "Icon" "Message type" "Reference" }
+    { { $image "vocab:ui/tools/error-list/icons/note.tiff" } "Parser note" { $link "parser" } }
+    { { $image "vocab:ui/tools/error-list/icons/syntax-error.tiff" } "Syntax error" { $link "syntax" } }
+    { { $image "vocab:ui/tools/error-list/icons/compiler-warning.tiff" } "Compiler warning" { $link "compiler-errors" } }
+    { { $image "vocab:ui/tools/error-list/icons/compiler-error.tiff" } "Compiler error" { $link "compiler-errors" } }
+    { { $image "vocab:ui/tools/error-list/icons/unit-test-error.tiff" } "Unit test failure" { $link "tools.test" } }
+    { { $image "vocab:ui/tools/error-list/icons/help-lint-error.tiff" } "Help lint failure" { $link "help.lint" } }
+    { { $image "vocab:ui/tools/error-list/icons/linkage-error.tiff" } "Linkage error" { $link "compiler-errors" } }
+}
+"The " { $vocab-link "source-files.errors" } " vocabulary contains backend code used by this tool." ;
+
+ABOUT: "ui.tools.error-list"

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

@@ -0,0 +1,210 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays sequences sorting assocs colors.constants fry
+combinators combinators.smart combinators.short-circuit editors memoize
+compiler.errors compiler.units fonts kernel io.pathnames prettyprint
+tools.test stack-checker.errors source-files.errors math.parser
+math.order models models.arrow models.arrow.smart models.search
+models.mapping debugger namespaces summary locals ui ui.commands
+ui.gadgets ui.gadgets.panes ui.gadgets.tables ui.gadgets.labeled
+ui.gadgets.tracks ui.gestures ui.operations ui.tools.browser
+ui.tools.common ui.gadgets.scrollers ui.tools.inspector
+ui.gadgets.status-bar ui.operations ui.gadgets.buttons
+ui.gadgets.borders ui.gadgets.packs ui.gadgets.labels
+ui.baseline-alignment ui.images ;
+IN: ui.tools.error-list
+
+CONSTANT: error-types
+    {
+        +compiler-warning+
+        +compiler-error+
+        +test-failure+
+        +linkage-error+
+    }
+
+MEMO: error-list-icon ( object -- object )
+    "vocab:ui/tools/error-list/icons/" ".tiff" surround <image-name> ;
+
+: error-icon ( type -- icon )
+    {
+        { +compiler-error+ [ "compiler-error" ] }
+        { +compiler-warning+ [ "compiler-warning" ] }
+        { +linkage-error+ [ "linkage-error" ] }
+        { +test-failure+ [ "unit-test-error" ] }
+    } case error-list-icon ;
+
+: <checkboxes> ( alist -- gadget )
+    [ <shelf> { 15 0 } >>gap ] dip
+    [ swap <checkbox> add-gadget ] assoc-each ;
+
+: <error-toggle> ( -- model gadget )
+    #! Linkage errors are not shown by default.
+    error-types [ dup +linkage-error+ eq? not <model> ] { } map>assoc
+    [ [ [ error-icon ] dip ] assoc-map <checkboxes> ]
+    [ <mapping> ] bi ;
+
+TUPLE: error-list-gadget < tool
+visible-errors source-file error
+error-toggle source-file-table error-table error-display ;
+
+SINGLETON: source-file-renderer
+
+: source-file-icon ( -- image-name )
+    "source-file" error-list-icon ;
+
+M: source-file-renderer row-columns
+    drop first2
+    [ [ source-file-icon ] [ ] [ length number>string ] tri* ] output>array ;
+
+M: source-file-renderer prototype-row
+    drop source-file-icon "" "" 3array ;
+
+M: source-file-renderer row-value
+    drop dup [ first <pathname> ] when ;
+
+M: source-file-renderer column-titles
+    drop { "" "File" "Errors" } ;
+
+M: source-file-renderer column-alignment drop { 0 0 1 } ;
+
+M: source-file-renderer filled-column drop 1 ;
+
+: <source-file-model> ( model -- model' )
+    [ group-by-source-file >alist sort-keys ] <arrow> ;
+
+:: <source-file-table> ( error-list -- table )
+    error-list model>> <source-file-model>
+    source-file-renderer
+    <table>
+        [ invoke-primary-operation ] >>action
+        COLOR: dark-gray >>column-line-color
+        6 >>gap
+        30 >>min-rows
+        30 >>max-rows
+        60 >>min-cols
+        60 >>max-cols
+        t >>selection-required?
+        error-list source-file>> >>selected-value ;
+
+SINGLETON: error-renderer
+
+M: error-renderer row-columns
+    drop [
+        {
+            [ source-file-error-type error-icon ]
+            [ line#>> number>string ]
+            [ asset>> unparse-short ]
+            [ error>> summary ]
+        } cleave
+    ] output>array ;
+
+M: error-renderer prototype-row
+    drop [ +compiler-error+ error-icon "" "" "" ] output>array ;
+
+M: error-renderer row-value
+    drop ;
+
+M: error-renderer column-titles
+    drop { "" "Line" "Asset" "Error" } ;
+
+M: error-renderer column-alignment drop { 0 1 0 0 } ;
+
+: sort-errors ( seq -- seq' )
+    [ [ [ file>> ] [ line#>> ] bi 2array ] compare ] sort ;
+
+: <error-table-model> ( error-list -- model )
+    [ model>> ] [ source-file>> ] bi
+    [ [ file>> ] [ string>> ] bi* = ] <search>
+    [ sort-errors ] <arrow> ;
+
+:: <error-table> ( error-list -- table )
+    error-list <error-table-model>
+    error-renderer
+    <table>
+        [ invoke-primary-operation ] >>action
+        COLOR: dark-gray >>column-line-color
+        6 >>gap
+        30 >>min-rows
+        30 >>max-rows
+        60 >>min-cols
+        60 >>max-cols
+        t >>selection-required?
+        error-list error>> >>selected-value ;
+
+TUPLE: error-display < track ;
+
+: <error-display> ( error-list -- gadget )
+    vertical error-display new-track
+        add-toolbar
+        swap error>> >>model
+        dup model>> [ print-error ] <pane-control> <scroller> 1 track-add ;
+
+: com-inspect ( error-display -- )
+    model>> value>> inspector ;
+
+: com-help ( error-display -- )
+    model>> value>> error>> error-help-window ;
+
+: com-edit ( error-display -- )
+    model>> value>> edit-error ;
+
+error-display "toolbar" f {
+    { f com-inspect }
+    { f com-help }
+    { f com-edit }
+} define-command-map
+
+: <error-list-toolbar> ( error-list -- toolbar )
+    [ <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> ;
+
+:: <error-list-gadget> ( model -- gadget )
+    vertical error-list-gadget new-track
+        <error-toggle> [ >>error-toggle ] [ >>visible-errors ] bi*
+        dup visible-errors>> model <error-model> >>model 
+        f <model> >>source-file
+        f <model> >>error
+        dup <source-file-table> >>source-file-table
+        dup <error-table> >>error-table
+        dup <error-display> >>error-display
+    :> error-list
+    error-list vertical <track>
+        { 5 5 } >>gap
+        error-list <error-list-toolbar> f track-add
+        error-list source-file-table>> <scroller> "Source files" <labeled-gadget> 1/4 track-add
+        error-list error-table>> <scroller> "Errors" <labeled-gadget> 1/2 track-add
+        error-list error-display>> "Details" <labeled-gadget> 1/4 track-add
+    { 5 5 } <filled-border> 1 track-add ;
+
+M: error-list-gadget focusable-child*
+    source-file-table>> ;
+
+: error-list-help ( -- ) "ui.tools.error-list" com-browse ;
+
+\ error-list-help H{ { +nullary+ t } } define-command
+
+error-list-gadget "toolbar" f {
+    { T{ key-down f f "F1" } error-list-help }
+} define-command-map
+
+SYMBOL: compiler-error-model
+
+compiler-error-model [ f <model> ] initialize
+
+SINGLETON: updater
+
+M: updater definitions-changed
+    2drop
+    compiler-errors get-global values
+    test-failures get-global append
+    compiler-error-model get-global
+    set-model ;
+
+updater remove-definition-observer
+updater add-definition-observer
+
+: error-list-window ( -- )
+    compiler-error-model get-global <error-list-gadget>
+    "Compiler errors" open-status-window ;

basis/ui/tools/operations/operations.factor

@@ -5,7 +5,7 @@ stack-checker summary io.pathnames io.styles kernel namespaces
 parser prettyprint quotations tools.crossref tools.annotations
 editors tools.profiler tools.test tools.time tools.walker vocabs
 vocabs.loader words sequences tools.vocabs classes
-compiler.units accessors vocabs.parser macros.expander ui
+compiler.errors compiler.units accessors vocabs.parser macros.expander ui
 ui.tools.browser ui.tools.listener ui.tools.listener.completion
 ui.tools.profiler ui.tools.inspector ui.tools.traceback
 ui.commands ui.gadgets.editors ui.gestures ui.operations
@@ -86,6 +86,21 @@ IN: ui.tools.operations
     { +listener+ t }
 } define-operation
 
+! Compiler errors
+[ compiler-error? ] \ edit-error H{
+    { +primary+ t }
+    { +secondary+ t }
+    { +listener+ t }
+} define-operation
+
+: com-reload ( error -- )
+    file>> run-file ;
+
+[ compiler-error? ] \ com-reload H{
+    { +listener+ t }
+} define-operation
+
+! Definitions
 : com-forget ( defspec -- )
     [ forget ] with-compilation-unit ;
 

basis/ui/tools/profiler/profiler-tests.factor

@@ -0,0 +1,3 @@
+USING: ui.tools.profiler tools.test ;
+
+\ profiler-window must-infer

basis/ui/tools/profiler/profiler.factor

@@ -11,6 +11,7 @@ ui.gadgets.tabbed ui.gadgets.status-bar ui.gadgets.borders
 ui.tools.browser ui.tools.common ui.baseline-alignment
 ui.operations ui.images ;
 FROM: models.arrow => <arrow> ;
+FROM: models.arrow.smart => <smart-arrow> ;
 FROM: models.product => <product> ;
 IN: ui.tools.profiler
 
@@ -112,8 +113,8 @@ M: method-renderer column-titles drop { "" "Method" "Count" } ;
 : <methods-model> ( profiler -- model )
     [
         [ method-counters <model> ] dip
-        [ generic>> ] [ class>> ] bi 3array <product>
+        [ generic>> ] [ class>> ] bi
-        [ first3 '[ _ _ method-matches? ] filter ] <arrow>
+        [ '[ _ _ method-matches? ] filter ] <smart-arrow>
     ] keep <profiler-model> ;
 
 : sort-by-name ( obj1 obj2 -- <=> )
@@ -208,6 +209,6 @@ profiler-gadget "toolbar" f {
 : profiler-window ( -- )
     <profiler-gadget> "Profiling results" open-status-window ;
 
-: com-profile ( quot -- ) profile profiler-window ;
+: com-profile ( quot -- ) profile profiler-window ; inline
 
 MAIN: profiler-window

basis/ui/tools/tools-docs.factor

@@ -66,6 +66,7 @@ $nl
 { $subsection "ui-listener" }
 { $subsection "ui-browser" }
 { $subsection "ui-inspector" }
+{ $subsection "ui.tools.error-list" }
 { $subsection "ui.tools.profiler" }
 { $subsection "ui-walker" }
 { $subsection "ui.tools.deploy" }

basis/ui/tools/tools.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: memory system kernel tools.vocabs ui.tools.operations
-ui.tools.listener ui.tools.browser ui.tools.common
+ui.tools.listener ui.tools.browser ui.tools.common ui.tools.error-list
 ui.tools.walker ui.commands ui.gestures ui ui.private ;
 IN: ui.tools
 

core/compiler/errors/errors-docs.factor

@@ -2,51 +2,7 @@ IN: compiler.errors
 USING: help.markup help.syntax vocabs.loader words io
 quotations words.symbol ;
 
-ARTICLE: "compiler-errors" "Compiler warnings and errors"
-"After loading a vocabulary, you might see messages like:"
-{ $code
-    ":errors - print 2 compiler errors."
-    ":warnings - print 50 compiler warnings."
-}
-"These warnings arise from the compiler's stack effect checker. Warnings are non-fatal conditions -- not all code has a static stack effect, so you try to minimize warnings but understand that in many cases they cannot be eliminated. Errors indicate programming mistakes, such as erroneous stack effect declarations."
-$nl
-"The precise warning and error conditions are documented in " { $link "inference-errors" } "."
-$nl
-"Words to view warnings and errors:"
-{ $subsection :errors }
-{ $subsection :warnings }
-{ $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-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"
-
-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." } ;
-
-HELP: compiler-error.
-{ $values { "error" "an error" } { "word" word } }
-{ $description "Prints a compiler error to " { $link output-stream } "." } ;
-
-HELP: compiler-errors.
-{ $values { "type" symbol } }
-{ $description "Prints compiler errors to " { $link output-stream } ". The type parameter is one of " { $link +error+ } ", " { $link +warning+ } ", or " { $link +linkage+ } "." } ;
-HELP: :errors
-{ $description "Prints all serious compiler errors from the most recent compile to " { $link output-stream } "." } ;
-
-HELP: :warnings
-{ $description "Prints all ignorable compiler warnings from the most recent compile to " { $link output-stream } "." } ;
-
-HELP: :linkage
-{ $description "Prints all C library interface linkage errors from the most recent compile to " { $link output-stream } "." } ;
-
-{ :errors :warnings } related-words
-
-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." } ;

core/compiler/errors/errors.factor

@@ -1,32 +1,27 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel namespaces make assocs io sequences
-sorting continuations math math.parser ;
+continuations math math.parser accessors definitions
+source-files.errors ;
 IN: compiler.errors
 
-SYMBOL: +error+
+SYMBOLS: +compiler-error+ +compiler-warning+ +linkage-error+ ;
-SYMBOL: +warning+
-SYMBOL: +linkage+
 
-GENERIC: compiler-error-type ( error -- ? )
+TUPLE: compiler-error < source-file-error ;
 
-M: object compiler-error-type drop +error+ ;
+M: compiler-error source-file-error-type error>> source-file-error-type ;
-
-GENERIC# compiler-error. 1 ( error word -- )
 
 SYMBOL: compiler-errors
 
+compiler-errors [ H{ } clone ] initialize
+
 SYMBOL: with-compiler-errors?
 
 : errors-of-type ( type -- assoc )
     compiler-errors get-global
-    swap [ [ nip compiler-error-type ] dip eq? ] curry
+    swap [ [ nip source-file-error-type ] dip eq? ] curry
     assoc-filter ;
 
-: compiler-errors. ( type -- )
-    errors-of-type >alist sort-keys
-    [ swap compiler-error. ] assoc-each ;
-
 : (compiler-report) ( what type word -- )
     over errors-of-type assoc-empty? [ 3drop ] [
         [
@@ -41,27 +36,25 @@ SYMBOL: with-compiler-errors?
     ] if ;
 
 : compiler-report ( -- )
-    "semantic errors" +error+ "errors" (compiler-report)
+    "compiler errors" +compiler-error+ "errors" (compiler-report)
-    "semantic warnings" +warning+ "warnings" (compiler-report)
+    "compiler warnings" +compiler-warning+ "warnings" (compiler-report)
-    "linkage errors" +linkage+ "linkage" (compiler-report) ;
+    "linkage errors" +linkage-error+ "linkage" (compiler-report) ;
 
-: :errors ( -- ) +error+ compiler-errors. ;
+: <compiler-error> ( error word -- compiler-error )
-
+    \ compiler-error new
-: :warnings ( -- ) +warning+ compiler-errors. ;
+        swap
-
+        [ >>asset ]
-: :linkage ( -- ) +linkage+ compiler-errors. ;
+        [ where [ first2 ] [ "<unknown file>" 0 ] if* [ >>file ] [ >>line# ] bi* ] bi
+        swap >>error ;
 
 : compiler-error ( error word -- )
-    with-compiler-errors? get [
+    compiler-errors get-global pick
-        compiler-errors get pick
+    [ [ [ <compiler-error> ] keep ] dip set-at ] [ delete-at drop ] if ;
-        [ set-at ] [ delete-at drop ] if
-    ] [ 2drop ] if ;
 
 : with-compiler-errors ( quot -- )
     with-compiler-errors? get "quiet" get or [ call ] [
         [
             with-compiler-errors? on
-            V{ } clone compiler-errors set-global
             [ compiler-report ] [ ] cleanup
         ] with-scope
     ] if ; inline

core/compiler/units/units-tests.factor

@@ -1,6 +1,6 @@
-IN: compiler.units.tests
 USING: definitions compiler.units tools.test arrays sequences words kernel
 accessors namespaces fry ;
+IN: compiler.units.tests
 
 [ [ [ ] define-temp ] with-compilation-unit ] must-infer
 [ [ [ ] define-temp ] with-nested-compilation-unit ] must-infer
@@ -31,3 +31,18 @@ accessors namespaces fry ;
     ] with-compilation-unit
     "b" get execute
 ] unit-test
+
+! Notify observers even if compilation unit did nothing
+SINGLETON: observer
+
+observer add-definition-observer
+
+SYMBOL: counter
+
+0 counter set-global
+
+M: observer definitions-changed 2drop global [ counter inc ] bind ;
+
+[ ] with-compilation-unit
+
+[ 1 ] [ counter get-global ] unit-test

core/compiler/units/units.factor

@@ -3,7 +3,7 @@
 USING: accessors arrays kernel continuations assocs namespaces
 sequences words vocabs definitions hashtables init sets
 math math.order classes classes.algebra classes.tuple
-classes.tuple.private generic ;
+classes.tuple.private generic compiler.errors ;
 IN: compiler.units
 
 SYMBOL: old-definitions
@@ -41,7 +41,7 @@ SYMBOL: compiler-impl
 HOOK: recompile compiler-impl ( words -- alist )
 
 ! Non-optimizing compiler
-M: f recompile [ f ] { } map>assoc ;
+M: f recompile [ [ f swap compiler-error ] each ] [ [ f ] { } map>assoc ] bi ;
 
 ! Trivial compiler. We don't want to touch the code heap
 ! during stage1 bootstrap, it would just waste time.

core/parser/parser-tests.factor

@@ -3,7 +3,7 @@ io.streams.string namespaces classes effects source-files assocs
 sequences strings io.files io.pathnames definitions
 continuations sorting classes.tuple compiler.units debugger
 vocabs vocabs.loader accessors eval combinators lexer
-vocabs.parser words.symbol multiline ;
+vocabs.parser words.symbol multiline source-files.errors ;
 IN: parser.tests
 
 \ run-file must-infer

core/parser/parser.factor

@@ -190,6 +190,7 @@ SYMBOL: interactive-vocabs
     "tools.annotations"
     "tools.crossref"
     "tools.disassembler"
+    "tools.errors"
     "tools.memory"
     "tools.profiler"
     "tools.test"

core/sequences/sequences.factor

@@ -568,6 +568,9 @@ M: sequence <=>
     2dup [ length ] bi@ =
     [ mismatch not ] [ 2drop f ] if ; inline
 
+: assert-sequence= ( a b -- )
+    2dup sequence= [ 2drop ] [ assert ] if ;
+
 : sequence-hashcode-step ( oldhash newpart -- newhash )
     >fixnum swap [
         [ -2 fixnum-shift-fast ] [ 5 fixnum-shift-fast ] bi

core/source-files/errors/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

core/source-files/errors/errors.factor

@@ -0,0 +1,14 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs kernel math.order sorting sequences ;
+IN: source-files.errors
+
+TUPLE: source-file-error error asset file line# ;
+
+: sort-errors ( errors -- alerrors'ist )
+    [ [ [ line#>> ] compare ] sort ] { } assoc-map-as sort-keys ;
+
+: group-by-source-file ( errors -- assoc )
+    H{ } clone [ [ push-at ] curry [ dup file>> ] prepose each ] keep ;
+
+GENERIC: source-file-error-type ( error -- type )

core/source-files/source-files.factor

@@ -4,7 +4,7 @@ USING: arrays definitions generic assocs kernel math namespaces
 sequences strings vectors words quotations io io.files
 io.pathnames combinators sorting splitting math.parser effects
 continuations checksums checksums.crc32 vocabs hashtables graphs
-compiler.units io.encodings.utf8 accessors ;
+compiler.units io.encodings.utf8 accessors source-files.errors ;
 IN: source-files
 
 SYMBOL: source-files
@@ -77,21 +77,20 @@ M: pathname forget*
 
 SYMBOL: file
 
-TUPLE: source-file-error error file ;
+: wrap-source-file-error ( error -- * )
-
+    file get rollback-source-file
-: <source-file-error> ( msg -- error )
     \ source-file-error new
-        file get >>file
+        f >>line#
-        swap >>error ;
+        file get path>> >>file
+        swap >>error rethrow  ;
 
 : with-source-file ( name quot -- )
     #! Should be called from inside with-compilation-unit.
     [
-        swap source-file
-        dup file set
-        definitions>> old-definitions set
         [
-            file get rollback-source-file
+            source-file
-            <source-file-error> rethrow
+            [ file set ]
-        ] recover
+            [ definitions>> old-definitions set ] bi
+        ] dip
+        [ wrap-source-file-error ] recover
     ] with-scope ; inline