dodebug.icl 9.57 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 143 144 145 146 147 148 149 150 151 152 153 154 155 156 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
implementation module dodebug

import StdInt, StdList, StdOverloaded, StdString
import StdControlDef, StdIOCommon, StdPictureDef
import devicefunctions, wstate, layout
import oswindow, clCrossCall_12
import StdDebug

trace_n` :: !msg .a -> .a | toString msg	// write toString msg and newline to stderr
										// before evaluating a
trace_n` m a = trace_n m a

instance toString (a,b) | toString a & toString b where
	toString (a,b) = brackify (itemsList "," [toString a,toString b])
instance toString (a,b,c) | toString a & toString b & toString c where
	toString (a,b,c) = brackify (itemsList "," [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) = brackify (itemsList "," [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) = brackify (itemsList "," [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) = brackify (itemsList "," [toString a,toString b,toString c,toString d,toString e,toString f])
instance toString (a,b,c,d,e,f,g) | toString a & toString b & toString c & toString d & toString e & toString f & toString g where
	toString (a,b,c,d,e,f,g) = brackify (itemsList "," [toString a,toString b,toString c,toString d,toString e,toString f,toString g])
instance toString (Maybe x) | toString x where
	toString Nothing = "Nothing"
	toString (Just x) = brackify ("Just "+++toString x)
//instance toString SliderMove where
//	toString SliderIncSmall			= "SliderIncSmall"
//	toString SliderDecSmall			= "SliderDecSmall"
//	toString SliderIncLarge			= "SliderIncLarge"
//	toString SliderDecLarge			= "SliderDecLarge"
//	toString (SliderThumb thumb)	= brackify ("SliderThumb "+++toString thumb)
/*
instance toString (DeviceEvent i o) where
	toString (MenuTraceEvent _)			= "MenuTraceEvent"
	toString (ToolbarSelection _)		= "ToolbarSelection"
	toString (ReceiverEvent _)			= "ReceiverEvent"
	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"
*/
instance toString ControlUpdateInfo where
	toString {cuItemNr,cuItemPtr,cuArea}
		= curlify (itemsList "," ((map recordFieldtoString (zip2 ["cuItemNr","cuItemPtr"] [cuItemNr,cuItemPtr]))++[recordFieldtoString ("cuArea",cuArea)]))
instance toString Colour where
	toString (RGB rgb)	= brackify ("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}	= curlify (itemsList "," (map recordFieldtoString [("r",r),("g",g),("b",b)]))
instance toString OSRect where
	toString {rleft,rtop,rright,rbottom}
						= curlify (itemsList "," (map recordFieldtoString [("left",rleft),("top",rtop),("right",rright),("bottom",rbottom)]))
instance toString Root where
	toString {rootItem,rootPos,rootTree}
		= curlify (itemsList "," [	recordFieldtoString ("rootItem",rootItem)
								 ,	recordFieldtoString ("rootPos", rootPos)
								 ,	recordFieldtoString ("rootTree",itemsList "," (map toString rootTree))
								 ])
instance toString Relative where
	toString {relativeItem,relativePos}
		= curlify (itemsList "," [	recordFieldtoString ("relativeItem",relativeItem)
								 ,	recordFieldtoString ("relativePos",relativePos)
								 ])
instance toString LayoutItem where
	toString {liId,liItemPos,liItemSize}
		= curlify (itemsList "," [	recordFieldtoString ("liId",      liId)
								 ,	recordFieldtoString ("liItemPos", liItemPos)
								 ,	recordFieldtoString ("liItemSize",liItemSize)
								 ])
instance toString ItemOffset where
	toString NoOffset			= "NoOffset"
	toString (OffsetVector v)	= brackify "OffsetVector "+++toString v
	toString (OffsetFun  i f)	= brackify "OffsetFun "+++toString i
instance toString CrossCallInfo where
	toString {ccMsg,p1,p2,p3,p4,p5,p6}
		= toString (ccMsgString ccMsg,p1,p2,p3,p4,p5,p6)
	where
		ccMsgString CcWmACTIVATE			= "CcWmACTIVATE"
		ccMsgString CcWmBUTTONCLICKED		= "CcWmBUTTONCLICKED"
		ccMsgString CcWmCHAR				= "CcWmCHAR"
		ccMsgString CcWmCLOSE				= "CcWmCLOSE"
		ccMsgString CcWmCOMBOSELECT			= "CcWmCOMBOSELECT"
		ccMsgString CcWmCOMMAND				= "CcWmCOMMAND"
		ccMsgString CcWmCREATE				= "CcWmCREATE"
		ccMsgString CcWmDDEEXECUTE			= "CcWmDDEEXECUTE"
		ccMsgString CcWmDEACTIVATE			= "CcWmDEACTIVATE"
		ccMsgString CcWmDRAWCLIPBOARD		= "CcWmDRAWCLIPBOARD"
		ccMsgString CcWmDRAWCONTROL			= "CcWmDRAWCONTROL"
		ccMsgString CcWmGETHSCROLLVAL		= "CcWmGETHSCROLLVAL"
		ccMsgString CcWmGETSCROLLBARINFO	= "CcWmGETSCROLLBARINFO"
		ccMsgString CcWmGETTOOLBARTIPTEXT	= "CcWmGETTOOLBARTIPTEXT"
		ccMsgString CcWmGETVSCROLLVAL		= "CcWmGETVSCROLLVAL"
		ccMsgString CcWmIDLEDIALOG			= "CcWmIDLEDIALOG"
		ccMsgString CcWmIDLETIMER			= "CcWmIDLETIMER"
		ccMsgString CcWmINITDIALOG			= "CcWmINITDIALOG"
		ccMsgString CcWmKEYBOARD			= "CcWmKEYBOARD"
		ccMsgString CcWmKILLFOCUS			= "CcWmKILLFOCUS"
//		ccMsgString CcWmLOSEMODELESSDLOG	= "CcWmLOSEMODELESSDLOG"
		ccMsgString CcWmMOUSE				= "CcWmMOUSE"
		ccMsgString CcWmNEWHTHUMB			= "CcWmNEWHTHUMB"
		ccMsgString CcWmNEWVTHUMB			= "CcWmNEWVTHUMB"
		ccMsgString CcWmPAINT				= "CcWmPAINT"
		ccMsgString CcWmPROCESSCLOSE		= "CcWmPROCESSCLOSE"
		ccMsgString CcWmPROCESSDROPFILES	= "CcWmPROCESSDROPFILES"
		ccMsgString CcWmSCROLLBARACTION		= "CcWmSCROLLBARACTION"
		ccMsgString CcWmSETFOCUS			= "CcWmSETFOCUS"
		ccMsgString CcWmSIZE				= "CcWmSIZE"
		ccMsgString CcWmSPECIALBUTTON		= "CcWmSPECIALBUTTON"
		ccMsgString CcWmTIMER				= "CcWmTIMER"
		ccMsgString CcWmZEROTIMER			= "CcWmZEROTIMER"
		ccMsgString msg						= "(Other message: "+++toString msg+++")"
toOSCrossCallInfoString :: CrossCallInfo -> String
toOSCrossCallInfoString cci = toString cci
toCleanCrossCallInfoString :: CrossCallInfo -> String
toCleanCrossCallInfoString cci = toString cci
//instance toString DelayActivationInfo where
//	toString (DelayActivated   wPtr)		= brackify ("DelayActivated "  +++toString wPtr)
//	toString (DelayDeactivated wPtr)		= brackify ("DelayDeactivated "+++toString wPtr)

curlify  x = "{"+++x+++"}"
brackify x = "("+++x+++")"
squarify x = "["+++x+++"]"

recordFieldtoString :: (String,a) -> String | toString a
recordFieldtoString (field,value) = field+++"="+++toString value

itemsList :: !String ![String] -> String
itemsList separator [x:xs]
	= x+++itemsList` xs
where
	itemsList` [x:xs]	= separator+++x+++itemsList` xs
	itemsList` _		= ""
itemsList _ _
	= ""


//show :: ![WElementHandle .ls .ps] -> String
//show itemHs = squarify (itemsList "\n," (map toString itemHs))
show` :: ![WElementHandle`] -> String
show` itemHs` = squarify (itemsList "\n," (map toString itemHs`))

listToString :: [x] -> String | toString x
listToString xs = squarify (itemsList "," (map toString xs))
/*
instance toString (WElementHandle .ls .ps) where
	toString (WListLSHandle itemHs) = brackify ("WListLSHandle "+++show itemHs)
	toString (WExtendLSHandle {wExtendItems}) = brackify ("WExtendLSHandle "+++show wExtendItems)
	toString (WChangeLSHandle {wChangeItems}) = brackify ("WChangeLSHandle "+++show wChangeItems)
	toString (WItemHandle itemH)			  = brackify ("WItemHandle "+++toString itemH)
instance toString (WItemHandle .ls .ps) where
	toString {wItemKind,wItemPos,wItemSize,wItems}
		= toString (wItemKind,wItemPos,wItemSize,show wItems)
*/
instance toString WElementHandle` where
	toString (WRecursiveHandle` itemHs wkind) = brackify (toString wkind+++" "+++show` itemHs)
	toString (WItemHandle` itemH)			  = brackify ("WItemHandle` "+++toString itemH)
instance toString WItemHandle` where
	toString {wItemKind`,wItemPos`,wItemSize`,wItems`}
		= toString (wItemKind`,wItemPos`,wItemSize`,show` wItems`)
instance toString WRecursiveKind where
	toString IsWListLSHandle	= "IsWListLSHandle"
	toString IsWExtendLSHandle	= "IsWExtendLSHandle"
	toString IsWChangeLSHandle	= "IsWChangeLSHandle"
193 194 195 196 197 198

instance toString UpdateInfo where
	toString info = "{" +++ toString info.updWIDS.wPtr +++ 
					"," +++ toString info.updWindowArea+++ 
//					"," +++ toString info.updControls+++ 
					"," +++ toString info.updGContext+++ 
Diederik van Arkel's avatar
Diederik van Arkel committed
199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215
					"}"

import code from "printStackNow.obj"

printStackNow :: !Int -> Int	// in 2.0.2 only works with stack trace only...
printStackNow stackDepth = code {
	ccall printStackNow "I:I"
	}

/*
Start = testPS 8

testPS n
	| n == 0 = printStackNow 10
	| testPS (dec n) == 0 = 0
							= 1
*/