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

   1 ! Copyright (C) 2009, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs calendar colors.constants
   4 combinators combinators.smart compiler.errors debugger editors
   5 init io.pathnames kernel math.parser models models.arrow
   6 models.arrow.smart models.delay models.mapping models.search
   7 namespaces prettyprint sequences sorting source-files.errors
   8 source-files.errors.debugger summary ui ui.commands ui.gadgets
   9 ui.gadgets.buttons ui.gadgets.labeled ui.gadgets.labels
  10 ui.gadgets.packs ui.gadgets.panes ui.gadgets.scrollers
  11 ui.gadgets.status-bar ui.gadgets.tables ui.gadgets.toolbar
  12 ui.gadgets.tracks ui.gestures ui.images ui.operations ui.theme
  13 ui.tools.browser ui.tools.common ui.tools.inspector ;
  14 IN: ui.tools.error-list
  15
  16 CONSTANT: source-file-icon
  17     T{ image-name f "vocab:ui/tools/error-list/icons/source-file.png" }
  18
  19 MEMO: error-icon ( type -- image-name )
  20     error-icon-path <image-name> ;
  21
  22 : <checkboxes> ( alist -- gadget )
  23     [ <shelf> { 15 0 } >>gap ] dip
  24     [ swap <checkbox> add-gadget ] assoc-each ;
  25
  26 : <error-toggle> ( -- model gadget )
  27     ! Linkage errors are not shown by default.
  28     error-types get [ fatal?>> <model> ] assoc-map
  29     [ [ [ error-icon ] dip ] assoc-map <checkboxes> ]
  30     [ <mapping> ] bi ;
  31
  32 TUPLE: error-list-gadget < tool
  33 visible-errors source-file error
  34 error-toggle source-file-table error-table error-display ;
  35
  36 SINGLETON: source-file-renderer
  37
  38 M: source-file-renderer row-columns
  39     drop first2 [
  40         [ source-file-icon ]
  41         [ +listener-input+ or ]
  42         [ length number>string ] tri*
  43     ] output>array ;
  44
  45 M: source-file-renderer prototype-row
  46     drop source-file-icon "" "" 3array ;
  47
  48 M: source-file-renderer row-value
  49     drop dup [ first [ <pathname> ] [ f ] if* ] when ;
  50
  51 M: source-file-renderer row-value? row-value = ;
  52
  53 M: source-file-renderer column-titles
  54     drop { "" "File" "Errors" } ;
  55
  56 M: source-file-renderer column-alignment drop { 0 0 1 } ;
  57
  58 M: source-file-renderer filled-column drop 1 ;
  59
  60 : <source-file-model> ( model -- model' )
  61     [ group-by-source-file sort-keys ] <arrow> ;
  62
  63 :: <source-file-table> ( error-list -- table )
  64     error-list model>> <source-file-model>
  65     source-file-renderer
  66     <table>
  67         [ invoke-primary-operation ] >>action
  68         COLOR: dark-gray >>column-line-color
  69         6 >>gap
  70         4 >>min-rows
  71         4 >>max-rows
  72         60 >>min-cols
  73         60 >>max-cols
  74         t >>selection-required?
  75         error-list source-file>> >>selection ;
  76
  77 SINGLETON: error-renderer
  78
  79 M: error-renderer row-columns
  80     drop [
  81         {
  82             [ error-type error-icon ]
  83             [ line#>> [ number>string ] [ "" ] if* ]
  84             [ asset>> [ unparse-short ] [ "" ] if* ]
  85             [ error>> safe-summary ]
  86         } cleave
  87     ] output>array ;
  88
  89 M: error-renderer prototype-row
  90     drop [ +compiler-error+ error-icon "" "" "" ] output>array ;
  91
  92 M: error-renderer row-value
  93     drop ;
  94
  95 M: error-renderer column-titles
  96     drop { "" "Line" "Asset" "Error" } ;
  97
  98 M: error-renderer column-alignment drop { 0 1 0 0 } ;
  99
 100 : sort-errors ( seq -- seq' )
 101     [ [ [ line#>> 0 or ] [ asset>> unparse-short ] bi 2array ] keep ] { } map>assoc
 102     sort-keys values ;
 103
 104 : file-matches? ( error pathname/f -- ? )
 105     [ path>> ] [ dup [ string>> ] when ] bi* = ;
 106
 107 : <error-table-model> ( error-list -- model )
 108     [ model>> ] [ source-file>> ] bi
 109     [ file-matches? ] <search>
 110     [ sort-errors ] <arrow> ;
 111
 112 :: <error-table> ( error-list -- table )
 113     error-list <error-table-model>
 114     error-renderer
 115     <table>
 116         [ invoke-primary-operation ] >>action
 117         COLOR: dark-gray >>column-line-color
 118         6 >>gap
 119         4 >>min-rows
 120         4 >>max-rows
 121         60 >>min-cols
 122         60 >>max-cols
 123         t >>selection-required?
 124         error-list error>> >>selection ;
 125
 126 TUPLE: error-display < track ;
 127
 128 : <error-display> ( error-list -- gadget )
 129     vertical error-display new-track with-lines
 130         swap error>> >>model
 131         dup model>> [ [ print-error ] when* ] <pane-control>
 132         margins <scroller> white-interior 1 track-add
 133         add-toolbar ;
 134
 135 : com-inspect ( error-display -- )
 136     control-value [ inspector ] when* ;
 137
 138 : com-help ( error-display -- )
 139     control-value [ error>> error-help-window ] when* ;
 140
 141 : com-edit ( error-display -- )
 142     control-value [ edit-error ] when* ;
 143
 144 error-display "toolbar" f {
 145     { f com-inspect }
 146     { f com-help }
 147     { f com-edit }
 148 } define-command-map
 149
 150 : <error-list-toolbar> ( error-list -- toolbar )
 151     [ <toolbar> ] [ error-toggle>> "Show errors:" label-on-left f track-add ] bi
 152     format-toolbar ;
 153
 154 : <error-model> ( visible-errors model -- model' )
 155     [ swap '[ error-type _ at ] filter ] <smart-arrow> ;
 156
 157 :: <error-list-gadget> ( model -- gadget )
 158     vertical error-list-gadget new-track
 159         <error-toggle> [ >>error-toggle ] [ >>visible-errors ] bi*
 160         dup visible-errors>> model <error-model> >>model
 161         f <model> >>source-file
 162         f <model> >>error
 163         dup <source-file-table> >>source-file-table
 164         dup <error-table> >>error-table
 165         dup <error-display> >>error-display
 166     :> error-list
 167     error-list vertical <track> with-lines
 168         error-list <error-list-toolbar> f track-add
 169         error-list source-file-table>> margins <scroller> white-interior
 170         "Source files" source-files-color <colored-labeled-gadget> 1/4 track-add
 171         error-list error-table>> margins <scroller> white-interior
 172         "Errors" errors-color <colored-labeled-gadget> 1/4 track-add
 173         error-list error-display>>
 174         "Details" details-color <colored-labeled-gadget> 1/2 track-add
 175     1 track-add ;
 176
 177 M: error-list-gadget focusable-child*
 178     source-file-table>> ;
 179
 180 SYMBOLS: error-list-model ;
 181
 182 SINGLETON: error-list-updater
 183
 184 M: error-list-updater errors-changed
 185     drop f error-list-model get-global model>> set-model ;
 186
 187 : error-list-help ( -- ) "ui.tools.error-list" com-browse ;
 188
 189 \ error-list-help H{ { +nullary+ t } } define-command
 190
 191 \ error-list-gadget "toolbar" f {
 192     { T{ key-down f f "F1" } error-list-help }
 193 } define-command-map
 194
 195 : error-list-window ( -- )
 196     error-list-model get-global [ drop all-errors ] <arrow>
 197     <error-list-gadget> "Errors" open-status-window ;
 198
 199 : show-error-list ( -- )
 200     [ error-list-gadget? ] find-window
 201     [ raise-window ] [ error-list-window ] if* ;
 202
 203 \ show-error-list H{ { +nullary+ t } } define-command
 204
 205 [
 206     f <model> 100 milliseconds <delay> error-list-model set-global
 207     error-list-updater add-error-observer
 208 ] "ui.tools.error-list" add-startup-hook