IdePlatform.icl 9.81 KB
Newer Older
Diederik van Arkel's avatar
Diederik van Arkel committed
1 2
implementation module IdePlatform

3 4 5 6
import StdEnv
import StdPSt, StdPStClass
import PmCleanSystem
import errwin, conswin
John van Groningen's avatar
John van Groningen committed
7
import UtilIO,UtilObjectIO
8 9 10 11 12 13
import EdKeyboard, EdMouse

from iostate	import appIOToolbox,accIOToolbox
from clCCall_12	import winLaunchApp,winMakeCString,:: CSTR,:: OSToolbox
import	clCrossCall_12, windowaccess, iostate
import pictCCall_12, cast
14
import first_run
15

16 17
import code from "Redirect."
import code from "cCrossCallMaarten."
Diederik van Arkel's avatar
Diederik van Arkel committed
18

19 20
import code from library "conkernel_library"
import code from library "bmpgdi_library"
Diederik van Arkel's avatar
Diederik van Arkel committed
21

22 23 24 25 26 27 28 29 30
toolIconFun :: !Int !(Maybe String) !(IdFun .st) ![(ToolbarItem .st)] !.env -> (![(ToolbarItem .st)],!.env)
toolIconFun toolname tooltip toolfun itemlist world
//		# (bmp,world)	= openBitmap (applicationpath toolname) world
	# (bmp,world)	= GetBitmapResource toolname world
	# itemlist		= case bmp of
						Nothing		-> abort ("Loading failed: "+++toString toolname)
						Just bmp	-> [ToolbarItem bmp tooltip toolfun:itemlist]
	= (itemlist,world)

31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49
PlatformInteractiveInit		:: !*(PSt General)	-> *PSt General
PlatformInteractiveInit ps
	// <<< can move this into first_run module
	// as function :: (reg_prefs,ps) -> (reg_prefs,ps)
	# (prefs,ps)	= getPrefs ps
	# pcl_name		= prefs.reg_prefs.tp_name
	# pcl_path		= prefs.reg_prefs.tp_path
	# hcl_name		= prefs.reg_prefs.hp_name
	# hcl_path		= prefs.reg_prefs.hp_path
	# flags			= prefs.reg_prefs.rp_flags
	# (res,flag,ps)	= first_run pcl_name pcl_path hcl_name hcl_path flags ps
	# ps = case res of
			True	# flags = take 10 [flag:flags]
					# prefs = {prefs & reg_prefs.rp_flags = flags}
					-> setPrefs prefs ps
			_		-> ps
	// >>>
	= ps

Diederik van Arkel's avatar
Diederik van Arkel committed
50 51 52 53 54 55 56 57 58 59 60 61
PlatformProcessAttributes :: [ProcessAttribute *(PSt General)]
PlatformProcessAttributes = 
	[ ProcessConsoleOpen id
	, ProcessConsoleQuit consoleKill
	, ProcessConsoleOut  consoleMessageO
	, ProcessConsoleErr  consoleMessageE
	]

//-- Experimental Console Handling/Redirection...

RunProgram :: !.String !*(PSt General) -> *PSt General
RunProgram path ps
Diederik van Arkel's avatar
Diederik van Arkel committed
62
	# (ret,ps) = accPIO (accIOToolbox (AddMainWindowHook True)) ps
Diederik van Arkel's avatar
Diederik van Arkel committed
63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85
	#	(project,ps)	= getProject ps
		(redc,ps)		= getCurrentRedc ps
		ao				= PR_GetApplicationOptions project
		(ps,_)			= Execute` redc updateErrorWindow path ao ps
	= ps
where
	Execute ::	!(WindowFun *env) !Pathname !ApplicationOptions *env -> (*env, !Bool)
	Execute winfun path {o} ps
		#	(didit,_) = winLaunchApp (quoted_string path) (o<>NoConsole) 99
		| didit
			= (ps,True)
			= (winfun ["Error: Could not launch the application."] ps,False)

	Execute` ::	!Bool !(WindowFun *(PSt General)) !Pathname !ApplicationOptions *(PSt General) -> (*PSt General, !Bool)
	Execute` redc winfun path {o} ps
		# (exists,ps)	= accFiles (FExists path) ps
		| not exists
			= (winfun ["Error: No application to run, you must bring the project up to date."] ps, False)
		| not redc || o == NoConsole
			#	(didit,_) = winLaunchApp (quoted_string path) (o<>NoConsole) 99
			| didit
				= (ps,True)
			= (winfun ["Error: Could not launch the application."] ps,False)
86
		#	(didit,_) = startChildProcess (quoted_string path +++. " -con") False/*True*/ 99
Diederik van Arkel's avatar
Diederik van Arkel committed
87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102
		| didit
			= (ps,True)
		= (winfun ["Error: Could not launch the console application."] ps,False)

//--

consWinKeyboard :: .WindowAttribute *(EditState,*PSt *General);
consWinKeyboard = WindowKeyboard	(\ks -> getKeyboardStateKeyState ks == KeyDown False) Able consKeyboard

consWinMouse :: .WindowAttribute *(EditState,*PSt *General);
consWinMouse = WindowMouse noMouseMoved Able editWindowMouse

consoleMessageI :: !{#Char} !(PSt General) -> PSt General
consoleMessageI msg ps = updateConsoleWindowI msg [consWinKeyboard,consWinMouse] ps

consoleMessageO :: !{#Char} !(PSt General) -> PSt General
103
consoleMessageO msg ps = updateConsoleWindowO msg [consWinKeyboard,consWinMouse] ps
Diederik van Arkel's avatar
Diederik van Arkel committed
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

consoleMessageE :: !{#Char} !(PSt General) -> PSt General
consoleMessageE msg ps = updateConsoleWindowE msg [consWinKeyboard,consWinMouse] ps

consoleKill :: !(PSt .a) -> (PSt .a)
consoleKill ps
	# ps = appPIO (appIOToolbox (killChildProcess)) ps
	= ps

consKeyboard :: .KeyboardState *(EditState,*PSt *General) -> *(EditState,*PSt *General);
consKeyboard ks (es,ps)
	| ks == SpecialKey f1Key (KeyDown False) ControlOnly
		# ps = appPIO (appIOToolbox (killChildProcess)) ps
		= (es,ps)
	| ks == SpecialKey f2Key (KeyDown False) ControlOnly
		# (_,ps) = accPIO (accIOToolbox (writeChildProcess "X")) ps
		= (es,ps)
	= case ks of
		(CharKey char _)
			# (_,ps) = accPIO (accIOToolbox (writeChildProcess {char})) ps
			# ps = consoleMessageI {char} ps
			-> (es,ps)
		(SpecialKey key _ _)
			| key == enterKey
				# (_,ps) = accPIO (accIOToolbox (writeChildProcess "\n")) ps
				# ps = consoleMessageI "\n" ps
				-> (es,ps)
			# (ed,ps)				= getEditorState ps
			# keyMapping			= getKeyMapping ed
			-> noeditWindowKeyboard keyMapping ks (es,ps)

//-- Console bindings...

Diederik van Arkel's avatar
Diederik van Arkel committed
137 138 139 140 141
AddMainWindowHook :: !Bool !*OSToolbox -> (!Bool,!*OSToolbox)
AddMainWindowHook _ tb = code {
		ccall AddMainWindowHook "I:I:I"
	}
	
Diederik van Arkel's avatar
Diederik van Arkel committed
142 143 144 145 146
startChildProcess :: !{#Char} !Bool !*OSToolbox -> (!Bool,!*OSToolbox)
startChildProcess cmdl swin tb
	# (cstr,tb) = winMakeCString cmdl tb
	= (startChildProcess` cstr swin,tb)

Diederik van Arkel's avatar
Diederik van Arkel committed
147
startChildProcess` :: !CSTR !Bool -> Bool
Diederik van Arkel's avatar
Diederik van Arkel committed
148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169
startChildProcess` _ _
	= code
	{
		.inline StartChildProcess
			ccall StartChildProcess "II-I"
		.end
	}

killChildProcess :: !*OSToolbox -> *OSToolbox
killChildProcess _
	= code
	{
		.inline TerminateChildProcess
			ccall TerminateChildProcess "I-I"
		.end
	}

writeChildProcess :: !{#Char} !*OSToolbox -> (!Int,!*OSToolbox)
writeChildProcess str tb
	# (cstr,tb) = winMakeCString str tb
	= (writeChildProcess` cstr,tb)

Diederik van Arkel's avatar
Diederik van Arkel committed
170
writeChildProcess` :: !CSTR -> Int
Diederik van Arkel's avatar
Diederik van Arkel committed
171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193
writeChildProcess` cstr
	= code
	{
		.inline WriteChildStdIn
			ccall WriteChildStdIn "I-I"
		.end
	}

//==

winInitialiseTooltips :: !*OSToolbox -> *OSToolbox
winInitialiseTooltips _
	= code
	{
		.inline InstallCrossCallMaarten
			ccall InstallCrossCallMaarten "I-I"
		.end
	}

osIgnoreCallback :: !CrossCallInfo !*OSToolbox -> (!CrossCallInfo,!*OSToolbox)
osIgnoreCallback _ tb 
	= (return0Cci,tb)

Diederik van Arkel's avatar
Diederik van Arkel committed
194 195 196 197 198 199 200 201 202 203 204 205 206 207
//--

CcRqGETBITMAPRESOURCE	:== 1477

osGetBitmapResource :: !Int !*OSToolbox -> (!(!Int,!String,!Int,!Int),!*OSToolbox)
osGetBitmapResource bitmap_id tb
	# (hbitmap,w,h,tb) = winGetBitmapResource bitmap_id tb
	# data = ""
	= ((hbitmap,data,w,h),tb)
	
winGetBitmapResource :: !Int !*OSToolbox -> (!Int,!Int,!Int,!*OSToolbox)
winGetBitmapResource _ _ = code {
		ccall WinGetBitmapResource "II-IIII"
	}
208

Diederik van Arkel's avatar
Diederik van Arkel committed
209 210 211 212 213 214 215 216 217 218 219
GetBitmapResource :: !Int !.env -> (!Maybe Bitmap,!.env)
GetBitmapResource bitmap_id ps
	# ((hbmp,data,w,h),_)	= osGetBitmapResource bitmap_id OSNewToolbox
	| hbmp == 0			= (Nothing, ps)
	# osbmp		= {originalSize=(w,h),reSize=(w,h),bitmapContents=data,bitmapHandle=hbmp}
	= (Just (toBitmap osbmp), ps)

//--

CcRqSETWINDOWICON		:== 1474

Diederik van Arkel's avatar
Diederik van Arkel committed
220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259
osSetWindowIcon :: !OSWindowPtr !Int !*OSToolbox -> *OSToolbox
osSetWindowIcon wPtr icon_id tb
	# tb = winInitialiseTooltips tb
	= snd (issueCleanRequest2 osIgnoreCallback (Rq2Cci CcRqSETWINDOWICON wPtr icon_id) tb)

SetWindowIcon :: !Id !Int !(PSt .l) -> PSt .l
SetWindowIcon wId icon pState=:{io}
	# (found,wDevice,ioState)	= ioStGetDevice WindowDevice io
	| not found
		= {pState & io=ioState}
	# windows					= windowSystemStateGetWindowHandles wDevice
	# (found,wsH,windows)		= getWindowHandlesWindow (toWID wId) windows
	| not found
		# windows				= setWindowHandlesWindow wsH windows
		# ioState				= ioStSetDevice (WindowSystemState windows) ioState
		= {pState & io=ioState}
	| otherwise
		#! wPtr					= wsH.wshIds.wPtr
		# ioState				= appIOToolbox (tbfun wPtr) ioState
		  windows				= setWindowHandlesWindow wsH windows
		# ioState				= ioStSetDevice (WindowSystemState windows) ioState
		= {pState & io=ioState}
where
	tbfun wPtr tb
		# tb = osSetWindowIcon wPtr icon tb
		= tb

SetProcessIcon :: !Int !(PSt .l) -> PSt .l
SetProcessIcon icon pState=:{io=ioState}
	# (osdi,ioState)	= ioStGetOSDInfo ioState
	# mosi				= getOSDInfoOSInfo osdi
	| isNothing mosi
		# ioState		= ioStSetOSDInfo osdi ioState
		= {pState & io = ioState}
	# {osFrame}			= fromJust mosi
	# ioState			= appIOToolbox (osSetWindowIcon osFrame icon) ioState
	# ioState			= ioStSetOSDInfo osdi ioState
	= {pState & io = ioState}
	
CleanIcon	:== 32512
Diederik van Arkel's avatar
Diederik van Arkel committed
260
ProjectIcon	:== 32513
Diederik van Arkel's avatar
Diederik van Arkel committed
261
AbcmodIcon	:== 32514
Diederik van Arkel's avatar
Diederik van Arkel committed
262 263 264 265 266 267 268 269 270 271 272 273
DefmodIcon	:== 32515
ImpmodIcon	:== 32516

AboutBitmap	:== 32512
findBM		:== 32513
newfBM		:== 32514
openBM		:== 32515
prntBM		:== 32516
saveBM		:== 32517
srchBM		:== 32518
updtBM		:== 32519
urunBM		:== 32520
274

275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319
import first_run
import Directory, StdTuple, StdMenu, StdSystem

getAboutBitmap :: !*env -> (!Maybe Bitmap, !*env) | FileEnv env
getAboutBitmap env
	= GetBitmapResource AboutBitmap env

helpItems :: !Id !Id !*(PSt .a) -> *PSt .a
helpItems wId mId ps
	# path					= applicationpath "Help"
	# ((ok,path`),ps)		= pd_StringToPath path ps
	| not ok = ps
	# ((err,dir),ps)		= getDirectoryContents path` ps
	| err <> NoDirError = ps
	# items					= map getinfo dir
	= to_menu_items (path+++."\\") items mId ps
where
	getinfo {fileName,fileInfo=fi=:{pi_fileInfo=dummyname=:{isDirectory}}}
		= (isDirectory,fileName)
	
	to_menu_items path [] mId ps = ps
	to_menu_items path [(is_dir,filename):rest] mId ps
		| not is_dir
			# item			= MenuItem filename [MenuFunction (noLS (help path filename wId))]
			# (err,ps)		= openSubMenuElements mId 32000 Void item ps
			= to_menu_items path rest mId ps
		| filename == "." || filename == ".."
			= to_menu_items path rest mId ps
		# ((ok,path`),ps)	= pd_StringToPath (path+++.filename) ps
		| not ok
			= to_menu_items path rest mId ps
		# ((err,dir),ps)	= getDirectoryContents path` ps
		| err <> NoDirError
			= to_menu_items path rest mId ps
		# items				= map getinfo dir		// only need common fileinfo...
		# (mId`,ps)			= openId ps
		# item				= SubMenu filename NilLS [MenuId mId`]
		# (err,ps)			= openSubMenuElements mId 32000 Void item ps
		# ps				= to_menu_items (path+++.filename+++."\\") items mId` ps
		= to_menu_items path rest mId ps

help path file wId ps
	# path		= path +++. file
	# (ret,ps)	= ShellDefault path ps
	= ps