Mac specific

Move keymapping to platform module

Ed/EdKeyMapping.dcl

@@ -9,6 +9,8 @@ from StdMaybe		import :: Maybe
 from StdOverloaded	import class ==, class toString, class fromString
 from EdActionType	import :: Action
 
+KeyMapFileName	:== "default.km"
+
 :: KeyMapping
 
 // The first two arguments are there to circumvent the

Ed/EdKeyMapping.icl

@@ -9,6 +9,8 @@ import StrictList, ioutil
 import EdActionType
 import Platform
 
+KeyMapFileName	:== "default.km"
+
 //--
 
 MAX_KEY_BINDINGS	:== 4

Ide/IDE.icl

@@ -9,7 +9,7 @@ import PmDialogues
 import PmParse
 import PmPath
 
-from EdKeyMapping import macKeyMapping, ReadKeyMapFile
+from EdKeyMapping import macKeyMapping, ReadKeyMapFile, KeyMapFileName
 from finder import sr_find, sr_find_next, sr_find_sel, sr_rep_find, sr_goto_cursor
 from finder import sr_goto_line, sr_goto_selection
 from edoptions import defaultFontAndTabs, optionsKeyMapping, editColours
@@ -110,7 +110,8 @@ Start world
 		= Batch stup force_update proj_path pub world
 where
 	setupKeyMap world
-		# ((km,ok,_),world) = accFiles (ReadKeyMapFile (applicationpath "Config\\default.km")) world
+		# keymappath		= MakeFullPathname PrefsDir	KeyMapFileName
+		# ((km,ok,_),world) = accFiles (ReadKeyMapFile keymappath) world
 		# keymap			= if ok km macKeyMapping
 		= (keymap,world)
 	setupToolBar show world		// need to conditionalise for Mac...

Mac/IdePlatform.dcl

@@ -4,8 +4,9 @@ import StdPSt, StdString
 import StdIOCommon
 from IdeState import :: General
 
-PlatformProcessAttributes :: [ProcessAttribute *(PSt General)]
-RunProgram :: !.String !*(PSt General) -> *PSt General
+PlatformInteractiveInit		:: !*(PSt General) -> *PSt General
+PlatformProcessAttributes	:: [ProcessAttribute *(PSt General)]
+RunProgram					:: !.String !*(PSt General) -> *PSt General
 
 SetWindowIcon :: !Id !Int !(PSt .l) -> PSt .l
 SetProcessIcon :: !Int !(PSt .l) -> PSt .l
@@ -16,3 +17,15 @@ ImpmodIcon	:== 32516
 DefmodIcon	:== 32515
 CleanIcon	:== 32512
 AbcmodIcon	:== 32514
+
+toolIconFun :: !String !(Maybe String) !(IdFun .st) ![(ToolbarItem .st)] !*env -> (![(ToolbarItem .st)],!*env)  | FileSystem env
+
+AboutBitmap	:== ""
+findBM		:== "findBM.bmp"
+newfBM		:== "newfBM.bmp"
+openBM		:== "openBM.bmp"
+prntBM		:== "prntBM.bmp"
+saveBM		:== "saveBM.bmp"
+srchBM		:== "srchBM.bmp"
+updtBM		:== "updtBM.bmp"
+urunBM		:== "urunBM.bmp"

Mac/IdePlatform.icl

@@ -6,10 +6,24 @@ import StdFunc
 import PmCleanSystem
 import errwin
 from IdeState import :: General
+import Platform
+
+toolIconFun :: !String !(Maybe String) !(IdFun .st) ![(ToolbarItem .st)] !*env -> (![(ToolbarItem .st)],!*env) | FileSystem env
+toolIconFun bitmapname tooltip toolfun itemlist world
+	# bitmappath	= MakeFullPathname BitmapDir bitmapname
+	# (bmp,world)	= openBitmap bitmappath world
+	# itemlist		= case bmp of
+						Nothing		-> itemlist
+						Just bmp	-> [ToolbarItem bmp tooltip toolfun:itemlist]
+	= (itemlist,world)
+
+PlatformInteractiveInit		:: !*(PSt General) -> *PSt General
+PlatformInteractiveInit ps
+	= ps
 
 GetDialogBackgroundColour :: !(PSt .l) -> (!Colour,!PSt .l)
 GetDialogBackgroundColour ps
-	= (LightGrey, ps)
+	= (White/*LightGrey*/, ps)	// Mac Appearance dependant!
 
 PlatformProcessAttributes :: [ProcessAttribute *(PSt General)]
 PlatformProcessAttributes = []
@@ -34,3 +48,13 @@ ImpmodIcon	:== 32516
 DefmodIcon	:== 32515
 CleanIcon	:== 32512
 AbcmodIcon	:== 32514
+
+AboutBitmap	:== ""
+findBM		:== "findBM.bmp"
+newfBM		:== "newfBM.bmp"
+openBM		:== "openBM.bmp"
+prntBM		:== "prntBM.bmp"
+saveBM		:== "saveBM.bmp"
+srchBM		:== "srchBM.bmp"
+updtBM		:== "updtBM.bmp"
+urunBM		:== "urunBM.bmp"

Mac/Platform.dcl

@@ -12,6 +12,7 @@ openPlatformWindowMenu			:: !*(PSt .l) -> *(PSt .l)
 TooltempDir	:: String
 EnvsDir		:: String
 PrefsDir	:: String
+BitmapDir	:: String
 
 batchOptions	:: !*World -> (!Bool,Bool,String,*File,!*World)
 wAbort			:: !String !*World -> *World

Mac/Platform.icl

@@ -53,3 +53,6 @@ EnvsDir = applicationpath "Config"
 
 PrefsDir	:: String
 PrefsDir = applicationpath "Config"
+
+BitmapDir	:: String
+BitmapDir = applicationpath "Bitmaps"

Mac/dodebug.dcl

+definition module dodebug
+
+from StdOverloaded	import class toString
+from StdPictureDef	import :: Colour
+import StdMaybe
+import ostoolbox,ostypes
+from deviceevents	import :: DeviceEvent, :: SchedulerEvent, :: MsgEvent, :: ControlUpdateInfo
+
+abort` :: !a -> .b	| toString a	// stop reduction and print argument
+abort`` :: !.a !b -> .a | toString b
+
+trace_n` :: !msg .a -> .a | toString msg	// write toString msg and newline to stderr
+										// before evaluating a
+trace_l :: ![a] .b -> .b | toString a
+assert :: {#.Char} !.(.a -> (.Bool,.b)) .a -> .b
+trace_rgn :: !{#.Char} !Int -> Int
+trace_col :: !{#.Char} !Colour -> Colour
+assertPort :: !Int !*OSToolbox -> (!Bool,!*OSToolbox)
+//		# tb = assert "updateScroll: wrong port" (assertPort wPtr) tb
+
+instance toString OSRect
+instance toString (l,r) | toString l & toString r
+instance toString (a,b,c) | toString a & toString b & toString c
+instance toString (a,b,c,d) | toString a & toString b & toString c & toString d
+instance toString (a,b,c,d,e) | toString a & toString b & toString c & toString d & toString e
+instance toString (a,b,c,d,e,f) | toString a & toString b & toString c & toString d & toString e & toString f
+
+//instance toString Colour
+//instance toString RGBColour
+
+instance toString (Maybe a) | toString a
+
+pretty :: ![a] -> String | toString a
+
+instance toString DeviceEvent
+instance toString SchedulerEvent
+instance toString MsgEvent
+instance toString ControlUpdateInfo
+
+DebugStr :: !String !.a -> .a
+DebugStr` :: !msg !.a -> .a | toString msg

Mac/dodebug.icl

+implementation module dodebug
+
+import StdEnv,StdPictureDef
+from	quickdraw import QGetPort, :: GrafPtr
+
+assert :: {#.Char} !.(.a -> (.Bool,.b)) .a -> .b
+assert txt test env
+	# (ok,env)	= test env
+	| ok = env
+	= abort txt
+
+import osrgn,StdDebug
+
+abort` :: !a -> .b	| toString a	// stop reduction and print argument
+abort` a = abort (toString a)
+
+abort`` :: !.a !b -> .a | toString b
+abort`` a b = abort (toString b)
+
+trace_l :: ![a] .b -> .b | toString a
+trace_l [] e = e
+trace_l [h:t] e
+	#! e = trace_n h e
+	= trace_l t e
+
+trace_rgn :: !{#.Char} !Int -> Int
+trace_rgn txt rgn
+	# (isRect,rct,_)= osgetrgnbox rgn OSNewToolbox
+	# rgn			= trace_n (txt+++xxx rct isRect) rgn
+	= rgn
+where
+	xxx {rleft,rtop,rright,rbottom} isRect =
+			"[("+++toString rleft+++
+			","+++toString rtop +++
+			"),("+++toString rright+++
+			","+++toString rbottom+++
+			")] "+++toString isRect
+
+trace_col :: !{#.Char} !Colour -> Colour
+trace_col txt col
+	= trace_n (txt+++xxx col) col
+where
+	xxx colour = case colour of
+							Black	-> "BlackColor"
+							White	-> "WhiteColor"
+							Red		-> "RedColor"
+							Green	-> "GreenColor"
+							Blue	-> "BlueColor"
+							Cyan	-> "CyanColor"
+							Magenta	-> "MagentaColor"
+							Yellow	-> "YellowColor"
+							RGB rgb		-> "rgb"
+							DarkGrey	-> "DarkGrey"
+							Grey		-> "Grey"
+							LightGrey	-> "LightGrey"
+
+
+assertPort :: !Int !*OSToolbox -> (!Bool,!*OSToolbox)
+assertPort p tb
+	# (q,tb)	= QGetPort tb
+	= (p==q,tb)
+		
+instance toString OSRect
+where
+	toString {rleft,rtop,rright,rbottom} = "{("+++toString rleft+++","+++toString rtop+++"),("+++toString rright+++","+++toString rbottom+++")}"
+
+instance toString (l,r) | toString l & toString r
+where
+	toString (l,r) = "("+++toString l+++","+++toString r+++")"
+
+instance toString (a,b,c) | toString a & toString b & toString c
+where
+	toString (a,b,c) = "("+++toString a+++","+++toString b+++","+++toString c+++")"
+
+instance toString (a,b,c,d) | toString a & toString b & toString c & toString d
+where
+	toString (a,b,c,d) = "("+++toString a+++","+++toString b+++","+++toString c+++","+++toString d+++")"
+
+instance toString (a,b,c,d,e) | toString a & toString b & toString c & toString d & toString e
+where
+	toString (a,b,c,d,e) = "("+++toString a+++","+++toString b+++","+++toString c+++","+++toString d+++","+++toString e+++")"
+
+instance toString (a,b,c,d,e,f) | toString a & toString b & toString c & toString d & toString e & toString f
+where
+	toString (a,b,c,d,e,f) = "("+++toString a+++","+++toString b+++","+++toString c+++","+++toString d+++","+++toString e+++","+++toString f+++")"
+
+instance toString Colour where
+	toString (RGB rgb)	=  "(RGB "+++toString rgb+++")"
+	toString Black		= "Black"
+	toString White		= "White"
+	toString DarkGrey	= "DarkGrey"
+	toString Grey		= "Grey"
+	toString LightGrey	= "LightGrey"
+	toString Red		= "Red"
+	toString Green		= "Green"
+	toString Blue		= "Blue"
+	toString Cyan		= "Cyan"
+	toString Magenta	= "Magenta"
+	toString Yellow		= "Yellow"
+
+instance toString RGBColour where
+	toString {r,g,b}	= "{"+++ (itemsList "," (map recordFieldtoString [("r",r),("g",g),("b",b)]))+++"}"
+
+itemsList :: !String ![String] -> String
+itemsList separator [x:xs]
+	= x+++itemsList` xs
+where
+	itemsList` [x:xs]	= separator+++x+++itemsList` xs
+	itemsList` _		= ""
+itemsList _ _
+	= ""
+
+curlify  x = "{"+++x+++"}"
+brackify x = "("+++x+++")"
+squarify x = "["+++x+++"]"
+
+recordFieldtoString :: (String,a) -> String | toString a
+recordFieldtoString (field,value) = field+++"="+++toString value
+
+pretty :: ![a] -> String | toString a
+pretty l = brackify (itemsList "," (map toString l))
+
+import StdMaybe
+
+instance toString (Maybe a) | toString a
+where
+	toString Nothing = "Nothing"
+	toString (Just a) = "Just "+++.toString a
+
+import deviceevents
+
+instance toString MsgEvent
+where
+	toString (QASyncMessage msg)	= "QASyncMessage"
+	toString (ASyncMessage msg)		= "ASyncMessage"
+	toString (SyncMessage msg)		= "SyncMessage"
+
+instance toString ControlUpdateInfo
+where
+	toString
+		{	cuItemNr			//:: !Int						// The wItemNr of the control
+		,	cuItemPtr			//:: !OSWindowPtr				// The wItemPtr to the control (can be OSNoWindowPtr)
+		,	cuArea				//:: !OSRect					// The update area of the control (in window coordinates)
+		} = "{"+++toString cuItemNr +:+ toString cuItemPtr +:+ toString cuArea+++"}"
+
+(+:+) infixr 5 :: String String -> String
+(+:+) l r = l +++ ","+++ r
+
+instance toString DeviceEvent where
+	toString (MenuTraceEvent _)			= "MenuTraceEvent"
+	toString (ToolbarSelection _)		= "ToolbarSelection"
+	toString (ReceiverEvent _)			= "ReceiverEvent"
+	toString (InternetEvent _)				= "InternetEvent"
+	toString (TimerEvent _)				= "TimerEvent"
+	toString (CompoundScrollAction _)	= "CompoundScrollAction"
+	toString (ControlGetKeyFocus _)		= "ControlGetKeyFocus"
+	toString (ControlKeyboardAction _)	= "ControlKeyboardAction"
+	toString (ControlLooseKeyFocus _)	= "ControlLooseKeyFocus"
+	toString (ControlMouseAction _)		= "ControlMouseAction"
+	toString (ControlSelection _)		= "ControlSelection"
+	toString (ControlSliderAction _)	= "ControlSliderAction"
+	toString (WindowActivation _)		= "WindowActivation"
+	toString (WindowCANCEL _)			= "WindowCANCEL"
+	toString (WindowDeactivation _)		= "WindowDeactivation"
+	toString (WindowInitialise _)		= "WindowInitialise"
+	toString (WindowKeyboardAction _)	= "WindowKeyboardAction"
+	toString (WindowMouseAction _)		= "WindowMouseAction"
+	toString (WindowOK _)				= "WindowOK"
+	toString (WindowRequestClose _)		= "WindowRequestClose"
+	toString (WindowScrollAction _)		= "WindowScrollAction"
+	toString (WindowSizeAction _)		= "WindowSizeAction"
+	toString (WindowUpdate _)			= "WindowUpdate"
+	toString ProcessRequestClose		= "ProcessRequestClose"
+	toString (ProcessRequestOpenFiles _)= "ProcessRequestOpenFiles"
+	toString ProcessRequestClipboardChanged		= "ProcessRequestClipboardChanged"
+
+instance toString SchedulerEvent
+where
+	toString (ScheduleOSEvent event=:(a,b,c,d,e,f,g) list)
+		= "ScheduleOSEvent: " +++ toString (a,b,c) +++ toString (d,e,f,g)
+	toString (ScheduleMsgEvent event)		= "ScheduleMsgEvent"
+	toString (ScheduleTimerEvent event)		= "ScheduleTimerEvent"
+
+DebugStr :: !String !.a -> .a
+DebugStr s a
+	| onOSX
+		# s = {toChar (size s)} +++ s
+		| 42 == DebugStr s 42 = a
+		= a
+	= trace_n s a
+where
+	DebugStr :: !String !*Int -> *Int
+	DebugStr _ _ = code {
+		ccall DebugStr "Ps:V:I"
+		}
+
+trace_n` :: !msg .a -> .a | toString msg	// write toString msg and newline to stderr
+										// before evaluating a
+trace_n` m a
+	= DebugStr (toString m) a
+//	= trace_n m a
+
+DebugStr` :: !msg !.a -> .a | toString msg
+DebugStr` msg a
+	= DebugStr (toString msg) a
+
+onOSX =: fst (runningCarbonOSX OSNewToolbox)
+
+runningCarbonOSX tb
+	# (err,res,tb)	= Gestalt "sysv" tb
+	| err <> 0 = abort "Gestalt failed.\n"
+	= (res >= 0x01000, tb)
+
+Gestalt :: !String !*Int -> (!Int,!Int,!*Int)
+Gestalt sSel tb
+	| size sSel <> 4 = abort "Gestalt not called with four-char selector.\n"
+	# iSel	= ((toInt sSel.[0]) << 24) bitor ((toInt sSel.[1]) << 16) bitor ((toInt sSel.[2]) << 8) bitor ((toInt sSel.[3]) << 0)
+	= Gestalt iSel tb
+where
+	Gestalt :: !Int !*Int -> (!Int,!Int,!*Int)
+	Gestalt _ _ = code {
+		ccall Gestalt "PI:II:I"
+		}