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