core/ui/tools/messages.factor

   1 ! Copyright (C) 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: compiler kernel gadgets-tracks gadgets-scrolling
   4 gadgets-workspace gadgets-panes gadgets-presentations
   5 gadgets-buttons inference errors io math gadgets namespaces
   6 generic ;
   7 IN: gadgets-messages
   8
   9 TUPLE: messages counter errors errors# warnings warnings# ;
  10
  11 M: messages batch-begins
  12     0 over set-messages-errors#
  13     0 over set-messages-warnings#
  14     dup messages-errors pane-clear
  15     messages-warnings pane-clear ;
  16
  17 M: messages compile-begins
  18     2drop ;
  19
  20 : messages-errors+
  21     dup messages-errors# 1+ swap set-messages-errors# ;
  22
  23 : messages-warnings+
  24     dup messages-warnings# 1+ swap set-messages-warnings# ;
  25
  26 M: object inference-error-major? drop t ;
  27
  28 M: messages compile-error
  29     over inference-error-major?
  30     [ dup messages-errors+ messages-errors ]
  31     [ dup messages-warnings+ messages-warnings ] if
  32     <pane-stream> [ error. ] with-stream ;
  33
  34 : <messages-button> ( -- gadget )
  35     "Compiler messages"
  36     [ find-workspace messages select-tool ]
  37     <bevel-button> ;
  38
  39 M: messages batch-ends
  40     [
  41         dup messages-errors# # " compiler error(s), " %
  42         messages-warnings# # " compiler warning(s)" %
  43     ] "" make print
  44     <messages-button> gadget. ;
  45
  46 : <errors> ( gadget -- newgadget )
  47     <scroller> "Compiler errors" <labelled-gadget> ;
  48
  49 : <warnings> ( gadget -- newgadget )
  50     <scroller> "Compiler warnings" <labelled-gadget> ;
  51
  52 C: messages ( -- gadget )
  53     {
  54         { [ <pane> ] set-messages-errors [ <errors> ] 1/2 }
  55         { [ <pane> ] set-messages-warnings [ <warnings> ] 1/2 }
  56     } { 0 1 } make-track* dup batch-begins ;