Messages tool

TODO.FACTOR.txt

@@ -15,12 +15,8 @@
 - more compact relocation info
 - problem if major gc happens during relocation
   - in fact relocation should not cons at all
-- better way of dealing with compiler errors
-  - messages tool
-    - sort into warnings and errors
-    - quick way to navigate to offending word
 - variable width word wrap
-  - 
+  - needs layout tricks
 - add-gadget, model-changed, set-model should compile
 - graphical module manager tool
   - list of modules -- loaded, not loaded

library/compiler/compiler.factor

@@ -5,6 +5,24 @@ USING: errors generic hashtables inference io kernel math
 namespaces optimizer parser prettyprint sequences test threads
 words ;
 
+SYMBOL: batch-errors
+
+GENERIC: batch-begins ( batch-errors -- )
+
+M: f batch-begins drop ;
+
+GENERIC: compile-begins ( word batch-errors -- )
+
+M: f compile-begins drop "Compiling " write . flush ;
+
+GENERIC: compile-error ( error batch-errors -- )
+
+M: f compile-error drop error. flush ;
+
+GENERIC: batch-ends ( batch-errors -- )
+
+M: f batch-ends drop ;
+
 : word-dataflow ( word -- dataflow )
     [
         dup ?no-effect
@@ -15,7 +33,7 @@ words ;
 
 : (compile) ( word -- )
     dup compiling? not over compound? and [
-        "Compiling " write dup . flush
+        dup batch-errors get compile-begins
         dup word-dataflow optimize generate
     ] [
         drop
@@ -25,12 +43,21 @@ words ;
     [ (compile) ] with-compiler ;
 
 : try-compile ( word -- )
-    [ compile ] [ error. flush update-xt ] recover ;
+    [
+        compile
+    ] [
+        batch-errors get compile-error update-xt
+    ] recover ;
+
+: compile-batch ( seq -- )
+    batch-errors get batch-begins
+    dup
+    [ f "no-effect" set-word-prop ] each
+    [ try-compile ] each
+    batch-errors get batch-ends ;
 
 : compile-vocabs ( seq -- )
-    [ words ] map concat
-    dup [ f "no-effect" set-word-prop ] each
-    [ try-compile ] each ;
+    [ words ] map concat compile-batch ;
 
 : compile-all ( -- )
     vocabs compile-vocabs changed-words get clear-hash ;
@@ -42,7 +69,7 @@ words ;
 
 : recompile ( -- )
     changed-words get [
-        dup hash-keys [ try-compile ] each clear-hash
+        dup hash-keys compile-batch clear-hash
     ] when* ;
 
 [ recompile ] parse-hook set

library/compiler/inference/errors.factor

@@ -2,9 +2,9 @@ IN: inference
 USING: kernel generic errors sequences prettyprint io words ;
 
 M: inference-error error.
-    dup delegate error.
-    "Nesting: " write
-    inference-error-rstate [ first ] map . ;
+    dup inference-error-rstate [ first ] map
+    dup empty? [ "Word: " write dup peek . ] unless
+    swap delegate error. "Nesting: " write . ;
 
 M: inference-error error-help drop f ;
 

library/compiler/inference/inference.factor

@@ -5,19 +5,23 @@ USING: arrays errors generic io kernel
 math namespaces parser prettyprint sequences strings
 vectors words ;
 
-TUPLE: inference-error rstate ;
+TUPLE: inference-error rstate major? ;
 
-C: inference-error ( msg rstate -- error )
+C: inference-error ( msg rstate important? -- error )
+    [ set-inference-error-major? ] keep
     [ set-inference-error-rstate ] keep
     [ set-delegate ] keep ;
 
 : inference-error ( msg -- * )
-    recursive-state get <inference-error> throw ;
+    recursive-state get t <inference-error> throw ;
+
+: inference-warning ( msg -- * )
+    recursive-state get f <inference-error> throw ;
 
 TUPLE: literal-expected ;
 
 M: object value-literal
-    <literal-expected> inference-error ;
+    <literal-expected> inference-warning ;
 
 : pop-literal ( -- rstate obj )
     1 #drop node,

library/compiler/inference/words.factor

@@ -34,7 +34,7 @@ IN: inference
 TUPLE: no-effect word ;
 
 : no-effect ( word -- * )
-    <no-effect> inference-error ;
+    <no-effect> inference-warning ;
 
 : nest-node ( -- ) #entry node, ;
 

library/ui/load.factor

@@ -37,6 +37,7 @@ PROVIDE: library/ui {
     "gadgets/presentations.factor"
     "ui.factor"
     "tools/tools.factor"
+    "tools/messages.factor"
     "tools/listener.factor"
     "tools/walker.factor"
     "tools/search.factor"

library/ui/tools/listener.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: gadgets-listener
-USING: arrays gadgets gadgets-frames gadgets-labels
+USING: compiler arrays gadgets gadgets-frames gadgets-labels
 gadgets-panes gadgets-scrolling gadgets-text gadgets-theme
 gadgets-tracks gadgets-workspace generic hashtables tools io
 kernel listener math models namespaces parser prettyprint
@@ -16,24 +16,6 @@ TUPLE: listener-gadget input output stack ;
     dup listener-gadget-input swap listener-gadget-output
     <duplex-stream> ;
 
-: listener-thread ( listener -- )
-    dup listener-stream [
-        [ ui-listener-hook ] curry listener-hook set tty
-    ] with-stream* ;
-
-: start-listener ( listener -- )
-    [ >r clear r> init-namespaces listener-thread ] in-thread
-    drop ;
-
-: <labelled-gadget> ( gadget title -- gadget )
-    {
-        { [ <label> dup reverse-video-theme ] f f @top }
-        { [ ] f f @center }
-    } make-frame ;
-
-: <labelled-pane> ( model quot title -- gadget )
-    >r <pane-control> <scroller> r> <labelled-gadget> ;
-
 : <listener-input> ( -- gadget )
     gadget get listener-gadget-output <interactor> ;
 
@@ -44,12 +26,23 @@ TUPLE: listener-gadget input output stack ;
 : init-listener ( listener -- )
     f <model> swap set-listener-gadget-stack ;
 
+: listener-thread ( listener -- )
+    dup listener-stream [
+        [ ui-listener-hook ] curry listener-hook set
+        find-messages batch-errors set
+        tty
+    ] with-stream* ;
+
+: start-listener ( listener -- )
+    [ >r clear r> init-namespaces listener-thread ] in-thread
+    drop ;
+
 C: listener-gadget ( -- gadget )
     dup init-listener {
         { [ <scrolling-pane> ] set-listener-gadget-output [ <scroller> ] 4/6 }
         { [ <stack-display> ] f f 1/6 }
         { [ <listener-input> ] set-listener-gadget-input [ <scroller> "Input" <labelled-gadget> ] 1/6 }
-    } { 0 1 } make-track* dup start-listener ;
+    } { 0 1 } make-track* ;
 
 M: listener-gadget focusable-child*
     listener-gadget-input ;

library/ui/tools/messages.factor

@@ -0,0 +1,50 @@
+! Copyright (C) 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: compiler kernel gadgets-tracks gadgets-scrolling
+gadgets-workspace gadgets-panes gadgets-presentations
+gadgets-buttons inference errors io math gadgets namespaces ;
+IN: gadgets-messages
+
+TUPLE: messages counter errors errors# warnings warnings# ;
+
+M: messages batch-begins
+    0 over set-messages-errors#
+    0 over set-messages-warnings#
+    dup messages-errors pane-clear
+    messages-warnings pane-clear ;
+
+M: messages compile-begins
+    2drop ;
+
+M: messages compile-error
+    over inference-error-major? [
+        dup messages-errors# 1+ over set-messages-errors#
+        messages-errors
+    ] [
+        dup messages-warnings# 1+ over set-messages-warnings#
+        messages-warnings
+    ] if [ error. ] with-stream ;
+
+: <messages-button> ( -- gadget )
+    "Compiler messages"
+    [ drop find-workspace messages select-tool ]
+    <bevel-button> ;
+
+M: messages batch-ends
+    [
+        dup messages-errors# # " compiler error(s), " %
+        messages-warnings# # " compiler warning(s)" %
+    ] "" make print
+    <messages-button> gadget. ;
+
+: <errors> ( gadget -- newgadget )
+    <scroller> "Compiler errors" <labelled-gadget> ;
+
+: <warnings> ( gadget -- newgadget )
+    <scroller> "Compiler warnings" <labelled-gadget> ;
+
+C: messages ( -- gadget )
+    {
+        { [ <pane> ] set-messages-errors [ <errors> ] 1/2 }
+        { [ <pane> ] set-messages-warnings [ <warnings> ] 1/2 }
+    } { 0 1 } make-track* dup batch-begins ;

library/ui/tools/tools.factor

@@ -1,8 +1,12 @@
 ! Copyright (C) 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+IN: gadgets-messages
+DEFER: messages
+
 IN: gadgets-workspace
 USING: gadgets gadgets-books gadgets-controls gadgets-workspace
-generic kernel models scratchpad sequences syntax ;
+generic kernel models scratchpad sequences syntax
+gadgets-messages ;
 
 DEFER: workspace-window
 
@@ -20,10 +24,11 @@ TUPLE: workspace ;
 
 TUPLE: tool gadget ;
 
+: find-tool ( class workspace -- index tool )
+    gadget-children [ tool-gadget class eq? ] find-with ;
+
 : show-tool ( class workspace -- tool )
-    [
-        gadget-children [ tool-gadget class eq? ] find-with swap
-    ] keep control-model set-model* ;
+    [ find-tool swap ] keep control-model set-model* ;
 
 : select-tool ( workspace class -- ) swap show-tool drop ;
 
@@ -33,3 +38,8 @@ TUPLE: tool gadget ;
 
 : call-tool ( arg class -- )
     find-workspace show-tool call-tool* ;
+
+: get-tool ( class -- gadget )
+    find-workspace find-tool nip tool-gadget ;
+
+: find-messages ( -- gadget ) messages get-tool ;

library/ui/tools/workspace.factor

@@ -7,7 +7,7 @@ gadgets-dataflow gadgets-frames gadgets-grids gadgets-help
 gadgets-listener gadgets-presentations gadgets-walker
 gadgets-workspace generic kernel math modules scratchpad
 sequences syntax words io namespaces hashtables
-gadgets-scrolling gadgets-panes ;
+gadgets-scrolling gadgets-panes gadgets-messages ;
 
 C: tool ( gadget -- tool )
     {
@@ -37,6 +37,7 @@ tool "Tool commands" {
 : workspace-tabs
     {
         { "Listener" <listener-gadget> }
+        { "Messages" <messages> }
         { "Definitions" <browser> } 
         { "Documentation" <help-gadget> }
         { "Walker" <walker-gadget> }
@@ -64,7 +65,8 @@ M: workspace pref-dim* delegate pref-dim* { 550 650 } vmax ;
     <workspace> dup <world>
     [ init-status ] keep
     [ init-tabs ] keep
-    open-window ;
+    open-window
+    listener-gadget get-tool start-listener ;
 
 : tool-window ( class -- ) workspace-window show-tool drop ;
 
@@ -81,10 +83,11 @@ workspace "Scrolling primary pane" {
 
 workspace "Tool switching commands" {
     { "Listener" T{ key-down f f "F2" } [ listener-gadget select-tool ] }
-    { "Definitions" T{ key-down f f "F3" } [ browser select-tool ] }
-    { "Documentation" T{ key-down f f "F4" } [ help-gadget select-tool ] }
-    { "Walker" T{ key-down f f "F5" } [ walker-gadget select-tool ] }
-    { "Dataflow" T{ key-down f f "F6" } [ dataflow-gadget select-tool ] }
+    { "Messages" T{ key-down f f "F3" } [ listener-gadget select-tool ] }
+    { "Definitions" T{ key-down f f "F4" } [ browser select-tool ] }
+    { "Documentation" T{ key-down f f "F5" } [ help-gadget select-tool ] }
+    { "Walker" T{ key-down f f "F6" } [ walker-gadget select-tool ] }
+    { "Dataflow" T{ key-down f f "F7" } [ dataflow-gadget select-tool ] }
 } define-commands
 
 workspace "Tool window commands" {
@@ -94,6 +97,6 @@ workspace "Tool window commands" {
 } define-commands
 
 workspace "Workflow commands" {
-    { "Reload changed sources" T{ key-down f f "F7" } [ drop [ reload-modules ] listener-gadget call-tool ] }
-    { "Recompile changed words" T{ key-down f f "F8" } [ drop [ recompile ] listener-gadget call-tool ] }
+    { "Reload changed sources" T{ key-down f f "F8" } [ drop [ reload-modules ] listener-gadget call-tool ] }
+    { "Recompile changed words" T{ key-down f { S+ } "F8" } [ drop [ recompile ] listener-gadget call-tool ] }
 } define-commands

library/ui/ui.factor

@@ -142,6 +142,15 @@ C: titled-gadget ( gadget title -- )
 : $commands ( elt -- )
     dup array? [ first ] when commands commands. ;
 
+: <labelled-gadget> ( gadget title -- gadget )
+    {
+        { [ <label> dup reverse-video-theme ] f f @top }
+        { [ ] f f @center }
+    } make-frame ;
+
+: <labelled-pane> ( model quot title -- gadget )
+    >r <pane-control> <scroller> r> <labelled-gadget> ;
+
 : pane-window ( quot title -- )
     >r make-pane <scroller> r> open-titled-window ;