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

   1 ! Copyright (C) 2009 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 math.parser init math.order models models.arrow
   7 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.status-bar
  12 ui.gadgets.buttons ui.gadgets.borders ui.gadgets.packs
  13 ui.gadgets.labels 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 column-titles
  53     drop { "" "File" "Errors" } ;
  54
  55 M: source-file-renderer column-alignment drop { 0 0 1 } ;
  56
  57 M: source-file-renderer filled-column drop 1 ;
  58
  59 : <source-file-model> ( model -- model' )
  60     [ group-by-source-file >alist sort-keys ] <arrow> ;
  61
  62 :: <source-file-table> ( error-list -- table )
  63     error-list model>> <source-file-model>
  64     source-file-renderer
  65     <table>
  66         [ invoke-primary-operation ] >>action
  67         COLOR: dark-gray >>column-line-color
  68         6 >>gap
  69         5 >>min-rows
  70         5 >>max-rows
  71         60 >>min-cols
  72         60 >>max-cols
  73         t >>selection-required?
  74         error-list source-file>> >>selected-value ;
  75
  76 SINGLETON: error-renderer
  77
  78 M: error-renderer row-columns
  79     drop [
  80         {
  81             [ error-type error-icon ]
  82             [ line#>> [ number>string ] [ "" ] if* ]
  83             [ asset>> [ unparse-short ] [ "" ] if* ]
  84             [ error>> summary ]
  85         } cleave
  86     ] output>array ;
  87
  88 M: error-renderer prototype-row
  89     drop [ +compiler-error+ error-icon "" "" "" ] output>array ;
  90
  91 M: error-renderer row-value
  92     drop ;
  93
  94 M: error-renderer column-titles
  95     drop { "" "Line" "Asset" "Error" } ;
  96
  97 M: error-renderer column-alignment drop { 0 1 0 0 } ;
  98
  99 : sort-errors ( seq -- seq' )
 100     [ [ [ line#>> ] [ asset>> unparse-short ] bi 2array ] keep ] { } map>assoc
 101     sort-keys values ;
 102
 103 : file-matches? ( error pathname/f -- ? )
 104     [ file>> ] [ dup [ string>> ] when ] bi* = ;
 105
 106 : <error-table-model> ( error-list -- model )
 107     [ model>> ] [ source-file>> ] bi
 108     [ file-matches? ] <search>
 109     [ sort-errors ] <arrow> ;
 110
 111 :: <error-table> ( error-list -- table )
 112     error-list <error-table-model>
 113     error-renderer
 114     <table>
 115         [ invoke-primary-operation ] >>action
 116         COLOR: dark-gray >>column-line-color
 117         6 >>gap
 118         5 >>min-rows
 119         5 >>max-rows
 120         60 >>min-cols
 121         60 >>max-cols
 122         t >>selection-required?
 123         error-list error>> >>selected-value ;
 124
 125 TUPLE: error-display < track ;
 126
 127 : <error-display> ( error-list -- gadget )
 128     vertical error-display new-track
 129         add-toolbar
 130         swap error>> >>model
 131         dup model>> [ [ print-error ] when* ] <pane-control> <scroller> 1 track-add ;
 132
 133 : com-inspect ( error-display -- )
 134     model>> value>> [ inspector ] when* ;
 135
 136 : com-help ( error-display -- )
 137     model>> value>> [ error>> error-help-window ] when* ;
 138
 139 : com-edit ( error-display -- )
 140     model>> value>> [ edit-error ] when* ;
 141
 142 error-display "toolbar" f {
 143     { f com-inspect }
 144     { f com-help }
 145     { f com-edit }
 146 } define-command-map
 147
 148 : <error-list-toolbar> ( error-list -- toolbar )
 149     [ <toolbar> ] [ error-toggle>> "Show errors:" label-on-left add-gadget ] bi ;
 150
 151 : <error-model> ( visible-errors model -- model' )
 152     [ swap '[ error-type _ at ] filter ] <smart-arrow> ;
 153
 154 :: <error-list-gadget> ( model -- gadget )
 155     vertical error-list-gadget new-track
 156         <error-toggle> [ >>error-toggle ] [ >>visible-errors ] bi*
 157         dup visible-errors>> model <error-model> >>model
 158         f <model> >>source-file
 159         f <model> >>error
 160         dup <source-file-table> >>source-file-table
 161         dup <error-table> >>error-table
 162         dup <error-display> >>error-display
 163     :> error-list
 164     error-list vertical <track>
 165         { 5 5 } >>gap
 166         error-list <error-list-toolbar> f track-add
 167         error-list source-file-table>> <scroller> "Source files" <labeled-gadget> 1/4 track-add
 168         error-list error-table>> <scroller> "Errors" <labeled-gadget> 1/2 track-add
 169         error-list error-display>> "Details" <labeled-gadget> 1/4 track-add
 170     { 5 5 } <filled-border> 1 track-add ;
 171
 172 M: error-list-gadget focusable-child*
 173     source-file-table>> ;
 174
 175 : error-list-help ( -- ) "ui.tools.error-list" com-browse ;
 176
 177 \ error-list-help H{ { +nullary+ t } } define-command
 178
 179 error-list-gadget "toolbar" f {
 180     { T{ key-down f f "F1" } error-list-help }
 181 } define-command-map
 182
 183 : error-list-window ( -- )
 184     error-list-model get [ drop all-errors ] <arrow>
 185     <error-list-gadget> "Errors" open-status-window ;
 186
 187 : show-error-list ( -- )
 188     [ error-list-gadget? ] find-window
 189     [ raise-window ] [ error-list-window ] if* ;
 190
 191 \ show-error-list H{ { +nullary+ t } } define-command