implement Project Directory Up and Down

Ide/IDE.icl

@@ -10,13 +10,13 @@ import PmParse
 import PmPath
 
 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 finder import sr_find, sr_find_next, sr_find_sel, sr_rep_find, sr_goto_cursor,
+				   sr_goto_line, sr_goto_selection
 from edoptions import defaultFontAndTabs, optionsKeyMapping, editColours
 
-from EdClient import :: EditAction, isEditWin, msgGetPathName,msgSelectAll
-from EdClient import emptySelection, sendToActiveWindow, msgGetSelection
-from EdClient import msgUndo,msgPaste,msgCopy,msgCut,msgClear,msgBalance,msgDetab
+from EdClient import :: EditAction, isEditWin, msgGetPathName,msgSelectAll,
+					 emptySelection, sendToActiveWindow, msgGetSelection,
+					 msgUndo,msgPaste,msgCopy,msgCut,msgClear,msgBalance,msgDetab
 import prefix, tools
 
 import IdeState
@@ -88,25 +88,16 @@ Start world
 							  }
 	# (interact, force_update, proj_path, logfile, world)
 							=	batchOptions world
-	#!	(iniClip,pub,world)	= iniGeneral
-								prefs
-								stup
-								interact logfile
-								mTargetId
-								eTargetId
-								lbId
+	#!	(iniClip,pub,world)	= iniGeneral prefs stup interact logfile
+								mTargetId eTargetId lbId
 								(initEditorState keymap)
-								emptyFindInfo
-								ffind
-								mEdUndoId
-								mMdEdOptId
+								emptyFindInfo ffind
+								mEdUndoId mMdEdOptId
 								iniTwi
 // winOnly?
 								iniCons
 								iniTargets
-								mProjectId
-								mPrListId
-								mPrRecId
+								mProjectId mPrListId mPrRecId
 								world
 	#	patt				=	[ ProcessClose (Quit prefspath)
 								, ProcessOpenFiles openfiles
@@ -467,6 +458,8 @@ projectMenu
 			, MenuId (projIds!!12)
 			, MenuSelectState Unable
 			]
+	:+:	MenuItem "Project Directory Up" [MenuFunction (noLS project_directory_up)]
+	:+:	MenuItem "Project Directory Down" [MenuFunction (noLS project_directory_down)]
 	:+:	MenuItem "Project Defaults..."
 			[ MenuFunction (noLS projectDefaults)
 			]

Ide/PmDialogues.dcl

@@ -6,6 +6,9 @@ import PmTypes, PmProject, IdeState
 projectOptions	:: !(PSt General) -> PSt General
 projectDefaults	:: !(PSt General) -> PSt General
 
+project_directory_up :: !(PSt General) -> PSt General
+project_directory_down :: !(PSt General) -> PSt General
+
 doPathsDialog	::					// Display a Paths dialogue
 	!String										// Dialogue title string
 	!Pathname									// Application path

Ide/PmDialogues.icl

@@ -5,8 +5,8 @@ import StdFileSelect,StdPStClass,StdWindow
 import PmTypes, PmProject, PmPath, UtilStrictLists
 import tabcontrol, ExtListBox, ioutil, IdeState
 import ExtNotice, UtilObjectIO
-
 import Platform, morecontrols
+from projwin import pm_update_project_window
 
 :: PO_LS =
 	{ ao	:: !ApplicationOptions
@@ -40,8 +40,7 @@ projectDialog actualProject ps`
 			#(dp,ps)		= getCurrentPaths ps
 			# prj			= PR_SetPaths False dp ret.paths prj
 			# (appPath,ps)	= getStup ps
-			# (prjPath,ps)	= getProjectFilePath ps
-			# prjPath		= RemoveFilename prjPath
+			# prjPath = PR_GetRootDir prj
 			# prj			= PR_SetExecPath ret.xp prj
 			# prj			= PR_SetStaticLibsInfo ret.sl prj
 			# (xxId,ps)		= getPWX ps
@@ -83,15 +82,16 @@ where
 	(lbdlibId,ps4)	= openExtListBoxId ps3
 	(lbslibId,ps5)	= openExtListBoxId ps4
 	(ap,ps6)		= getStup ps5
-	(pp,ps7)		= fix (getProjectFilePath ps6) where fix (l,r) = (RemoveFilename l,r)
+	pp = PR_GetRootDir project
 	(prefs,ps)		= PlatformDependant
-						(getPrefs ps7)	// Win
+						(getPrefs ps6)	// Win
 						(getPrefs ps9)	// Mac
 // mac only...
 	(fontNames`, ps8)
-					= accPIO (accScreenPicture getFontNames) ps7		// filteren naar alleen fixed width fonts....
+					= accPIO (accScreenPicture getFontNames) ps6		// filteren naar alleen fixed width fonts....
 //	(fixed,ps9)		= seqList (map (\f->accPIO (accScreenPicture (lisFixedWidth f))) fontNames`) ps8
 	(fixed,ps9)		= accPIO (accScreenPicture (seqList (map lisFixedWidth fontNames`))) ps8
+
 	fontNames		= lfilter fixed fontNames`
 	fontSizes		= [7, 8, 9, 10, 12, 14, 18, 24 ]
 	inifn			= ao.fn
@@ -170,7 +170,7 @@ where
 	setexe (ls,ps)
 		# (prjPath,ps)	= getProjectFilePath ps
 		# prjName		= RemoveSuffix (RemovePath prjPath)
-		# prjPath		= RemoveFilename prjPath
+		# prjPath = pp
 		# (exename,ps)	= PlatformDependant
 							(selectOutputFile` "Executable" "*.exe" "Set" ps)	// win
 							(selectOutputFile "Executable" prjName ps)	// mac
@@ -395,8 +395,7 @@ where
 
 	make_sym_path name ps
 		# (appPath,ps)	= getStup ps
-		# (prjPath,ps)	= getProjectFilePath ps
-		# prjPath		= RemoveFilename prjPath
+		  prjPath = pp
 		= (symPath appPath prjPath name,ps)
 		
 	objectsPane = Pane "Extra Objects"
@@ -645,6 +644,38 @@ setCheckControlMark full id io
 		True	-> markCheckControlItems id [1] io
 		False	-> unmarkCheckControlItems id [1] io
 
+project_directory_up :: !(PSt General) -> PSt General
+project_directory_up ps
+	# (project,ps) = getProject ps
+	| not (PR_ProjectSet project)
+		= okNotice ["No open project"] ps
+	# (project_file_path,ps) = getProjectFilePath ps
+	  project_file_dir = RemoveFilename project_file_path
+	  relative_root_dir = PR_GetRelativeRootDir project
+	  parent_project_dir = make_project_dir (size relative_root_dir+1) project_file_dir
+	| size parent_project_dir==0 || parent_project_dir==PR_GetRootDir project
+		= okNotice ["Project directory cannot be moved further up"] ps
+	# relative_root_dir = relative_root_dir+++"."
+	  project = change_root_directory_of_project relative_root_dir parent_project_dir project
+	  ps = setProject project ps
+	= pm_update_project_window ps
+
+project_directory_down :: !(PSt General) -> PSt General
+project_directory_down ps
+	# (project,ps) = getProject ps
+	| not (PR_ProjectSet project)
+		= okNotice ["No open project"] ps
+	# (project_file_path,ps) = getProjectFilePath ps
+	  project_file_dir = RemoveFilename project_file_path
+	  relative_root_dir = PR_GetRelativeRootDir project
+	  child_project_dir = make_project_dir (size relative_root_dir-1) project_file_dir
+	| size relative_root_dir<=1 || child_project_dir==PR_GetRootDir project
+		= okNotice ["Project directory cannot be moved further down"] ps	
+	# relative_root_dir = relative_root_dir % (0,size relative_root_dir-2)
+	  project = change_root_directory_of_project relative_root_dir child_project_dir project
+	  ps = setProject project ps
+	= pm_update_project_window ps
+
 doPathsDialog :: !String !Pathname !Pathname !(List Pathname) ((List Pathname) (PSt .l) -> (PSt .l)) (PSt .l) -> (PSt .l)
 doPathsDialog titlestring ap pp lo set ps
 	#	(wid,ps)	= openId ps

Ide/projwin.icl

@@ -13,6 +13,7 @@ import ioutil, morecontrols, colorpickcontrol
 import projmen, menubar, colourclip
 //from IDE import OpenModule
 import Platform, IdePlatform
+import PmDirCache, UtilIO
 
 //-- Project Window Options...
 
@@ -475,8 +476,7 @@ pm_update_project_window_interactive ps
 						Just ws		-> getControlViewDomain lbId.controlId ws
 	# (srcpaths,ps)	= getProjwinPaths ps
 	# (appPath,ps)	= getStup ps
-	# (prjPath,ps)	= getProjectFilePath ps
-	# prjPath		= RemoveFilename prjPath
+	  (prjPath,ps) = getFromProject PR_GetRootDir ps
 	# lbItems		= items srcpaths appPath prjPath modules prefs.prj_prefs.proj_shft
 	# ps			= appendExtListBoxItems lbId lbItems ps
 	# ps			= case mframe of
@@ -499,7 +499,6 @@ where
 		# mods					= filter isInPaths mods
 		# mods					= sortBy (\(a,b,_,_) (c,d,_,_) -> less a b c d) mods
 		# moditems				= makenice True "" mods
-//		# rootitem				= (GetModuleName root, OpenModule (MakeImpPathname root) emptySelection, openif root)
 		# rootitem				= (GetModuleName root, open_imp rootdir (MakeImpPathname root), openif rootdir root)
 		= [rootitem:moditems]
 	where
@@ -516,8 +515,8 @@ where
 			# (exists,ps)	= accFiles (FExists path) ps
 			| exists
 				= ed_open_path_sel path emptySelection ps
-			# imppath		= MakeImpPathname root
-			= open_imp rootdir imppath ps
+				= open_imp rootdir (MakeImpPathname root) ps
+
 		less a b c d
 			| before b d = True		// use < -ordening of searchpaths...
 			| b == d
@@ -730,9 +729,8 @@ where
 		| not ok
 			= ps
 		# (lo,ps)	= getFromProject PR_GetLinkOptions ps
-		# (prj_path,ps)				= getProjectFilePath ps
+		  (prj_path`,ps) = getFromProject PR_GetRootDir ps
 		# (app_path,ps)				= getStup ps
-		# prj_path`					= RemoveFilename prj_path
 		# execpath					= fulPath app_path prj_path` execpath
 		| lo.method == LM_Dynamic
 			# execpath				= (RemoveSuffix` execpath) +++. ".bat"
@@ -742,9 +740,8 @@ where
 pm_run :: !*(PSt *General) -> *PSt *General;
 pm_run ps
 	# (app_path,ps)				= getStup ps
-	# (prj_path,ps)				= getProjectFilePath ps
+	  (prj_path`,ps) = getFromProject PR_GetRootDir ps
 	# (execpath,ps)				= getFromProject PR_GetExecPath ps
-	# prj_path`					= RemoveFilename prj_path
 	# execpath					= fulPath app_path prj_path` execpath
 	# (lo,ps)					= getFromProject PR_GetLinkOptions ps
 	| lo.method == LM_Dynamic
@@ -785,7 +782,7 @@ pm_copt ps
 	//-> only for module + ide, now added cursel in projwin
 	// current active added... (need to check if active is part of project...)
 	# (lbId,ps)			= getPWI ps
-	# (project,ps)		= accProject (\l->(l,l)) ps
+	# (project,ps)		= getFromProject (\l->l) ps
 	# (path,ps)			= sendToActiveWindow msgGetPathName ps
 	| isJust path
 		# path			= fromJust path
@@ -842,7 +839,6 @@ getActiveModules ps
 			# sel			= map (MakeImpPathname o fst) sel
 			# (sel,ps)		= seqList (map findModule sel) ps
 			# sel			= [fromJust m \\ m <- sel | isJust m]
-//			# ps = trace_n` ("Sel",listToString sel) ps
 			= (sel,ps)
 		= ([],ps)
 	#	winpath 			= fromJust winpath
@@ -850,10 +846,8 @@ getActiveModules ps
 		= ([winpath],ps)
 	| IsDefPathname winpath
 		= ([MakeImpPathname winpath],ps)
-//	= trace_n` ("Regular",winpath) ([winpath],ps)
 	= ([],ps)
-import PmDirCache, UtilIO
-//import dodebug
+
 findModule :: !.Modulename !*(PSt General) -> (!Maybe Pathname,!*PSt General)
 findModule pathname ps
 	# (syspaths,ps)			= getCurrentPaths ps
@@ -865,10 +859,8 @@ findModule pathname ps
 		_		-> srcpaths
 	# ((ok,fullpath),ps)	= accFiles (SearchDisk False pathname srcpaths) ps
 	| not ok
-//		= trace_n` ("NotFound",pathname,fullpath) (Nothing, ps)
 		= (Nothing, ps)
 	# fullpath`				= GetLongPathName fullpath
-//	= trace_n` ("Found",fullpath`) (Just fullpath`, ps)
 	= (Just fullpath`, ps)
 
 DoProcess msg compile cont ps
@@ -878,7 +870,7 @@ DoProcess msg compile cont ps
 	= ps
 where
 	init paths ps
-		#	(project,ps)		= accProject (\l->(l,l)) ps
+		#	(project,ps)		= getFromProject (\l->l) ps
 			ps					= ew_safe_close ps
 			ps					= tw_safe_close ps
 		= okcont paths project ps	
@@ -919,14 +911,14 @@ pm_save_copy_as ps
 	| isNothing pn
 		= ps
 	# pn		= fromJust pn
-	#	(project,ps)	= accProject (\l->(l,l)) ps
+	#	(project,ps)	= getFromProject (\l->l) ps
 	# (project,ps)		= pm_save_common pn project ps
 	#	ps				= appProject (const project) ps
 	= ps
 
 pm_save :: !*(PSt *General) -> *PSt *General
 pm_save ps
-	#	(project,ps)	= accProject (\l->(l,l)) ps
+	#	(project,ps)	= getFromProject (\l->l) ps
 		(pathname,ps)	= getProjectFilePath ps
 	# (project,ps) = pm_save_common pathname project ps
 	#	project			= PR_SetSaved project
@@ -976,8 +968,6 @@ isProjWin win ps
 	# (wId,ps) = getPWW ps
 	= (wId == win,ps)
 
-//////////////////////////////////////
-
 extKeyboard = ControlKeyboard keyFilter Able keyboard
 
 keyFilter :: KeyboardState -> Bool
@@ -1001,7 +991,7 @@ keyboard (CharKey '+' (KeyDown False)) ((lbState=:{tMargin,listboxId,selection,i
 		| not hasSelection
 			= ((lbState,ls),ps)
 		# (appPath,ps)	= getStup ps
-		# (prjPath,ps)	= getProjectFilePath ps
+		  (prjPath,ps) = getFromProject PR_GetRootDir ps
 		# ps = updFstate` (map (\(p,b)-> (fulPath appPath prjPath p,b)) selItems) ps
 		# ps = pm_update_project_window_interactive ps
 		= ((lbState,ls),ps)
@@ -1017,7 +1007,7 @@ keyboard (CharKey '-' (KeyDown False)) ((lbState=:{tMargin,listboxId,selection,i
 		| not hasSelection
 			= ((lbState,ls),ps)
 		# (appPath,ps)	= getStup ps
-		# (prjPath,ps)	= getProjectFilePath ps
+		  (prjPath,ps) = getFromProject PR_GetRootDir ps
 		# ps = updFstate` (map (\(p,b)-> (fulPath appPath prjPath p,b)) selItems) ps
 		# ps = pm_update_project_window_interactive ps
 		= ((lbState,ls),ps)

Ide/targetui.icl

@@ -389,7 +389,7 @@ buttonWidth = ContentWidth "Append..."
 
 editTargets getTs setTs ps
 	# (ap,ps) 	= getStup ps
-	# (pp,ps) 	= getProjectFilePath ps
+	# (pp,ps)	= getFromProject PR_GetRootDir ps
 	# pp		= RemoveFilename pp
 	# (ts,ps)	= getTs ps
 	# (ct,ps)	= getCurrentTarget ps
@@ -897,8 +897,6 @@ remObject (ls=:{tg,ap,pp,lbobjId},ps)
 		ps					= setExtListBoxSelection lbobjId [] ps
 	= (ls,ps)
 
-//--
-
 setCheckControlMarks ids full io
 	= seq [setCheckControlMark full id \\ id <- ids] io
 setCheckControlMark full id io
@@ -906,8 +904,6 @@ setCheckControlMark full id io
 		True	-> markCheckControlItems id [1] io
 		False	-> unmarkCheckControlItems id [1] io
 
-//--
-
 FullPath True _ _ p = p
 FullPath False ap pp l = symPath ap pp l
 

Pm/PmFiles.dcl

@@ -29,6 +29,7 @@ ProjectFileVersion :== "1.4"
 	, pg_target				:: String					// specify used environment
 	, pg_execpath			:: String					// move to ApplicationOptions
 	, pg_dynamic			:: !ProjectDynamicInfo
+	, pg_root_directory		:: !String
 	, pg_precompile			:: !Maybe String			// experiment: move to LinkOptions
 	, pg_postlink			:: !Maybe String			// experiment: move to LinkOptions
 	}

Pm/PmFiles.icl

@@ -22,6 +22,7 @@ ProjectFileVersion :== "1.4"
 	, pg_target				:: String
 	, pg_execpath			:: String
 	, pg_dynamic			:: !ProjectDynamicInfo
+	, pg_root_directory		:: !String
 	, pg_precompile			:: !Maybe String
 	, pg_postlink			:: !Maybe String
 	}
@@ -68,16 +69,16 @@ EmptyUndefModule =
 	, path			= ""
 	}
 
-//--
+project_root_option = SimpleOption	"ProjectRoot"							(\a->a.pg_root_directory)   (\v a->{a & pg_root_directory = v})
 
 ProjectGlobalOptionsTable :: OptionsTable ProjectGlobalOptions
 ProjectGlobalOptionsTable =
-	{	SimpleOption	"Built"									(\a->a.pg_built)			(\v a->{a & pg_built=v})
+	{	project_root_option
+	,	SimpleOption	"Built"									(\a->a.pg_built)			(\v a->{a & pg_built=v})
 	,	SimpleOption	"Target"								(\a->a.pg_target)			(\v a->{a & pg_target=v})
 	,	SimpleWithStringConversionOption convert_exec_path_separators_and_extension "Exec" (\a->a.pg_execpath) (\v a->{a & pg_execpath=v})
 	,	GroupedOption	"CodeGen"		CodeGenOptionsTable		(\a->a.pg_codegen)			(\v a->{a & pg_codegen=v})
 	,	GroupedOption	"Application"	ApplicationOptionsTable	(\a->a.pg_application)		(\v a->{a & pg_application=v})
-//	,	GroupedOption	"Project"		ProjectOptionsTable		(\a->a.pg_projectOptions)	(\v a->{a & pg_projectOptions=v})
 	,	GroupedOption	"Link"			LinkOptionsTable		(\a->a.pg_link)				(\v a->{a & pg_link=v})
 	,	ListOption		"Paths"			PathName ""				(\a->a.pg_projectPaths)		(\v a->{a & pg_projectPaths=v})
 	,	GroupedOption	"Static"		StaticLibsInfoTable		(\a->a.pg_staticLibInfo)	(\v a->{a & pg_staticLibInfo=v})
@@ -147,7 +148,6 @@ where
 		,	showsync	= True
 */		}
 
-
 CompilerOptionsTable :: OptionsTable CompilerOptions
 CompilerOptionsTable =
 	{
@@ -211,13 +211,6 @@ ApplicationOptionsTable	=
 		GroupedOption "Profile"	ApplicationProfiletOptionsTable	id				const,
 		GroupedOption "Output"	ApplicationOutputOptionsTable	id				const
 	}
-/*
-ProjectOptionsTable :: OptionsTable ProjectOptions
-ProjectOptionsTable =
-	{
-		SimpleOption "Verbose"	(\a->a.ProjectOptions.verbose)	(\v a->{ProjectOptions | a & verbose=v})
-	}
-*/
 
 PathName :: OptionsTableEntry {#Char}
 PathName

Pm/PmProject.dcl

@@ -22,12 +22,13 @@ SaveProjectFile	::
 	( !Bool			// success
 	, !*Files		// returned filesystem
 	);
+
 ReadProjectFile	::
 	!String			// path to projectfile
 	!String			// the application directory
 	!*Files			// the filesystem environment
 	->
-	((!Project		// the project
+	(!(!Project		// the project
 	, !Bool			// success: true if successful except when failed to close
 					// project file. Then success is true but errmsg (next entry)
 					// is nonempty.
@@ -35,6 +36,8 @@ ReadProjectFile	::
 	),!*Files		// returned filesystem
 	)
 
+change_root_directory_of_project :: !{#Char} !{#Char} !Project -> Project
+
 getDynamicInfo	:: !Project -> (ProjectDynamicInfo,Project)
 setDynamicInfo	:: !.ProjectDynamicInfo !.Project -> .Project
 
@@ -64,6 +67,8 @@ PR_GetPaths					:: !Project -> List String
 PR_GetRootModuleName		:: !Project -> String
 PR_GetRootPathName			:: !Project -> (!String,!Project)
 PR_GetRootModuleDir			:: !Project -> String
+PR_GetRootDir :: !Project -> String
+PR_GetRelativeRootDir :: !Project -> String
 PR_GetModulenames			:: !Bool !Def_and_Imp !Project -> (List String,Project)
 PR_GetOpenModulenames		:: !Project -> List String
 PR_GetModuleStuff			:: !Project -> List (Modulename,String,Modulename,String)
@@ -110,3 +115,5 @@ PR_SetPrecompile	:: !(Maybe String) !Project -> Project
 PR_GetPrecompile	:: !Project -> (!Maybe String, !Project)
 PR_SetPostlink		:: !(Maybe String) !Project -> Project
 PR_GetPostlink		:: !Project -> (!Maybe String, !Project)
+
+make_project_dir :: !Int !{#Char} -> {#Char}