basis/ui/gadgets/panes/panes-tests.factor

   1 USING: accessors colors fonts fry help help.markup help.stylesheet
   2 help.syntax help.topics inspector io io.streams.string io.styles
   3 kernel literals math models namespaces prettyprint see sequences
   4 tools.test ui.gadgets ui.gadgets.debug ui.gadgets.panes
   5 ui.gadgets.panes.private ui.theme ;
   6 IN: ui.gadgets.panes.tests
   7
   8 : #children ( -- n ) "pane" get children>> length ;
   9
  10 { } [ <pane> "pane" set ] unit-test
  11
  12 { } [ #children "num-children" set ] unit-test
  13
  14 { } [
  15     "pane" get <pane-stream> [ 100 [ . ] each-integer ] with-output-stream*
  16 ] unit-test
  17
  18 { t } [ #children "num-children" get = ] unit-test
  19
  20 : test-gadget-text ( quot -- ? )
  21     '[ _ call( -- ) ]
  22     [ make-pane gadget-text dup print "======" print ]
  23     [ with-string-writer dup print ] bi = ;
  24
  25 { t } [ [ "hello" write ] test-gadget-text ] unit-test
  26 { t } [ [ "hello" pprint ] test-gadget-text ] unit-test
  27 { t } [
  28     [
  29         H{ { wrap-margin 100 } } [ "hello" pprint ] with-nesting
  30     ] test-gadget-text
  31 ] unit-test
  32 { t } [
  33     [
  34         H{ { wrap-margin 100 } } [
  35             H{ } [
  36                 "hello" pprint
  37             ] with-style
  38         ] with-nesting
  39     ] test-gadget-text
  40 ] unit-test
  41 { t } [ [ [ 1 2 3 ] pprint ] test-gadget-text ] unit-test
  42 { t } [ [ \ + describe ] test-gadget-text ] unit-test
  43 { t } [ [ \ = see ] test-gadget-text ] unit-test
  44 { t } [ [ \ = print-topic ] test-gadget-text ] unit-test
  45
  46 { t } [
  47     [
  48         title-style get [
  49                 "Hello world" write
  50         ] with-style
  51     ] test-gadget-text
  52 ] unit-test
  53
  54
  55 { t } [
  56     [
  57         title-style get [
  58                 "Hello world" write
  59         ] with-nesting
  60     ] test-gadget-text
  61 ] unit-test
  62
  63 { t } [
  64     [
  65         title-style get [
  66             title-style get [
  67                 "Hello world" write
  68             ] with-nesting
  69         ] with-style
  70     ] test-gadget-text
  71 ] unit-test
  72
  73 { t } [
  74     [
  75         title-style get [
  76             title-style get [
  77                 [ "Hello world" write ] ($block)
  78             ] with-nesting
  79         ] with-style
  80     ] test-gadget-text
  81 ] unit-test
  82
  83 { t } [
  84     [
  85         last-element off
  86         \ = >link $title
  87         "Hello world" print-content
  88     ] test-gadget-text
  89 ] unit-test
  90
  91 { t } [
  92     [ { { "a\n" } } simple-table. ] test-gadget-text
  93 ] unit-test
  94
  95 { t } [
  96     [ { { "a" } } simple-table. "x" write ] test-gadget-text
  97 ] unit-test
  98
  99 { t } [
 100     [ H{ } [ { { "a" } } simple-table. ] with-nesting "x" write ] test-gadget-text
 101 ] unit-test
 102
 103 ARTICLE: "test-article-1" "This is a test article"
 104 "Hello world, how are you today." ;
 105
 106 { t } [ [ "test-article-1" $title ] test-gadget-text ] unit-test
 107
 108 { t } [ [ "test-article-1" print-topic ] test-gadget-text ] unit-test
 109
 110 ARTICLE: "test-article-2" "This is a test article"
 111 "Hello world, how are you today."
 112 { $table { "a" "b" } { "c" "d" } } ;
 113
 114 { t } [ [ "test-article-2" print-topic ] test-gadget-text ] unit-test
 115
 116 <pane> [ \ = see ] with-pane
 117 <pane> [ \ = print-topic ] with-pane
 118
 119 { } [
 120     \ = <model> [ see ] <pane-control> [ ] with-grafted-gadget
 121 ] unit-test
 122
 123 : <test-pane> ( -- foo )
 124     <gadget> pane new-pane ;
 125
 126 { t } [ <test-pane> dup input>> child? ] unit-test
 127 { t } [ <test-pane> dup last-line>> child? ] unit-test
 128
 129 ! smash-line
 130 ${
 131     ""
 132     T{ font
 133         { name $[ default-sans-serif-font-name ] }
 134         { size $[ default-font-size ] }
 135         { foreground $[ text-color ] }
 136         { background $[ content-background ] }
 137     }
 138 } [
 139     <pane> dup current>> smash-line [ text>> ] [ font>> ] bi
 140 ] unit-test