Re-organize some error-related code, three-pane look for compiler errors tool, add Joe's icons

basis/debugger/debugger.factor

@@ -309,7 +309,7 @@ M: lexer-error compute-restarts
 M: lexer-error error-help
     error>> error-help ;
 
-M: object compiler-error. ( error -- )
+M: compiler-error compiler-error. ( error -- )
     [
         [
             [
@@ -324,6 +324,8 @@ M: object compiler-error. ( error -- )
         ] bi format nl
     ] [ error>> error. ] bi ;
 
+M: compiler-error error. compiler-error. ;
+
 M: bad-effect summary
     drop "Bad stack effect declaration" ;
 

basis/editors/editors.factor

@@ -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/stack-checker/errors/prettyprint/prettyprint.factor

@@ -1,7 +1,7 @@
-! 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 ;
@@ -11,11 +11,16 @@ 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 ;
 
@@ -27,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
@@ -44,26 +51,31 @@ 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" ;

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/compiler-errors/compiler-errors.factor

@@ -1,14 +1,18 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays sequences sorting assocs colors.constants combinators
+USING: accessors arrays sequences sorting assocs colors.constants
-combinators.smart compiler.errors compiler.units fonts kernel io.pathnames
+combinators combinators.smart combinators.short-circuit editors
-math.parser math.order models models.arrow namespaces summary ui
+compiler.errors compiler.units fonts kernel io.pathnames
-ui.commands ui.gadgets ui.gadgets.tables ui.gadgets.tracks
+stack-checker.errors math.parser math.order models models.arrow
-ui.gestures ui.operations ui.tools.browser ui.tools.common
+models.search debugger namespaces summary locals ui ui.commands
-ui.gadgets.scrollers ;
+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.images ;
 IN: ui.tools.compiler-errors
 
-TUPLE: error-list-gadget < tool table ;
+TUPLE: error-list-gadget < tool source-file error source-file-table error-table error-display ;
 
 SINGLETON: source-file-renderer
 
@@ -16,60 +20,133 @@ M: source-file-renderer row-columns
     drop [ first2 length number>string 2array ] [ { "All" "" } ] if* ;
 
 M: source-file-renderer row-value
-    drop first <pathname> ;
+    drop dup [ first <pathname> ] when ;
 
 M: source-file-renderer column-titles
     drop { "File" "Errors" } ;
 
-: <source-file-table> ( model -- table )
+M: source-file-renderer column-alignment drop { 0 1 } ;
-    [ group-by-source-file >alist sort-keys f prefix ] <arrow>
+
-    source-file-renderer <table>
+M: source-file-renderer filled-column drop 0 ;
+
+: <source-file-model> ( model -- model' )
+    [ group-by-source-file >alist sort-keys f prefix ] <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
-        { 1 f } >>column-widths
         6 >>gap
         30 >>min-rows
         30 >>max-rows
-        80 >>min-cols
+        60 >>min-cols
-        80 >>max-cols ;
+        60 >>max-cols
+        t >>selection-required?
+        error-list source-file>> >>selected-value ;
 
 SINGLETON: error-renderer
 
+GENERIC: error-icon ( error -- icon )
+
+: <error-icon> ( name -- image-name )
+    "vocab:ui/tools/error-list/icons/" ".tiff" surround <image-name> ;
+
+M: inference-error error-icon
+    type>> {
+        { +error+ [ "compiler-error" ] }
+        { +warning+ [ "compiler-warning" ] }
+    } case <error-icon> ;
+
+M: object error-icon drop "HAI" ;
+
+M: compiler-error error-icon error>> error-icon ;
+
 M: error-renderer row-columns
     drop [
         {
-            [ file>> ]
+            [ error-icon ]
             [ line#>> number>string ]
             [ word>> name>> ]
             [ 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 { "File" "Line" "Word" "Error" } ;
+    drop { "" "Line" "Word" "Error" } ;
 
-: <error-table> ( model -- table )
+M: error-renderer column-alignment drop { 0 1 0 0 } ;
-    [ [ [ [ file>> ] [ line#>> ] bi 2array ] compare ] sort ] <arrow>
+
-    error-renderer <table>
+: sort-errors ( seq -- seq' )
+    [ [ [ file>> ] [ line#>> ] bi 2array ] compare ] sort ;
+
+: <error-table-model> ( error-list -- model )
+    [ model>> [ values ] <arrow> ] [ source-file>> ] bi
+    [ swap { [ drop not ] [ [ string>> ] [ file>> ] bi* = ] } 2|| ] <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
-        80 >>min-cols
+        60 >>min-cols
-        80 >>max-cols ;
+        60 >>max-cols
+        t >>selection-required?
+        error-list error>> >>selected-value ;
 
-: <error-list-gadget> ( model -- gadget )
+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-gadget> ( model -- gadget )
     vertical error-list-gadget new-track
-        { 3 3 } >>gap
+        model >>model
-        swap <source-file-table> >>table
+        f <model> >>source-file
-        dup table>> <scroller> 1/2 track-add ;
+        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 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*
-    table>> ;
+    source-file-table>> ;
 
 : error-list-help ( -- ) "ui-error-list" com-browse ;
 
@@ -96,4 +173,4 @@ updater add-definition-observer
 
 : error-list-window ( -- )
     compiler-error-model get-global <error-list-gadget>
-    "Compiler errors" open-window ;
+    "Compiler errors" open-status-window ;

basis/ui/tools/debugger/debugger.factor

@@ -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/operations/operations.factor

@@ -87,9 +87,6 @@ IN: ui.tools.operations
 } define-operation
 
 ! Compiler errors
-: edit-error ( error -- )
-    [ file>> ] [ line#>> ] bi edit-location ;
-
 [ compiler-error? ] \ edit-error H{
     { +primary+ t }
     { +secondary+ t }
@@ -191,4 +188,4 @@ interactor
 "These commands operate on the entire contents of the input area."
 [ ]
 [ quot-action ]
-define-operation-map
+define-operation-map