implementation module ShowProfile

//import StdEnv
//import StdIO
//import Help
//import expand_8_3_names_in_path
//import ArgEnv

//import StdDebug
import StdArray, StdBool, StdEnum, StdFile, StdFunc, StdList, StdMisc
import StdPicture, StdPrint, StdMaybe
import ExtNotice
import code from "cpuspeed.obj"
//import code from library "time_profiler_kernel_library"
//import code from library "shit_library"

ApplicationName :==  "ShowTimeProfile"
HelpFileName :== ApplicationName +++ "Help"

PCorMac pc mac :== pc

//windowSize = {w=640,h=400}

//--

:: *ProgState =
	{ info			:: ProfileInfo
	, print_setup	:: PrintSetup
	, monaco_font	:: !Font
	, wind			:: !Id
	}

:: ProfileInfo
	= ProfileInfo [FormattedProfile] FormattedProfile
	| NoProfileInfo

//isNoProfile :: .ProfileInfo -> .Bool;
//isNoProfile NoProfileInfo = True
//isNoProfile _ = False

:: Profile =
	{ module_name		:: String
	, function_name		:: String
	, n_strict_calls	:: Int
	, n_lazy_calls		:: Int
	, n_curried_calls	:: Int
	, n_allocated_words	:: Int
	, time				:: Real
	}

:: FormattedProfile =
	{ f_module_name			:: String
	, f_function_name		:: String
	, f_n_strict_calls		:: Int
	, f_n_lazy_calls		:: Int
	, f_n_curried_calls		:: Int
	, f_n_allocated_bytes	:: Int
	, f_alloc_percentage	:: Real
	, f_time				:: Real
	, f_time_percentage		:: Real
	}

//--
/*
Start` :: !*World -> *World
Start` world
	# (r,_,_) = clock_speed_and_profile_overhead
	| r==1
		= error_notice_and_quit
			["Profiling does not work on this computer,",
			 "because the processor does not have a time stamp counter"
			] world
	| r==2
		= error_notice_and_quit
			["Profiling does not work on this computer,",
			 "because the windows API function QueryPerformanceFrequency failed"
			] world
	# (defaultPS, world)	= defaultPrintSetup world
	# (mf,world)			= accScreenPicture openDefaultFont world
	# (wi,world)			= openId world
	= startIO SDI (ploc wi mf defaultPS) pini patt world
where
	ploc wi mf ds =
		{ info			= NoProfileInfo
		, print_setup		= ds
		, monaco_font	= mf
		, wind			= wi
		}
	pini ps
		# (err,ps)	= openMenu undef file_menu ps
		# (err,ps)	= openMenu undef sort_menu ps
		# (err,ps)	= openMenu undef help_menu ps
		# ps		= open_profile_window ps
		# ps		= open_time_file_from_command_line ps
		= ps
	patt =
		[ ProcessClose closeProcess
		, ProcessOpenFiles openFiles
		, ProcessWindowSize windowSize
		]
	file_menu = Menu "&File"
					(	MenuItem "&Open"	[MenuShortKey 'O', MenuFunction (noLS file_open_function)]
					:+: MenuItem "&Close"	[MenuShortKey 'W', MenuFunction (noLS file_close_function)]
					:+: MenuSeparator		[]
					:+: MenuItem "Print&Setup"[MenuFunction (noLS doPrintSetupDialog)]
					:+: MenuItem "&Print"	[MenuShortKey 'P', MenuFunction (noLS printTable)]
					:+: MenuSeparator		[]
					:+: MenuItem "&Quit"	[MenuShortKey 'Q', MenuFunction quit_function]
					) []
	sort_menu = Menu "&Sort"
					(	MenuItem "Sort by &Function"      [MenuShortKey 'F', MenuFunction (noLS sort_by_function_name)]
					:+:	MenuItem "Sort by &Time"          [MenuShortKey 'T', MenuFunction (noLS sort_by_time_function)]
					:+:	MenuItem "Sort by &Allocation"    [MenuShortKey 'A', MenuFunction (noLS sort_by_allocation_function)]
					:+:	MenuItem "Sort by &Strict calls"  [MenuShortKey 'S', MenuFunction (noLS sort_by_strict_function)]
					:+:	MenuItem "Sort by &Lazy calls"    [MenuShortKey 'L', MenuFunction (noLS sort_by_lazy_function)]
					:+:	MenuItem "Sort by &Curried calls" [MenuShortKey 'C', MenuFunction (noLS sort_by_curried_function)]
					) []
	help_menu = Menu "&Help"
					(	MenuItem "&About..."	[MenuFunction (noLS (showAbout ApplicationName HelpFileName))]
					:+:	MenuItem "&Help..."		[MenuFunction (noLS (showHelp HelpFileName))]
					) []
*/
//--
/*
quit_function :: *(.a,*PSt .b) -> *(.a,*PSt .b);
quit_function (ls,ps) = (ls,closeProcess ps)

error_notice_and_quit :: [.String] *World -> .World;
error_notice_and_quit strings world
	= startIO NDI  0 (okNotice strings) [] world
*/
//-- File funs
/*
open_time_file_from_command_line :: *(PSt *ProgState) -> *PSt *ProgState;
open_time_file_from_command_line ps
	| size commandline == 1
		= ps
		= open_file_function (expand_8_3_names_in_path commandline.[1]) ps
where
	commandline
		= getCommandLine

openFiles [] ps = ps
openFiles [h:t] ps
	= open_file_function (expand_8_3_names_in_path h) ps

file_open_function :: *(PSt *ProgState) -> *PSt *ProgState;
file_open_function pst
	# (maybe_file,pst) = selectInputFile pst
	| isJust maybe_file
		= open_file_function (fromJust maybe_file) pst
	= pst

file_close_function :: *(PSt *ProgState) -> *PSt *ProgState;
file_close_function pst
	// disable menus
	// close window
	// enable menus
	# pst = appPLoc (\p->{p & info = NoProfileInfo}) pst
	= pst

open_profile_window pst
	# (wId,pst)					= accPLoc (\p=:{wind}->(wind,p)) pst
	# {w=screen_size_x}			= maxFixedWindowSize
	# ((window_look,window_height),pst)
								= window_update_function pst
	# profile_window			= Window ""
									header
									[ WindowPos (LeftTop,OffsetVector{vx=(screen_size_x-windowSize.w)>>1, vy=10})
									, WindowOuterSize windowSize
									//{w=WindowWidth,h=if (window_height<=screen_size_y-40) window_height (screen_size_y-40)}
									, WindowViewDomain {zero & corner2={x=windowSize.w,y=window_height}}
									, WindowHScroll (stdScrollFunction Horizontal 4)
									, WindowVScroll (stdScrollFunction Vertical 4)
									, WindowLook True window_look
									, WindowClose (noLS file_close_function)
									, WindowId wId
									, WindowItemSpace 0 0 
									]
	// disable 'Open'
	// open profile_window
	# (err,pst)					= openWindow undef profile_window pst
	= pst
where
	header = fn :+: ts :+: tp :+: ab :+: ap :+: sn :+: ln :+: cn
	fn = ButtonControl "Function"		[ControlWidth (PixelWidth WidthFstColumn), ControlPos (LeftTop,zero), ControlFunction (noLS sort_by_function_name)]
	ts = ButtonControl "Time(s)"		[ControlWidth (PixelWidth (Offset2-Offset1)),ControlFunction (noLS sort_by_time_function)]
	tp = ButtonControl "Time(%)"		[ControlWidth (PixelWidth (Offset3-Offset2)),ControlFunction (noLS sort_by_time_function)]
	ab = ButtonControl "Alloc(bytes)"	[ControlWidth (PixelWidth (Offset4-Offset3)),ControlFunction (noLS sort_by_allocation_function)]
	ap = ButtonControl "Alloc(%)"		[ControlWidth (PixelWidth (Offset5-Offset4)),ControlFunction (noLS sort_by_allocation_function)]
	sn = ButtonControl "Strict(#)"		[ControlWidth (PixelWidth (Offset6-Offset5)),ControlFunction (noLS sort_by_strict_function)]
	ln = ButtonControl "Lazy(#)"		[ControlWidth (PixelWidth (Offset7-Offset6)),ControlFunction (noLS sort_by_lazy_function)]
	cn = ButtonControl "Curried(#)"		[ControlWidth (PixelWidth (Offset8-Offset7)),ControlFunction (noLS sort_by_curried_function)]

//	body cId = CompoundControl NilLS [ControlLook,ControlId cId,ControlViewSize {w=400,h=200} ]

open_file_function :: {#.Char} *(PSt *ProgState) -> *PSt *ProgState;
open_file_function file_name pst
	# pst						= maybe_save_function pst
	# ((open_ok,profile),pst)	= accFiles (open_profile file_name) pst
 	| not open_ok
		# pst = trace_n "open_file_function failed" pst
		= pst
	# (total_strict_calls,total_lazy_calls,total_curried_calls,total_allocation,total_time)
								= sum_time_and_allocation profile
	# (formatted_profile,total_profile)
								= format_profile total_strict_calls total_lazy_calls total_curried_calls total_allocation total_time profile
	# formatted_profile			= sortBy ge_profile_time formatted_profile
	// Save read profile to program state
	# pst						= appPLoc (\p->{p & info = ProfileInfo formatted_profile total_profile}) pst
	// Do visual stuff
	# ((window_look,window_height),pst)
								= window_update_function pst
	# (wId,pst)					= accPLoc (\p=:{wind}->(wind,p)) pst
	// disable 'Open'
	// open profile_window
	# pst						= appPIO (setWindowLook wId True (True,window_look)) pst
	# pst						= appPIO (setWindowViewDomain wId {zero & corner2={x=780,y=window_height}}) pst
	// enable menu 'Sort'
	// enable 'Close,Print'
	= pst
*/
sum_time_and_allocation :: ![.Profile] -> .(Int,Int,Int,Int,Real);
sum_time_and_allocation l = foldl add_time_and_allocation (0,0,0,0,0.0) l
where
	add_time_and_allocation (s,l,c,a,t) {function_name,n_strict_calls,n_lazy_calls,n_curried_calls,n_allocated_words,time}
		| n_allocated_words>=0
			= (s+n_strict_calls,l+n_lazy_calls,c+n_curried_calls,a+n_allocated_words,t+time)
			= (s+n_strict_calls,l+n_lazy_calls,c+n_curried_calls,a,t+time)

totals_per_module :: ![.Profile] -> ![.Profile]
totals_per_module []
	= []
totals_per_module [f=:{module_name}:l]
	# (functions,l) = split_at_next_module l
	# functions = [f:functions]
	# (total_strict_calls,total_lazy_calls,total_curried_calls,total_allocation,total_time) = sum_time_and_allocation functions
	# new_module =
			{ module_name=module_name
			, function_name="Module "+++module_name
			, n_strict_calls=total_strict_calls
			, n_lazy_calls=total_lazy_calls
			, n_curried_calls=total_curried_calls
			, n_allocated_words=total_allocation
			, time=total_time
			}
	= [new_module:totals_per_module l]
where
	split_at_next_module []
		= ([],[])
	split_at_next_module l=:[f=:{module_name=m}:t]
		| m==module_name
			# (functions,l) = split_at_next_module t
			= ([f:functions],l)
			= ([],l)

//--
/*
maybe_save_function :: *(PSt *ProgState) -> *PSt *ProgState;
maybe_save_function pst
	# (info,pst) = accPLoc (\p=:{info}->(info,p)) pst
	| isNoProfile info
		= pst
	= file_close_function pst
*/
// File i/o

open_profile :: {#.Char} !*a -> *((.Bool,[.Profile]),!*a) | FileSystem a;
open_profile file_name files
	# (open_ok,input_file,files)	= fopen file_name FReadText files
	| not open_ok
		= ((False,[]),files)
	# (profile,input_file)			= read_profile input_file
	  (_,files)						= fclose input_file files
	= ((True,profile),files)
where
	read_profile :: *File -> ([.Profile],.File);
	read_profile file
//		# (processor,processor_clock,bus_clock,file)
//				= read_processor_information file
		# (_,clock_speed,overhead)
				= clock_speed_and_profile_overhead
		= read_function_profiles (PCorMac
			(compute_time_x86 (clock_speed*1.0E6) overhead)
			undef//(compute_time processor processor_clock bus_clock)
			) file
	
	read_processor_information :: *File -> (Int,Int,Int,.File);
	read_processor_information file
		# (ok,processor,file)=freadi file
		| not ok
			= error file
		# (ok,processor_clock,file)=freadi file
		| not ok
			= error file
		# (ok,bus_clock,file)=freadi file
		| not ok
			= error file
		# (ok,c,file) = freadc file
		| not ok || c<>'\n'
			= error file
			= (processor,processor_clock,bus_clock,file)
	where
			error file = (0,1,1,file)
	
	read_function_profiles :: (.(Int,Int,Int) -> .Real) *File -> ([.Profile],.File);
	read_function_profiles compute_time_function file
		# (ok,function_profile,file) = read_function_profile file
		| not ok
			= ([],file)
			# (profile,file) = read_function_profiles compute_time_function file
			= ([function_profile : profile],file)
	where
		read_function_profile file
			# (ok,module_name,file) = read_function_name file
			| not ok
				= error file
			# (ok,function_name,file) = read_function_name file
			| not ok
				= error file
			# (ok,n_strict_calls,file)=freadi file
			| not ok
				= error file
			# (ok,n_lazy_calls,file)=freadi file
			| not ok
				= error file
			# (ok,n_curried_calls,file)=freadi file
			| not ok
				= error file
			# (ok,n_profiler_calls,file)=freadi file
			| not ok
				= error file
			# (ok,n_allocated_words,file)=freadi file
			| not ok
				= error file
			# (ok,time_hi,file)=freadi file
			| not ok
				= error file
			# (ok,time_lo,file)=freadi file
			| not ok
				= error file
			# (ok,c,file) = freadc file
			| not ok || c<>'\n'
				= error file
				# time = compute_time_function (time_hi,time_lo,n_profiler_calls)
				=	(True,
					{ module_name		= module_name
					, function_name		= function_name
					, n_strict_calls	= n_strict_calls
					, n_lazy_calls		= n_lazy_calls
					, n_curried_calls	= n_curried_calls
					, n_allocated_words	= n_allocated_words
					, time				= time
					},file)
		where
				error file = (False,abort "error in read_function_profile",file)
		
		read_function_name :: !*File -> !(!Bool,!String,!*File)
		read_function_name file
			# (ok,c,file) = freadc file
			| not ok || c==' ' || c=='\n'
				= (False,"",file)
				# (acc,file) = read_function_name [c] file
				= (True,{c \\ c <- reverse acc},file)
		where
			read_function_name acc file
				# (ok,c,file) = freadc file
				| not ok || c == ' ' || c == '\n' = (acc,file)
				= read_function_name [c:acc] file

//-- Clock speed funs

define_fltused :: !Bool -> Bool
define_fltused n = code {
	.export _fltused
	:_fltused
	pop_b 0
	}

measure_clock_speed_and_profile_overhead :: (!Int,!Real,!Real)
measure_clock_speed_and_profile_overhead = code {
	ccall measure_clock_speed_and_profile_overhead ":IRR"
	}

clock_speed_and_profile_overhead :: (Int,Real,Real);
clock_speed_and_profile_overhead
	| define_fltused True
		=: measure_clock_speed_and_profile_overhead

//-- Compute time funs

TwoPower32Real:==4294967296.0
/*
PowerPC601GestaltNumber:==257
PowerPC750GestaltNumber:==264

PowerPC603604ProfileOverhead:==10.0
PowerPC750ProfileOverhead:==7.0

compute_time :: .Int a b -> .((c,.Int,d) -> Real) | toReal a & toReal b & toReal c & toReal d;
compute_time processor processor_clock bus_clock
	| processor==PowerPC601GestaltNumber
		= \ (time_hi,time_lo,n_profiler_calls)
			-> toReal time_hi + (toReal time_lo / 1E+9) - (toReal n_profiler_calls*16.0/toReal processor_clock)
	| processor==PowerPC750GestaltNumber
		= \ (time_hi,time_lo,n_profiler_calls)
			-> ((toReal time_hi*TwoPower32Real + (if (time_lo>=0) (toReal time_lo) (TwoPower32Real+toReal time_lo)))*4.0)/toReal bus_clock
		 		- (toReal n_profiler_calls*PowerPC750ProfileOverhead/toReal processor_clock)
		= \ (time_hi,time_lo,n_profiler_calls)
			-> ((toReal time_hi*TwoPower32Real + (if (time_lo>=0) (toReal time_lo) (TwoPower32Real+toReal time_lo)))*4.0)/toReal bus_clock
		 		- (toReal n_profiler_calls*PowerPC603604ProfileOverhead/toReal processor_clock)
*/
compute_time_x86 :: a .Real -> .((b,.Int,c) -> Real) | toReal a & toReal b & toReal c;
compute_time_x86 processor_clock profile_overhead
	= \ (time_hi,time_lo,n_profiler_calls)
		-> (toReal time_hi*TwoPower32Real + (if (time_lo>=0) (toReal time_lo) (TwoPower32Real+toReal time_lo)))/toReal processor_clock
			- (toReal n_profiler_calls*profile_overhead/toReal processor_clock)

//-- Sorting funs

ge_profile_time :: !.FormattedProfile !.FormattedProfile -> Bool;
ge_profile_time {f_time = time1}			{f_time = time2}			= time1 >= time2

le_profile_name :: !.FormattedProfile !.FormattedProfile -> Bool;
le_profile_name {f_function_name = name1}	{f_function_name = name2}	= name1 <= name2

ge_profile_byte :: !.FormattedProfile !.FormattedProfile -> Bool;
ge_profile_byte {f_n_allocated_bytes = byte1}	{f_n_allocated_bytes = byte2}	= byte1 >= byte2

ge_profile_strict :: !.FormattedProfile !.FormattedProfile -> Bool;
ge_profile_strict {f_n_strict_calls = strict1} {f_n_strict_calls = strict2} = strict1 >= strict2

ge_profile_lazy :: !.FormattedProfile !.FormattedProfile -> Bool;
ge_profile_lazy {f_n_lazy_calls = lazy1} {f_n_lazy_calls = lazy2} = lazy1 >= lazy2

ge_profile_curried :: !.FormattedProfile !.FormattedProfile -> Bool;
ge_profile_curried {f_n_curried_calls = curry1} {f_n_curried_calls = curry2} = curry1 >= curry2

g_profile_time :: !.FormattedProfile !.FormattedProfile -> Bool;
g_profile_time {f_time = time1}			{f_time = time2}			= time1 > time2

l_profile_name :: !.FormattedProfile !.FormattedProfile -> Bool;
l_profile_name {f_function_name = name1}	{f_function_name = name2}	= name1 < name2

l_module_name :: !.FormattedProfile !.FormattedProfile -> Bool;
l_module_name {f_module_name = name1}	{f_module_name = name2}	= name1 < name2

le_module_name :: !.Profile !.Profile -> Bool;
le_module_name {module_name = name1}	{module_name = name2}	= name1 <= name2

g_profile_byte :: !.FormattedProfile !.FormattedProfile -> Bool;
g_profile_byte {f_n_allocated_bytes = byte1}	{f_n_allocated_bytes = byte2}	= byte1 > byte2

g_profile_strict :: !.FormattedProfile !.FormattedProfile -> Bool;
g_profile_strict {f_n_strict_calls = strict1} {f_n_strict_calls = strict2} = strict1 > strict2

g_profile_lazy :: !.FormattedProfile !.FormattedProfile -> Bool;
g_profile_lazy {f_n_lazy_calls = lazy1} {f_n_lazy_calls = lazy2} = lazy1 > lazy2

g_profile_curried :: !.FormattedProfile !.FormattedProfile -> Bool;
g_profile_curried {f_n_curried_calls = curry1} {f_n_curried_calls = curry2} = curry1 > curry2
/*
sort_by_time_function pst :== sort_and_redraw_window ge_profile_time pst
sort_by_function_name pst :== sort_and_redraw_window le_profile_name pst
sort_by_allocation_function pst	:== sort_and_redraw_window ge_profile_byte pst
sort_by_strict_function pst	:== sort_and_redraw_window ge_profile_strict pst
sort_by_lazy_function pst :== sort_and_redraw_window ge_profile_lazy pst
sort_by_curried_function pst :== sort_and_redraw_window ge_profile_curried pst

sort_and_redraw_window :: (FormattedProfile -> FormattedProfile -> .Bool) *(PSt *ProgState) -> *PSt *ProgState;
sort_and_redraw_window compare_function pst
	# (info,pst)			= accPLoc (\p=:{info}->(info,p)) pst
	# (ProfileInfo formatted_profile total_profile) = info
	# formatted_profile		= sortBy compare_function formatted_profile
	# pst 					= appPLoc (\p->{p & info = ProfileInfo formatted_profile total_profile}) pst
	# ((look,_),pst)		= window_update_function pst
	# (wId,pst)				= accPLoc (\p=:{wind}->(wind,p)) pst
	# pst					= appPIO (setWindowLook wId True (True,look)) pst
	= pst
*/
//-- Printing look

printTable :: Font !PrintSetup [.FormattedProfile] .FormattedProfile !*(PSt .a) -> *(PrintSetup,*PSt .a);
printTable printFont printSetup functionData sumData ps
//	# (s=:(ProfileInfo functionData sumData),ps)	= accPLoc (\l=:{info}->(info,l)) ps
//	# (printFont,ps)								= accPLoc (\l=:{monaco_font}->(monaco_font,l)) ps
//	# (printSetup,ps)								= accPLoc (\l=:{print_setup}->(print_setup,l)) ps
	# (doesntFit,newPrintSetup,ps)					= print2 True True (generate_pages printFont functionData sumData) printSetup ps
//	# ps											= appPLoc (\l->{l & print_setup = newPrintSetup}) ps
	| doesntFit
		# ps = openNotice (Notice ["The paper is not wide enough to","print all columns.",
										 "Try landscape format."] (NoticeButton "Ok" id) []) ps
		= (newPrintSetup,ps)
	= (newPrintSetup,ps)
where 
	generate_pages printFont functionData sumData { printSetup, jobInfo={ range=(first,last), copies } } picture
 		# {page=page=:{w=maxX,h=maxY},resolution=(horizontal_dpi,_)} = getPageDimensions printSetup True
// 		# widthFstColumn = maxX-Offset8-Pos0
//		# ((line_height,ascent),picture) = formatInfo printFont picture
		# (metrics,picture) = getFontMetrics printFont picture
		# line_height = fontLineHeight metrics
		# nrLinesPerPage = (maxY+1)/line_height
		# pages_without_sum = groupBy (nrLinesPerPage-2) functionData
		# printed_pages = pages_without_sum % (first-1,last-1)
		| isEmpty printed_pages
			= ([],picture,False)
		// ensure, that sum is always printed, regardless of the range of pages the user has choosen
		# (all_but_last,last_page) = splitAt ((length printed_pages)-1) printed_pages
		# last_page_1 = (hd last_page) % (0,nrLinesPerPage-4)	// there needs to be place for the sum line
		# new_last_page = last_page_1 ++ [sumData]
		# pages = all_but_last ++ [new_last_page]
		// ok
		# landscape = maxX > maxY;
		# column_positions=if landscape column_l_positions column_p_positions;
		# column_positions = PCorMac [pos*horizontal_dpi/72 \\ pos<- column_positions] column_positions;
		# page` = {x=maxX,y=maxY}
		# all_drawfuncs 
		    = map (\lines_in_one_page -> 
					print_table column_positions printFont (line_height,metrics) [{corner1=zero,corner2=page`}] {corner1=zero,corner2=page`} lines_in_one_page)
				  pages
		= (	flatten (repeatn copies all_drawfuncs ),
			picture,
			False
		  )
	where
		column_p_positions = [4,120,240,290,340,400,450,500,550,590]
		column_l_positions = [4,200,400,460,520,590,650,710,770,830]

		print_table cols printFont (line_height,{fLeading,fAscent,fDescent}) updArea newFrame=:{corner2={x=totalWidth}} lines picture
			# picture	= setPenFont printFont picture
			# picture	= draw_table_header cols (fLeading + fAscent) (fLeading+line_height+2) totalWidth picture
			# delta_text= fDescent + 1
			# picture	= draw_profile_lines delta_text cols lines (fLeading+line_height+4) line_height updArea picture
			= picture

groupBy :: !Int [x] -> [[x]]
groupBy n [] = []
groupBy n l = [(take n l ) : (groupBy n (drop n l))] 

print2 :: .Bool .Bool (PrintInfo -> .(*Picture -> *(.DrawFuns,*Picture,Bool))) PrintSetup *a -> (Bool,PrintSetup,*a) | PrintEnvironments a
print2 doDialog emulateScreen prFun printSetup printEnv
	# (alt,printEnv) = printPagePerPage doDialog emulateScreen 0 initFun stateTransition printSetup printEnv
	= case alt of
		StartedPrinting (_,usedPrintSetup,doesntFit) 	-> (doesntFit,usedPrintSetup,printEnv)
 		Cancelled _										-> (False,printSetup,printEnv)
where
	initFun :: .e .PrintInfo *Picture -> (.(Bool,Point2),(PrintState,*Picture))
  	initFun _ printInfo picture
  		# (drawFuns,picture,doesntFit) = prFun printInfo picture
  		= ((isEmpty drawFuns,zero), ((drawFuns,printInfo.printSetup,doesntFit),picture))

	stateTransition :: ((.[*Picture -> *Picture],.c,.d),*Picture) -> (.(Bool,e),(([*Picture -> *Picture],.c,.d),*Picture)) | zero e;
  	stateTransition (([drawFun:rest],printSetup,doesntFit),picture)
  		= ((isEmpty rest,zero), ((rest,printSetup,doesntFit), drawFun picture))
  	stateTransition (([],printSetup,doesntFit),picture)
  		= ((True,zero), (([],printSetup,doesntFit), picture))

:: PrintState :== (DrawFuns,PrintSetup,Bool)
:: DrawFuns :== [*Picture -> *Picture]
/*
doPrintSetupDialog :: *(PSt *ProgState) -> *PSt *ProgState;
doPrintSetupDialog ps
	# (printSetup,ps)	= accPLoc (\l=:{print_setup}->(print_setup,l)) ps
	# (printSetup,ps)	= printSetupDialog printSetup ps
	= appPLoc (\l->{l & print_setup = printSetup}) ps
*/
//-- Profile Look

//window_update_function :: *(PSt *ProgState) -> *(w:(x:a -> v:(.UpdateState -> u:(*Picture -> .Picture))),*PSt *ProgState), [u <= v, v <= x, v <= w];
/*
window_update_function ps
	# (font,ps) = accPLoc (\p=:{monaco_font}->(monaco_font,p)) ps
	# ({fAscent,fDescent},ps)
				= accPIO (accScreenPicture (getFontMetrics font)) ps
	# (info,ps) = accPLoc (\p=:{info}->(info,p)) ps
	# height	= case info of
					NoProfileInfo									-> 6 + QUICK_FIX
					(ProfileInfo formatted_profile total_profile)	-> 6+(fAscent+fDescent+1)*(2+length formatted_profile)+QUICK_FIX
	= ((drawfun info font,height),ps)
where
	drawfun NoProfileInfo _
		= no_draw
	where
		no_draw ss us=:{updArea} picture 
			= seq (map unfill updArea) picture

	drawfun (ProfileInfo formatted_profile total_profile) window_font
		= draw_profile
	where
		draw_profile ss us=:{updArea,newFrame={corner2={x=totalWidth}}} picture
			# picture		= seq (map unfill updArea) picture
			# (metrics,picture) = getFontMetrics window_font picture
			# line_height	= fontLineHeight metrics
			# picture		= setPenFont window_font picture
			# first_line	= QUICK_FIX
			# picture		= draw_profile_lines cols lines first_line line_height updArea picture
			= picture
		where
			lines = formatted_profile++[total_profile]
			cols = [col0,col1,col2,col3,col4,col5,col6,col7,col8,WidthFstColumn+totalWidth]
*/
QUICK_FIX :== 20
/*
formatInfo :: .Font *Picture -> (.(Int,Int),.Picture);
formatInfo window_font pict
	# ({fAscent,fDescent},pict)=getFontMetrics window_font pict
	# line_height=fAscent+fDescent+1
	= ((line_height,fAscent),pict)
*/
//--

//format_string_r :: .Int u:(a v:Char) -> a Char | Array .a, [u <= v];
format_string_r length string
	# string_size=size string
	| string_size >= length
		= string
		= (createArray (length-string_size) ' ')+++string

format_real :: .Int .Int .Int .Real .Real -> {#Char};
format_real n_spaces n d m r
	| r<0.0
		= format_negative_real (if (n_spaces<1) 0 (dec n_spaces)) n d m (~r)
	# s=toString (toInt (m*r))
	  l=size s
	| l<=d
		= createArray n_spaces ' ' +++ createArray n '0' +++"."+++createArray (d-l) '0'+++s
	| l<=n+d
		= createArray n_spaces ' ' +++ createArray (n+d-l) '0' +++insert_dot_in_string s l d
	| l<=n_spaces+n+d
		= createArray (n_spaces+n+d-l) ' '+++ insert_dot_in_string s l d
		= insert_dot_in_string s l d

format_negative_real :: .Int .Int .Int a a -> {#Char} | * , toInt a;
format_negative_real n_spaces n d m r
	# s=toString (toInt (m*r))
	  l=size s
	| l<=d
		= createArray n_spaces ' ' +++"-"+++ createArray n '0' +++"."+++ createArray (d-l) '0' +++s
	| l<=n+d
		= createArray n_spaces ' ' +++"-"+++ createArray (n+d-l) '0' +++insert_dot_in_string s l d
	| l<=n_spaces+n+d
		= createArray (n_spaces+n+d-l) ' ' +++ "-"+++insert_dot_in_string s l d
		= "-"+++insert_dot_in_string s l d

insert_dot_in_string :: {#.Char} .Int .Int -> {#Char};
insert_dot_in_string s l d = s % (0,l-1-d) +++"."+++ s % (l-d,l-1)

format_profile :: .Int .Int .Int .Int .Real [.Profile] -> ([.FormattedProfile],.FormattedProfile);
format_profile total_strict_calls total_lazy_calls total_curried_calls total_allocation total_time profile_list
	= ([format_profile p \\ p<-profile_list],
	   { f_module_name			= "All Modules"
	   , f_function_name		= "Total"
	   , f_n_strict_calls		= total_strict_calls
	   , f_n_lazy_calls			= total_lazy_calls
	   , f_n_curried_calls		= total_curried_calls
	   , f_n_allocated_bytes	= PCorMac total_allocation (total_allocation<<2)
	   , f_alloc_percentage		= 100.0
	   , f_time					= total_time
	   , f_time_percentage		= 100.0
	   })
where
	format_profile {module_name,function_name,n_strict_calls,n_lazy_calls,n_curried_calls,n_allocated_words,time} =
		{ f_module_name			= module_name
		, f_function_name		= function_name
		, f_time				= time
		, f_time_percentage		= (time*100.0)/total_time
		, f_n_allocated_bytes	= PCorMac n_allocated_words (n_allocated_words<<2)
		, f_alloc_percentage	= (toReal (n_allocated_words)*100.0)/toReal total_allocation
		, f_n_strict_calls		= n_strict_calls
		, f_n_lazy_calls		= n_lazy_calls
		, f_n_curried_calls		= n_curried_calls
		}

//-- Draw funs

(>:) infixl
(>:) f g:== g f

drawLeft :: !.Point2 !.{#Char} !*Picture -> *Picture;
drawLeft position=:{x} s picture
	# (width,picture)	= getPenFontStringWidth s picture
	= drawAt {position & x = x - width} s picture


myGrey = RGB {r=MaxRGB*9/10,g= MaxRGB*9/10,b= MaxRGB*9/10}

draw_profile_lines :: .Int [.Int] ![.FormattedProfile] .Int .Int UpdateArea *Picture -> *Picture;
draw_profile_lines delta_text cols lines top line_height area picture
	# y = top + line_height - delta_text
	= draw_profile_lines False lines y picture
where
//	delta_text = 2
	
	in_area y [{corner1={y=y1},corner2={y=y2}}:areas]
		= (y >= y1-line_height && y <= y2+line_height) || in_area y areas
	in_area y []
		= False
	
	draw_profile_lines _ [] y picture
		= picture
	draw_profile_lines background_box [{f_module_name,f_function_name,f_time,f_time_percentage,f_n_allocated_bytes,f_alloc_percentage,f_n_strict_calls,f_n_lazy_calls,f_n_curried_calls}:lines] y picture
		| not (in_area y area)
			= draw_profile_lines (not background_box) lines (y+line_height) picture
		# y_pos
			= y
		# picture 
			= case background_box of
				True
					# picture
						= setPenColour myGrey picture
					# picture
						= fill {corner1={x=col0,y=y_pos-line_height + delta_text},corner2={x=col9,y=y_pos + delta_text}} picture
					-> setPenColour Black picture
				False
//					# picture
//						= setPenColour White picture
					# picture
						= unfill {corner1={x=col0,y=y_pos-line_height + delta_text},corner2={x=col9,y=y_pos + delta_text}} picture
					-> picture	//setPenColour Black picture
		# (cs1,picture) = cut_string f_module_name wdthFstCol picture
		# (cs2,picture) = cut_string f_function_name wdthSndCol picture
		# picture=picture
			>: drawAt {x=col0+5,y=y} cs1
			>: drawAt {x=col1+5,y=y} cs2
			>: drawLeft {x=col3-4,y=y} (format_real 0 1 6 1000000.0 f_time)
			>: drawLeft {x=col4-4,y=y} (format_real 0 2 3 1000.0 f_time_percentage)
			>: drawLeft {x=col5-4,y=y} (toString f_n_allocated_bytes)
			>: drawLeft {x=col6-4,y=y} (format_real 0 2 3 1000.0 (f_alloc_percentage))
			>: drawLeft {x=col7-4,y=y} (toString f_n_strict_calls)
			>: drawLeft {x=col8-4,y=y} (toString f_n_lazy_calls)
			>: drawLeft {x=col9-4,y=y} (toString f_n_curried_calls)
		= draw_profile_lines (not background_box) lines (y+line_height) picture

	col0 = cols!!0//Pos0
	col1 = cols!!1//wdthFstCol+Offset2
	col2 = cols!!2//wdthFstCol+Offset3
	col3 = cols!!3//wdthFstCol+Offset4
	col4 = cols!!4//wdthFstCol+Offset5
	col5 = cols!!5//wdthFstCol+Offset6
	col6 = cols!!6//wdthFstCol+Offset7
	col7 = cols!!7//wdthFstCol+Offset8
	col8 = cols!!8//wdthFstCol+totalWidth
	col9 = cols!!9
	col10 = cols!!10
	
	wdthFstCol = col1 - col0 - 10
	wdthSndCol = col2 - col1 - 10

// poging tot geinverteerde versie van draw_profile_lines
draw_profile_lines` :: .Int [.Int] ![.FormattedProfile] .Int .Int !UpdateArea *Picture -> *Picture;
draw_profile_lines` _ _ _ _ _ [] picture = picture
draw_profile_lines` _ _ [] _ _ _ picture = picture
draw_profile_lines` delta_text cols lines top line_height [area:rest] picture
	# (s,f) = rect_lines area
	# picture = draw_profile_lines (isEven s) s f (top + line_height + (s * line_height) - delta_text) picture
	
	= draw_profile_lines` delta_text cols lines top line_height rest picture
where
//	delta_text = 2
	
//	base_y = top + line_height - delta_text
	maxline = dec (length lines)
	
	rect_lines {corner1={y=y1},corner2={y=y2}}
		= (max 0 ((y1-top)/line_height), min maxline ((y2-top)/line_height))
	
	draw_profile_lines
		background_box
		s f
		y_pos picture
		| s > f = picture
		# {f_module_name,f_function_name,f_time,f_time_percentage,f_n_allocated_bytes,f_alloc_percentage,f_n_strict_calls,f_n_lazy_calls,f_n_curried_calls} = lines!!s
		# picture 
			= case background_box of
				True
					# picture
						= setPenColour myGrey picture
					# picture
						= fill {corner1={x=col0,y=y_pos-line_height + delta_text},corner2={x=col10,y=y_pos + delta_text}} picture
					-> setPenColour Black picture
				False
//					# picture
//						= setPenColour White picture
					# picture
						= unfill {corner1={x=col0,y=y_pos-line_height + delta_text},corner2={x=col10,y=y_pos + delta_text}} picture
					-> picture	//setPenColour Black picture
		# (cs1,picture) = cut_string f_module_name wdthFstCol picture
		# (cs2,picture) = cut_string f_function_name wdthSndCol picture
		# picture=picture
			>: drawAt {x=col0+5,y=y_pos} cs1
			>: drawAt {x=col1+5,y=y_pos} cs2
			>: drawClipLeft (col2+5) {x=col3-5,y=y_pos} (format_real 6 1 6 1000000.0 f_time)
			>: drawClipLeft (col3+5) {x=col4-5,y=y_pos} (format_real 2 2 3 1000.0 f_time_percentage)
			>: drawClipLeft (col4+5) {x=col5-5,y=y_pos} (format_string_r 12 (toString f_n_allocated_bytes))
			>: drawClipLeft (col5+5) {x=col6-5,y=y_pos} (format_real 2 2 3 1000.0 (f_alloc_percentage))
			>: drawClipLeft (col6+5) {x=col7-5,y=y_pos} (format_string_r 10 (toString f_n_strict_calls))
			>: drawClipLeft (col7+5) {x=col8-5,y=y_pos} (format_string_r 10 (toString f_n_lazy_calls))
			>: drawClipLeft (col8+5) {x=col9-5,y=y_pos} (format_string_r 10 (toString f_n_curried_calls))
		= draw_profile_lines (not background_box) (inc s) f (y_pos+line_height) picture

	drawClipLeft :: !.Int !.Point2 !.{#Char} !*Picture -> *Picture;

//	drawClipLeft _ position str picture = drawLeft position str picture
	
	drawClipLeft minx position=:{x,y} str picture
		= appClipPicture (toRegion {corner1={x=minx,y=y-20},corner2={x=x,y=y+20}}) (drawLeft position str) picture
	
//	drawClipLeft minx position=:{x,y} str picture
//		= appClipPicture (toRegion {corner1={x=minx,y=y-20},corner2={x=x,y=y+20}}) (drawAt {position & x = minx} str) picture

/*
	drawClipLeft minx position=:{x} str picture
		# (width,picture)	= getPenFontStringWidth str picture
		| width < wid
			= drawAt {position & x = x - width} str picture
		# (cs,picture) = cut_string str wid picture
		# (width,picture)	= getPenFontStringWidth cs picture
		| width < wid
			= drawAt {position & x = x - width} cs picture
		= picture
	where
		wid = x - minx
*/	

	col0 = cols!!0//Pos0
	col1 = cols!!1//wdthFstCol+Offset2
	col2 = cols!!2//wdthFstCol+Offset3
	col3 = cols!!3//wdthFstCol+Offset4
	col4 = cols!!4//wdthFstCol+Offset5
	col5 = cols!!5//wdthFstCol+Offset6
	col6 = cols!!6//wdthFstCol+Offset7
	col7 = cols!!7//wdthFstCol+Offset8
	col8 = cols!!8//wdthFstCol+totalWidth
	col9 = cols!!9
	col10 = cols!!10
	
	wdthFstCol = col1 - col0 - 10
	wdthSndCol = col2 - col1 - 10

Pos0:==4
WidthFstColumn :== 280
WidthSndColumn :== 280
Offset1:==0
Offset2:==100
Offset3:==160
Offset4:==240
Offset5:==280
Offset6:==330
Offset7:==395
Offset8:==475

col0 = Pos0
col1 = col0 + WidthSndColumn
col2 = WidthFstColumn+ WidthSndColumn+Offset2
col3 = WidthFstColumn+ WidthSndColumn+Offset3
col4 = WidthFstColumn+ WidthSndColumn+Offset4
col5 = WidthFstColumn+ WidthSndColumn+Offset5
col6 = WidthFstColumn+ WidthSndColumn+Offset6
col7 = WidthFstColumn+ WidthSndColumn+Offset7
col8 = WidthFstColumn+ WidthSndColumn+Offset8
//col8 = WidthFstColumn+totalWidth

cut_string :: .String .Int *Picture -> (String,*Picture);
// hoef je alleen opnieuw te bepalen bij verplaatsen colom dus niet in standaard look...?
// analoog geldt voor formatting funs...
cut_string str width pic
	# (wid,pic) = getPenFontStringWidth str pic
	| wid <= width
		= (str,pic)
	# (fitting_string,pic) = firstAfterList f l pic
	| isNothing fitting_string
		= ("",pic)
//		= abort "This program has a bug. It was wrongly assumed, that the first column is wide enough" 
	= (fromJust fitting_string,pic)
where
	f cut_str pic
		# (w,pic) = getPenFontStringWidth cut_str pic
		= (w > width,pic)

	l = [(str % (0,n))+++"..." \\ n <- reverse [0..(size str)-1]]

	firstAfterList f [] s = (Nothing,s)
	firstAfterList f [h:t] s
		# (b,s) = f h s
		| b
			= firstAfterList f t s
		= (Just h,s)

//draw_table_header :: !Int .Int .Int .Int *Picture -> *Picture
draw_table_header cols y line_y window_width picture
	= picture
//		>: unfill {corner1={x=0,y=0},corner2={x=window_width,y=line_y}}
		>: drawAt {x=cols!!0+5,y=y} "Module"
		>: drawAt {x=cols!!1+5,y=y} "Function"
		>: drawLeft {x=cols!!3,y=y} "Time(s)"
		>: drawLeft {x=cols!!4,y=y} "Time(%)"
		>: drawLeft {x=cols!!5,y=y} "Alloc(bytes)"
		>: drawLeft {x=cols!!6,y=y} "Alloc(%)"
		>: drawLeft {x=cols!!7,y=y} "Strict(n)"
		>: drawLeft {x=cols!!8,y=y} "Lazy(n)"
		>: drawLeft {x=cols!!9,y=y} "Curried(n)"
		>: drawLine {x=0,y=line_y} {x=window_width,y=line_y}

