basis/ui/gadgets/debug/debug.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays colors.constants dlists io io.streams.string
   4 kernel namespaces opengl sequences ui ui.baseline-alignment ui.gadgets
   5 ui.gadgets.buttons ui.gadgets.labels ui.gadgets.private ui.pens
   6 ui.render ui.text vectors ;
   7 IN: ui.gadgets.debug
   8
   9 ! We can't print to output-stream here because that might be a pane
  10 ! stream, and our graft-queue rebinding here would be captured
  11 ! by code adding children to the pane...
  12 : with-grafted-gadget ( gadget quot -- )
  13     [
  14         <dlist> \ graft-queue set
  15         100 <vector> \ layout-queue set
  16         over
  17         graft notify-queued
  18         dip
  19         ungraft notify-queued
  20     ] with-string-writer print ; inline
  21
  22 TUPLE: baseline-gadget < gadget baseline cap-height ;
  23
  24 M: baseline-gadget baseline baseline>> ;
  25
  26 M: baseline-gadget cap-height cap-height>> ;
  27
  28 : <baseline-gadget> ( baseline cap-height dim -- gadget )
  29     baseline-gadget new
  30         swap >>dim
  31         swap >>cap-height
  32         swap >>baseline ;
  33
  34 ! An intentionally broken gadget -- used to test UI error handling,
  35 ! make sure that one bad gadget doesn't bring the whole system down
  36
  37 : <bad-button> ( -- button )
  38     "Click me if you dare"
  39     [ "Haha" throw ]
  40     <border-button> ;
  41
  42 TUPLE: bad-gadget < gadget ;
  43
  44 M: bad-gadget draw-gadget* "Lulz" throw ;
  45
  46 M: bad-gadget pref-dim* drop { 100 100 } ;
  47
  48 : <bad-gadget> ( -- gadget ) bad-gadget new ;
  49
  50 : bad-gadget-test ( -- )
  51     <bad-button> "Test 1" open-window
  52     <bad-gadget> "Test 2" open-window ;
  53
  54 SINGLETON: metrics-paint
  55
  56 M: metrics-paint draw-boundary
  57     drop
  58     COLOR: red gl-color
  59     [ dim>> ] [ >label< line-metrics ] bi
  60     [ [ first ] [ ascent>> ] bi* [ nip 0 swap 2array ] [ 2array ] 2bi gl-line ]
  61     [ drop { 0 0 } swap gl-rect ]
  62     2bi ;
  63
  64 : <metrics-gadget> ( text font -- gadget )
  65     [ <label> ] dip >>font metrics-paint >>boundary ;