Commit 3c886916 authored by Diederik van Arkel's avatar Diederik van Arkel

Mac specific

Move keymapping to platform module
parent 9222b57d
......@@ -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
......
......@@ -9,6 +9,8 @@ import StrictList, ioutil
import EdActionType
import Platform
KeyMapFileName :== "default.km"
//--
MAX_KEY_BINDINGS :== 4
......
......@@ -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...
......
......@@ -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"
......@@ -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"
......@@ -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
......@@ -53,3 +53,6 @@ EnvsDir = applicationpath "Config"
PrefsDir :: String
PrefsDir = applicationpath "Config"
BitmapDir :: String
BitmapDir = applicationpath "Bitmaps"
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
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"
}
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment