tabcontrol.icl 2.96 KB
Newer Older
Diederik van Arkel's avatar
Diederik van Arkel committed
1
2
3
4
5
6
7
8
9
10
11
12
implementation module tabcontrol

import StdEnum, StdFunc, StdList
import StdId, StdPSt, StdControl, windowhandle
import Platform

LighterGrey = RGB {r=225,g=225,b=225}
Vellum = RGB {r=200,g=225,b=255}


//--- Tab Control

13
:: TabControl c ls pst = TabControl (c ls pst) RowsOrColumns [ControlAttribute *(ls,pst)]
Diederik van Arkel's avatar
Diederik van Arkel committed
14
15
16
17

instance Controls (TabControl c) | Panes c
where
	getControlType _ = "TabControl"
18
	controlToHandles (TabControl tabs rowsorcols atts) ps
Diederik van Arkel's avatar
Diederik van Arkel committed
19
20
		# (rid,ps)		= openId ps
		# (ts,is,cs,ps)	= getLC tabs True rid ps
21
22
		# (sz,ps)		= controlSize (rdef rowsorcols rid ts is) False (Just (0,0)) (Just (0,0)) Nothing ps
		# (cs`,ps)		= controlToHandles (imp rowsorcols sz rid ts cs is atts) ps
Diederik van Arkel's avatar
Diederik van Arkel committed
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
		= (cs`,ps)

look sz ss us=:{newFrame} pc
	# pc = PlatformDependant pc (setPenBack White pc)
	# pc = PlatformDependant pc (stdUnfillUpdAreaLook ss us pc)

	# pc = setPenColour DarkGrey pc
	# pc = drawLine
			{x=left, y=yoffset}
			{x=right, y=yoffset}
			pc
	# pc = setPenColour LighterGrey pc
	# pc = drawLine
			{x=left, y=yoffset`}
			{x=right, y=yoffset`}
			pc
	# pc = PlatformDependant pc (setPenColour Black pc)
	= pc
where
	left		= newFrame.corner1.x
	right		= newFrame.corner2.x
	yoffset		= sz.h + 5
	yoffset`	= inc yoffset

47
imp rowsorcols sz rid labels panes ids atts
Diederik van Arkel's avatar
Diederik van Arkel committed
48
		= CompoundControl
49
		(	rdef rowsorcols rid labels ids
Diederik van Arkel's avatar
Diederik van Arkel committed
50
51
52
53
		:+:	(Handles panes)
		)
		[ControlLook True (look sz),ControlHMargin 0 0, ControlVMargin 0 0:atts]

54
rdef rowsorcols rid labels ids
Diederik van Arkel's avatar
Diederik van Arkel committed
55
56
57
58
	= RadioControl
		[ (label,Nothing,noLS (switchto x))
		\\	label <- labels
		&	x <- [0..]
59
		] rowsorcols 1 [ControlId rid]
Diederik van Arkel's avatar
Diederik van Arkel committed
60
61
62
63
64
65
where
	switchto x ps
		= appPIO (showControl (ids!!x) o hideControls ids) ps

//--

66
:: Handles ls pst = Handles (pst -> *(*[ControlState ls pst],pst))
Diederik van Arkel's avatar
Diederik van Arkel committed
67
68
69
70
71
72

instance Controls Handles
where
	getControlType _ = "Handles"
	controlToHandles (Handles h) ps = h ps

73
:: Xane ls l :== (PSt l) -> *(*[ControlState ls (PSt l)],(PSt l))
Diederik van Arkel's avatar
Diederik van Arkel committed
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121

class Panes pdef
where
	getLC :: !(pdef .ls (PSt .l)) !Bool !Id !*(PSt .l) -> (![String],![Id],!Xane .ls .l,!*(PSt .l))
	

instance Panes (Pane c) | Controls c
where
	getLC (Pane t c) ini rid ps
		# (i,ps) = openId ps
		# h = controlToHandles (LayoutControl c
					[ ControlId i
					, ControlPos (Below rid,OffsetVector {vx=0,vy=10})
					, ControlHMargin 0 0
					, ControlVMargin 0 0
					: if ini [] [ControlHide]
					])
		= ([t],[i],h,ps)

instance Panes (:+: c1 c2) | Panes c1 & Panes c2
where
	getLC (c1 :+: c2) ini rid ps
		# (t1,i1,h1,ps) = getLC c1 ini rid ps
		# (t2,i2,h2,ps) = getLC c2 False rid ps
		= (t1++t2,i1++i2,hh h1 h2,ps)
	where
		hh h1 h2 ps
			# (hh1,ps) = h1 ps
			# (hh2,ps) = h2 ps
			= (hh1++hh2,ps)
/*
instance Panes (AddLS  c) | Panes c
where
	getLC NilLS ini rid ps = ([],[],[],ps)
instance Panes (NewLS  c) | Panes c
where
	getLC NilLS ini rid ps = ([],[],[],ps)
instance Panes (ListLS c) | Panes c
where
	getLC NilLS ini rid ps = ([],[],[],ps)
instance Panes NilLS
where
	getLC NilLS ini rid ps
		# h = controlToHandles NilLS
		= ([],[],h,ps)
*/

:: Pane c ls pst = Pane String (c ls pst)