ioutil.icl 7.16 KB
Newer Older
Diederik van Arkel's avatar
Diederik van Arkel committed
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
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
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
implementation module ioutil

import StdBool,StdList,StdFile
import StdControl,StdPSt,StdFileSelect
import iostate

altScrollFunction :: !Direction !Int -> ScrollFunction
altScrollFunction direction d
	= altScrollFunction` direction d
where
	altScrollFunction` :: !Direction !Int !ViewFrame !SliderState !SliderMove -> Int
	altScrollFunction` direction d {corner1,corner2} {sliderThumb=x} move
		# d				= abs d
		  edge			= if (direction==Horizontal)
		  					(abs (corner2.x-corner1.x-d))
		  					(abs (corner2.y-corner1.y-d))
		= case move of
			SliderIncSmall	-> x+d
			SliderDecSmall	-> x-d
			SliderIncLarge	-> x+edge
			SliderDecLarge	-> x-edge
			SliderThumb x	-> x

alignScrollFunction :: !Direction !Int -> ScrollFunction
alignScrollFunction direction d
	= alignScrollFunction` direction d
where
	alignScrollFunction` :: !Direction !Int !ViewFrame !SliderState !SliderMove -> Int
	alignScrollFunction` direction d {corner1,corner2} {sliderThumb=x,sliderMax=m} move
		# d				= abs d
		  edge			= if (direction==Horizontal)
		  					(abs (corner2.x-corner1.x-d))
		  					(abs (corner2.y-corner1.y-d))
		= case move of
			SliderIncSmall	-> let x` = x+d in if (x`>m) m (align x`)
			SliderDecSmall	-> align (x-d)
			SliderIncLarge	-> align (x+edge)
			SliderDecLarge	-> align (x-edge)
			SliderThumb x	-> if (x == m) x (align x)
	align x = (x / d) * d

safeOpenFixedFont :: !FontDef !*Picture -> (Font,*Picture);
safeOpenFixedFont fdef pict
	# ((ok,fnt),pict) = openFont fdef pict
	# ((ok,fnt),pict) = case ok of
							True -> ((ok,fnt),pict)
							False -> openFont fdef` pict
	| not ok
		= openDefaultFont pict
	= (fnt,pict)
where
	fdef` = NonProportionalFontDef
	
instance toString FontDef
where
	toString {fName,fSize,fStyles} = "<fName: "+++fName+++",fSize: "+++toString fSize+++",fStyles: "+++toS fStyles+++ ">"
	where
		toS [] = ""
		toS [s] = s
		toS [h:t] = h+++", "+++toS t

filterReturnKeys :: KeyboardStateFilter
filterReturnKeys = filterfun
where
	filterfun (SpecialKey key  (KeyDown False) _)	= key==enterKey || key==returnKey
//	filterfun (CharKey    '\n' (KeyDown False))		= True
	filterfun _										= False

escFilter :: KeyboardStateFilter
escFilter = filter
where
	filter (SpecialKey key KeyUp mods) = (key == escapeKey) && (mods == NoModifiers)
	filter _ = False

instance accScreenPicture (PSt .l)
where
	accScreenPicture f ps = accPIO (accScreenPicture f) ps

toMark :: !Bool -> MarkState
toMark True = Mark
toMark False = NoMark

toSelect :: !Bool -> SelectState
toSelect True = Able
toSelect False = Unable

noPS :: .(.a -> .b) !(.a,.c) -> (.b,.c)
noPS f (ls,ps) = (f ls,ps)

drawLeft :: !.Point2 a !*Picture -> *Picture | toString a
drawLeft point info picture
	#	text				= toString info
	=	drawAt point text picture

drawCenter :: !.Point2 a !*Picture -> *Picture | toString a
drawCenter {x,y} info picture
	#	text				= toString info
		(width,picture)		= getPenFontStringWidth text picture
	=	drawAt {x=x-width/2,y=y} text picture

drawRight :: !.Point2 a !*Picture -> *Picture | toString a
drawRight {x,y} info picture
	#	text				= toString info
		(width,picture)		= getPenFontStringWidth text picture
	=	drawAt {x=x-width,y=y} text picture

setCheckControlItem :: !Id .Index !.Bool !*(IOSt *l) -> *(IOSt *l)
setCheckControlItem id idx True io = markCheckControlItems id [idx] io
setCheckControlItem id idx False io = unmarkCheckControlItems id [idx] io

zip3::![.a] [.b] [.c] -> [(.a,.b,.c)]
zip3 [a:as] [b:bs] [c:cs]	= [(a,b,c):zip3 as bs cs]
zip3 as bs cs				= []

getPenAttributeFont :: ![.PenAttribute] -> FontDef;
getPenAttributeFont [] = SansSerifFontDef
getPenAttributeFont [PenFont f:_] = getFontDef f
getPenAttributeFont [_:t] = getPenAttributeFont t

getPenAttributeColour :: ![.PenAttribute] -> Colour;
getPenAttributeColour [] = Black
getPenAttributeColour [PenColour c:_] = c
getPenAttributeColour [_:r] = getPenAttributeColour r

getPenAttributeBack :: ![.PenAttribute] -> Colour;
getPenAttributeBack [] = White
getPenAttributeBack [PenBack c:_] = c
getPenAttributeBack [_:r] = getPenAttributeBack r

instance FileEnv Files
where
	accFiles f e = f e
	appFiles f e = f e

seqmap :: (.a -> .(.b -> .b)) ![.a] !.b -> .b;
seqmap f [] e = e
seqmap f [h:t] e
	#! e = f h e
	= seqmap f t e

notEmpty s		:== not (isEmpty s)

143
144
145
146
147
148
import	StdTuple, clCCall_12, clCrossCall_12
from	osfileselect	import osInitialiseFileSelectors
from	scheduler		import handleOneEventForDevices
from	commondef		import fatalError

selectDirectory` :: !(PSt *l) -> (!Maybe String,!(PSt *l))
Diederik van Arkel's avatar
Diederik van Arkel committed
149
150
selectDirectory` env
//	= selectDirectory Nothing env
151
	# initial = global.[0]
Diederik van Arkel's avatar
Diederik van Arkel committed
152
153
154
155
156
	# (result,env) = selectDirectory initial env
	# (result,_) = case result of
					Nothing -> (result,global)
					(Just _) -> update_maybe_string result global
	= (result,env)
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
where
	selectDirectory :: !(Maybe String) !(PSt *l) -> (!Maybe String,!PSt *l)
	selectDirectory initial pState
		# (tb,pState)			= accPIO getIOToolbox pState
		# tb					= osInitialiseFileSelectors tb
		# (ok,name,pState,tb)	= osSelectdirectory handleOSEvent pState initial tb
		# pState				= appPIO (setIOToolbox tb) pState
		= (if ok (Just name) Nothing,pState)

	//	handleOSEvent turns handleOneEventForDevices into the form required by osSelect(in/out)putfile.
	handleOSEvent :: !OSEvent !*(PSt *l) -> *PSt *l
	handleOSEvent osEvent pState
		= thd3 (handleOneEventForDevices (ScheduleOSEvent osEvent []) pState)

	osSelectdirectory :: !(OSEvent->.s->.s) !.s !(Maybe String) !*OSToolbox -> (!Bool,!String,!.s,!*OSToolbox)
	osSelectdirectory handleOSEvent state initial tb
		# (initialptr,  tb)	= case initial of
								Just initial	-> winMakeCString initial   tb
								Nothing			-> (0,tb)
		# (rcci,state,tb)	= issueCleanRequest (callback handleOSEvent) (Rq1Cci CcRqDIRECTORYDIALOG initialptr) state tb
		# tb				= case initialptr of
								0	-> tb
								_	-> winReleaseCString initialptr   tb
		# (ok,name,tb)		= getinputfilename rcci tb
		= (ok,name,state,tb)
	where
		getinputfilename :: !CrossCallInfo !*OSToolbox -> (!Bool,!String,!*OSToolbox)
		getinputfilename {ccMsg=CcRETURN2,p1=ok,p2=ptr} tb
			| ok==0
				= (False,"",tb)
			| otherwise
				# (pathname,tb)	= winGetCStringAndFree ptr tb
				= (True,pathname,tb)
		getinputfilename {ccMsg=CcWASQUIT} tb
			= (False,"",tb)
		getinputfilename {ccMsg} _
			= osfileselectFatalError "osSelectdirectory" ("unexpected ccMsg field of return CrossCallInfo ("+++toString ccMsg+++")")

	//	callback lifts a function::(OSEvent -> .s -> .s) to
	//        a crosscallfunction::(CrossCallInfo -> .s -> *OSToolbox -> (CrossCallInfo,.s,*OSToolbox))
	callback :: !(OSEvent->.s->.s) !CrossCallInfo !.s !*OSToolbox -> (!CrossCallInfo,!.s,!*OSToolbox)
	callback handleOSEvent cci state tb = (return0Cci,handleOSEvent cci state,tb)

	osfileselectFatalError :: String String -> .x
	osfileselectFatalError function error
		= fatalError function "osfileselect" error
Diederik van Arkel's avatar
Diederik van Arkel committed
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225

//== UNSAFE HACK...

import StdArray

global =: {Just ""}

//update_maybe_string :: !(Maybe String) !*{(Maybe String)} -> (!(Maybe String),!*{(Maybe String)})
update_maybe_string :: !(Maybe String) !{(Maybe String)} -> (!(Maybe String),!{(Maybe String)})
update_maybe_string ms ar
//	= (ms,{ar & [0] = ms})
	= code {
		push_a 0
		pushI 0
		push_a 2
		update_a 2 3
		update_a 1 2
		updatepop_a 0 1
		update _ 1 0
		push_a 1
		update_a 1 2
		updatepop_a 0 1
	}