Ticket #309: setscrollbug.2.hs

File setscrollbug.2.hs, 1.6 KB (added by brassel, 9 years ago)
Line 
1-- The gui defined by this program does not behave as expected:
2-- when starting the program, both sliders do nothing but print the
3-- message "old scrollfunction" in the shell.
4-- This should be changed by clicking anywhere within the window.
5-- But the change affects the horizontal scrollbar only, the vertical
6-- one keeps printing the message.
7
8import Graphics.UI.ObjectIO
9import Debug.Trace
10
11main = do cid <- openId
12          startIO SDI () (openWindow undefined (theWindow cid)) [ProcessClose closeProcess]
13
14theWindow cid = Window "Click should change scroll function" 
15                  (CompoundControl NilLS 
16                              [ ControlOuterSize size,
17                        ControlViewDomain (Rectangle zero $ Point2 10000 10000),
18                        ControlMouse (const True) Able 
19                          (noLS1 mouseEvent),
20                        ControlHScroll oldSlide,
21                        ControlVScroll oldSlide,
22                        ControlId cid])
23                  [WindowViewSize size]
24    where                 
25      size = Size width height
26      width = 300
27      height = 360
28      mouseEvent (MouseUp p _) ps = do
29                   setControlScrollFunction cid Horizontal slide
30                   setControlScrollFunction cid Vertical slide
31                   return ps
32      mouseEvent _ ps = return ps
33
34oldSlide _ _ _ = trace "old scrollfunction" 42
35
36slide viewFrame (SliderState{sliderThumb=st}) state
37      =  case state of 
38         SliderThumb i  -> i
39         SliderIncSmall -> st+20 
40         SliderDecSmall -> st-20
41         SliderIncLarge -> st+100
42         SliderDecLarge -> st-100