Working on UI compile error viewer tool

basis/debugger/debugger.factor

@@ -9,7 +9,7 @@ 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 ;
 IN: debugger
 
 GENERIC: error. ( error -- )
@@ -309,11 +309,20 @@ M: lexer-error compute-restarts
 M: lexer-error error-help
     error>> error-help ;
 
-M: object compiler-error. ( error word -- )
+M: object compiler-error. ( error -- )
-    nl
+    [
-    "While compiling " write pprint ": " print
+        [
-    nl
+            [
-    print-error ;
+                [ line#>> # ": " % ]
+                [ word>> synopsis % ] bi
+            ] "" make
+        ] [
+            [
+                presented set
+                bold font-style set
+            ] H{ } make-assoc
+        ] bi format nl
+    ] [ error>> error. ] bi ;
 
 M: bad-effect summary
     drop "Bad stack effect declaration" ;

basis/ui/tools/compiler-errors/authors.txt

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

basis/ui/tools/compiler-errors/compiler-errors.factor

@@ -0,0 +1,77 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays sorting assocs colors.constants combinators
+combinators.smart compiler.errors compiler.units fonts kernel
+math.parser math.order models models.arrow namespaces summary ui
+ui.commands ui.gadgets ui.gadgets.tables ui.gadgets.tracks
+ui.gestures ui.operations ui.tools.browser ui.tools.common
+ui.gadgets.scrollers ;
+IN: ui.tools.compiler-errors
+
+TUPLE: error-list-gadget < tool table ;
+
+SINGLETON: error-renderer
+
+M: error-renderer row-columns
+    drop [
+        {
+            [ file>> ]
+            [ line#>> number>string ]
+            [ word>> name>> ]
+            [ error>> summary ]
+        } cleave
+    ] output>array ;
+
+M: error-renderer row-value
+    drop ;
+
+M: error-renderer column-titles
+    drop { "File" "Line" "Word" "Error" } ;
+
+: <error-table> ( model -- table )
+    [ [ [ [ file>> ] [ line#>> ] bi 2array ] compare ] sort ] <arrow>
+    error-renderer <table>
+        [ invoke-primary-operation ] >>action
+        monospace-font >>font
+        COLOR: dark-gray >>column-line-color
+        6 >>gap
+        30 >>min-rows
+        30 >>max-rows
+        80 >>min-cols
+        80 >>max-cols ;
+
+: <error-list-gadget> ( model -- gadget )
+    [ values ] <arrow> vertical error-list-gadget new-track
+        { 3 3 } >>gap
+        swap <error-table> >>table
+        dup table>> <scroller> 1 track-add ;
+
+M: error-list-gadget focusable-child*
+    table>> ;
+
+: error-list-help ( -- ) "ui-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
+    compiler-error-model get-global
+    set-model ;
+
+updater remove-definition-observer
+updater add-definition-observer
+
+: error-list-window ( obj -- )
+    compiler-error-model get-global <error-list-gadget>
+    "Compiler errors" open-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,24 @@ IN: ui.tools.operations
     { +listener+ t }
 } define-operation
 
+! Compiler errors
+: edit-error ( error -- )
+    [ file>> ] [ line#>> ] bi edit-location ;
+
+[ 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 ;
 

core/compiler/errors/errors.factor

@@ -1,21 +1,28 @@
-! 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 ;
+sorting continuations math math.order math.parser accessors
+definitions ;
 IN: compiler.errors
 
 SYMBOL: +error+
 SYMBOL: +warning+
 SYMBOL: +linkage+
 
+TUPLE: compiler-error error word file line# ;
+
 GENERIC: compiler-error-type ( error -- ? )
 
 M: object compiler-error-type drop +error+ ;
 
-GENERIC# compiler-error. 1 ( error word -- )
+M: compiler-error compiler-error-type error>> compiler-error-type ;
+
+GENERIC: compiler-error. ( error -- )
 
 SYMBOL: compiler-errors
 
+compiler-errors [ H{ } clone ] initialize
+
 SYMBOL: with-compiler-errors?
 
 : errors-of-type ( type -- assoc )
@@ -23,9 +30,19 @@ SYMBOL: with-compiler-errors?
     swap [ [ nip compiler-error-type ] dip eq? ] curry
     assoc-filter ;
 
+: sort-compile-errors ( assoc -- alist )
+    [ [ [ line#>> ] compare ] sort ] { } assoc-map-as sort-keys ;
+
+: group-by-source-file ( errors -- assoc )
+    H{ } clone [ [ push-at ] curry [ nip dup file>> ] prepose assoc-each ] keep ;
+
 : compiler-errors. ( type -- )
-    errors-of-type >alist sort-keys
+    errors-of-type group-by-source-file sort-compile-errors
-    [ swap compiler-error. ] assoc-each ;
+    [
+        [ nl "==== " write print nl ]
+        [ [ nl ] [ compiler-error. ] interleave ]
+        bi*
+    ] assoc-each ;
 
 : (compiler-report) ( what type word -- )
     over errors-of-type assoc-empty? [ 3drop ] [
@@ -51,17 +68,17 @@ SYMBOL: with-compiler-errors?
 
 : :linkage ( -- ) +linkage+ compiler-errors. ;
 
+: <compiler-error> ( error word -- compiler-error )
+    dup where [ first2 ] [ "<unknown file>" 0 ] if* \ compiler-error boa ;
+
 : 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.