/*
** Program: Clean Prover System
** Module:  ShowDefinition (.icl)
** 
** Author:  Maarten de Mol
** Created: 28 September 1999
*/

implementation module 
	ShowDefinition

import 
	StdEnv,
	StdIO,
	States,
	MarkUpText,
//	ListBox,
	RWSDebug

/*
// ------------------------------------------------------------------------------------------------------------------------   
pickDefinition :: !*PState -> !*PState
// ------------------------------------------------------------------------------------------------------------------------   
pickDefinition pstate
	# (opened, pstate)			= isWindowOpened DlgShowDefinitions True pstate
	| opened					= pstate
	# (winfo, pstate)			= new_Window DlgShowDefinitions pstate
	# dialog_id					= winfo.wiWindowId
	# (modules_textid, pstate)	= accPIO openId pstate
	# (modules_lbid, pstate)	= accPIO (openListBoxId dialog_id) pstate
	# (kind_textid, pstate)		= accPIO openId pstate
	# (kind_lbid, pstate)		= accPIO (openListBoxId dialog_id) pstate
	# (def_textid, pstate)		= accPIO openId pstate
	# (def_lbid, pstate)		= accPIO (openListBoxId dialog_id) pstate
	# (dialog, pstate)			= PickDefDLG dialog_id modules_textid modules_lbid kind_textid kind_lbid def_textid def_lbid pstate
	= snd (openDialog 0 dialog pstate)

// ------------------------------------------------------------------------------------------------------------------------   
:: ModuleInfo =
// ------------------------------------------------------------------------------------------------------------------------   
	{	miPtr		:: !ModulePtr
	,	miName		:: !ModuleName
	}
	
// ------------------------------------------------------------------------------------------------------------------------   
instance toString ModuleInfo
// ------------------------------------------------------------------------------------------------------------------------   
where
	toString modinfo
		= modinfo.miName

// ------------------------------------------------------------------------------------------------------------------------   
instance toString DefinitionInfo
// ------------------------------------------------------------------------------------------------------------------------   
where
	toString definfo
		= definfo.diName

// ------------------------------------------------------------------------------------------------------------------------   
buildModuleInfo :: !*CHeaps !*CProject -> ([!ModuleInfo], !*CHeaps, !*CProject)
// ------------------------------------------------------------------------------------------------------------------------   
buildModuleInfo heaps prj
	# (mod_ptrs, prj)			= prj!prjModules
	# (mod_names, heaps)		= getPointerNames mod_ptrs heaps
	# mod_infos					= [{miPtr = ptr, miName = name} \\ ptr <- mod_ptrs & name <- mod_names]
	# predef_info				= {miPtr = nilPtr, miName = "###PREDEFINED###"}
	= ([predef_info:mod_infos], heaps, prj)

// BEZIG
// ------------------------------------------------------------------------------------------------------------------------   
// PickDefDLG :: Id -> Dialog _ _ _
// ------------------------------------------------------------------------------------------------------------------------   
PickDefDLG own_id modules_textid modules_lbid kind_textid kind_lbid def_textid def_lbid pstate
	# (modules, pstate)			= accHeapsProject buildModuleInfo pstate
	# modules					= sortBy (\m1 m2 -> m1.miName < m2.miName) modules
	= (	Dialog "Pick a definition"
		(	TextControl			"Pick modules:"
									[ ControlId				modules_textid
									]
		:+:	TextListBoxControl  modules [] MultiSelect 25
									[ ListBoxPos			(Below modules_textid, zero)
									, ListBoxId				modules_lbid
									, ListBoxFont			{fName = "Courier New", fSize=10, fStyles=[]}
									, ListBoxBackgroundColour	AlmostWhite
									, ListBoxHiliteColour		AlmostWhiteHilite
									, ListBoxEventHandler	(\event default_handler state -> set_definitions (default_handler state))
									]
		:+:	TextListBoxControl	(map snd kinds) [5] SingleSelect (length kinds)
									[ ListBoxId				kind_lbid
									, ListBoxPos			(RightToListBox modules_lbid, zero)
									, ListBoxFont			{fName = "Courier New", fSize=10, fStyles=[]}
									, ListBoxBackgroundColour	AlmostWhite
									, ListBoxHiliteColour		AlmostWhiteHilite
									, ListBoxEventHandler	(\event default_handler state -> set_definitions (default_handler state))
									]
		:+: TextControl			"Pick kind:"
									[ ControlId				kind_textid
									, ControlPos			(AboveListBox kind_lbid, zero)
									]
		:+: typed_listbox			[ ListBoxId				def_lbid
									, ListBoxPos			(RightToListBox kind_lbid, zero)
									, ListBoxFont			{fName = "Courier New", fSize=10, fStyles=[]}
									, ListBoxBackgroundColour	AlmostWhite
									, ListBoxHiliteColour		AlmostWhiteHilite
									, ListBoxWidth			350
									, ListBoxEventHandler  catch_double_click
									]
		:+: TextControl 		"Pick definition:"
									[ ControlId				def_textid
									, ControlPos			(AboveListBox def_lbid, zero)
									]
		)
		[ WindowId				own_id
		, WindowPos				(Fix, OffsetVector {vx=100,vy=100})
		, WindowClose			(noLS (close_Window DlgShowDefinitions))
		]
	  , pstate)
	where
		kinds					= [(CAlgType, "Algebraic Types"), (CClass, "Classes"), (CMember, "Class Members"), (CInstance, "Class Instances"),
								   (CDataCons, "Dataconstructors"), (CFun, "Functions"),
								   (CRecordField, "Record Fields"), (CRecordType, "Record Types")]
		
		typed_listbox :: [ListBoxAttribute DefinitionInfo *PState] -> (ListBoxState DefinitionInfo Int *PState)
		typed_listbox atts = TextListBoxControl [] [] SingleSelect 25 atts
		
		set_definitions :: *PState -> *PState
		set_definitions pstate 
			# (mbe_selected_modules_indexes, pstate)	= getListBoxSelection modules_lbid pstate
			# selected_modules_indexes					= fromJust mbe_selected_modules_indexes
			# (mbe_modules, pstate)						= getListBoxItems modules_lbid pstate
			# modules									= fromJust mbe_modules
			# selected_modules							= [modules !! index \\ index <- selected_modules_indexes]
			# selected_modules_ptrs						= map (\mi -> mi.miPtr) selected_modules
			# (mbe_selected_kind_index, pstate)			= getListBoxSelection kind_lbid pstate
			# selected_kind_index						= fromJust mbe_selected_kind_index
			# kind										= fst (kinds !! (hd selected_kind_index))
			# (error, ptrs, pstate)						= accErrorHeaps (getHeapPtrs selected_modules_ptrs [kind]) pstate
			| isError error								= showError error pstate
			# (error, definitions, pstate)				= accErrorHeapsProject (uumapError getDefinitionInfo ptrs) pstate
			| isError error								= showError error pstate
			# (show_records, pstate)					= pstate!ls.stDisplayOptions.optShowRecordFuns
			# definitions								= if show_records definitions (filter check_select_name definitions)
			# definitions								= if show_records definitions (filter check_update_name definitions)
			# (show_dictionaries, pstate)				= pstate!ls.stDisplayOptions.optShowDictionaries
			# definitions								= if show_dictionaries definitions (filter check_dict_name definitions)
			# (show_tupleselects, pstate)				= pstate!ls.stDisplayOptions.optShowTupleFuns
			# definitions								= if show_tupleselects definitions (filter check_tselect_name definitions)
			# definitions								= sortBy (\di1 di2 -> di1.diName < di2.diName) definitions
			# pstate									= setListBoxItems def_lbid definitions [] 0 pstate
			= pstate
			where
				check_select_name def	= not (substring "_select_" def.diName)
				check_update_name def	= not (substring "_update_" def.diName)
				check_dict_name def		= not (substring "dictionary_" def.diName)
				check_tselect_name def	= not (substring "_tupleselect_" def.diName)
		
		substring :: !String !String -> Bool
		substring sub whole
			# sub			= [c \\ c <-: sub]
			# whole			= [c \\ c <-: whole]
			= check_list sub whole
			where
				check_list [c:cs] [d:ds]
					# init				= isinit [c:cs] [d:ds]
					| init				= True
					= check_list [c:cs] ds
				check_list _ []
					= False
				
				isinit [] whole			= True
				isinit [c:cs] [d:ds]	= if (c == d) (isinit cs ds) False
				isinit _ _				= False
			
		catch_double_click :: ListBoxEvent (IdFun *PState) *PState -> *PState
		catch_double_click (ExecuteItem index) defaultaction state
			# pstate								= defaultaction state
			# (maybe_items, pstate)					= getListBoxItems def_lbid pstate
			# items									= fromJust maybe_items
			# selected_item							= items !! index
			= showDefinition selected_item.diPointer pstate
		catch_double_click other defaultaction pstate
			= defaultaction pstate
*/

// ------------------------------------------------------------------------------------------------------------------------   
showDefinition :: !HeapPtr !*PState -> *PState
// ------------------------------------------------------------------------------------------------------------------------   
showDefinition defptr pstate
	# (opened, pstate)			= isWindowOpened (WinDefinition defptr) True pstate
	| opened					= pstate
	# (winfo, pstate)			= new_Window (WinDefinition defptr) pstate
	# id						= winfo.wiWindowId
	# rid						= fromJust winfo.wiSpecialRId
	# module_ptr				= ptrModule defptr
	# (error, name, pstate)		= accErrorHeapsProject (getDefinitionName defptr) pstate
	| isError error				= showError error pstate
	# (finfo, pstate)			= makeFormatInfo pstate
	# (error, ftext, pstate)	= show finfo defptr pstate
	| isError error				= showError error pstate
	# (modname, pstate)			= case isNilPtr module_ptr of
									True	-> ("###PREDEFINED###", pstate)
									False	-> accHeaps (getPointerName module_ptr) pstate
	# (vector, pstate)			= placeWindow {w=600,h=300} pstate
	# (extended_bg, pstate)		= pstate!ls.stDisplayOptions.optDefinitionWindowBG
	# bg						= toColour 0 extended_bg
	= MarkUpWindow (name +++ " in module " +++ modname) ftext 
		[ MarkUpBackgroundColour	bg
		, MarkUpMaxWidth			600
		, MarkUpMaxHeight			350
		, MarkUpFontFace			"Courier New"
		, MarkUpTextSize			10
		, MarkUpLinkStyle			False Black bg True Blue bg
		, MarkUpEventHandler		(clickHandler (click_handler rid))
		, MarkUpReceiver			rid
		, MarkUpIgnoreMultipleSpaces
		]
		[ WindowId					id
		, WindowClose				(noLS (close_Window (WinDefinition defptr)))
		, WindowPos					(LeftTop, OffsetVector vector)
		] pstate
	where
		click_handler :: !(RId (MarkUpMessage WindowCommand)) !WindowCommand !*PState -> *PState
		click_handler rid CmdRefreshAlways pstate
			# (finfo, pstate)					= makeFormatInfo pstate
			# (error, ftext, pstate)			= show finfo defptr pstate
			| isError error						= showError error pstate
			# pstate							= changeMarkUpText rid ftext pstate
			= pstate
		click_handler rid (CmdRefresh ChangedDisplayOption) pstate
			# (finfo, pstate)					= makeFormatInfo pstate
			# (error, ftext, pstate)			= show finfo defptr pstate
			| isError error						= showError error pstate
			# pstate							= changeMarkUpText rid ftext pstate
			= pstate
		click_handler rid (CmdRefresh (RemovedCleanModules ptrs)) pstate
			# mod_ptr							= ptrModule defptr
			| isMember mod_ptr ptrs				= close_Window (WinDefinition defptr) pstate
			= pstate
		click_handler rid (CmdShowDefinition ptr) pstate
			= showDefinition ptr pstate
		click_handler rid command pstate
			= pstate
		
		show :: !FormatInfo !HeapPtr !*PState -> (!Error, !MarkUpText WindowCommand, !*PState)
		show finfo ptr pstate
			# state								= pstate.ls
			# heaps								= state.stHeaps
			# prj								= state.stProject
			# (error, ftext, heaps, prj)		= formattedShow ptr finfo heaps prj
			# state								= {state & stHeaps = heaps, stProject = prj}
			# pstate							= {pstate & ls = state}
			| isError error						= (error, DummyValue, pstate)
			= (OK, changeCmLink CmdShowDefinition ftext, pstate)