CpmLogic.icl 27.5 KB
Newer Older
1 2
implementation module CpmLogic

3 4 5
/**
 * Clean libraries imports
 */
6
import StdEnv,StdStrictLists
7
from StdOverloadedList import ++|,Last,Init,RemoveAt,SplitAt,instance length [!!]
8
import set_return_code,Directory
9

10 11 12
/**
 * CPM imports
 */
13
import AbsSyn,CpmPaths
14 15 16 17

/**
 * CleanIDE imports
 */
18
import UtilIO,IdeState,Platform,PmPath,PmEnvironment,PmProject,PmDriver
19
from PmCleanSystem import :: CompileOrCheckSyntax(..)
20 21 22 23

/**
 * Execute a general CPM action
 */
24
doCpmAction :: String String !CpmAction !*World -> *World
25 26 27 28 29
doCpmAction cleanhome  pwd  CpmMake           world = doMake cleanhome pwd world
doCpmAction cleanhome  pwd  (Project pn pa)   world = doProjectAction cleanhome pwd pn pa world
doCpmAction cleanhome  pwd  (Module mn ma)    world = doModuleAction cleanhome mn ma world
doCpmAction cleanhome  pwd  (Environment ea)  world = doEnvironmentAction cleanhome pwd ea world
doCpmAction _          _    _                 world =
30 31
  help  "cpm <target>"
    [  "Where <target> is one of the following:"
32 33 34 35 36 37 38
    ,  "  <projectname> [--force] [--envs=filename] : build project <projectname>."
    ,  "                                              Optionally force build (default: 'false')"
    ,  "                                              Optionally specify the environments file (default: 'IDEEnvs')"
    ,  "  project <projectfile>                     : project actions"
    ,  "  module <modulename>                       : module actions"
    //,  "  environment                               : environment actions"
    ,  "  make                                      : build all projects in the current directory"
39 40 41
    ,  ""
    ,  "Execute `cpm <target> help` to get help for specific actions."] world

42 43 44
/**
 * Find all project files in the current working directory and build them
 */
45
doMake :: String !String !*World -> *World
46
doMake cleanhome pwd world
47
  # ((ok,pwd_path),world) = pd_StringToPath pwd world
48
  | not ok
49
 	= error ("Failed to read current directory ("+++pwd+++")") world
50 51
  # ((err,entries), world) = getDirectoryContents pwd_path world
  | err<>NoDirError
52
 	= error ("Failed to read current directory ("+++pwd+++")") world
53 54 55 56 57
 	# xs = [e \\ {fileName=e}<-entries
 			| size e>=4 && e.[size e-4]=='.' && e.[size e-3]=='p' && e.[size e-2]=='r' && e.[size e-1]=='j']
 	| isEmpty xs
		= error ("No project file found in " +++ pwd) world
		= foldr (\pn -> doProjectAction cleanhome pwd pn (BuildProject False EnvsFileName)) world xs
58

59 60 61 62 63 64 65
/**
 * Default compiler options. Currently it is a simple alias for
 * forwards-compatibility.
 */
compilerOptions :: CompilerOptions
compilerOptions = DefaultCompilerOptions

66 67 68 69 70 71 72
getLine :: *World -> *(String, *World)
getLine world
  # (console, world)  = stdio world
  # (line, console)   = freadline console
  # (_, world)        = fclose console world
  = (line, world)

73 74 75
/**
 * Execute project-specific actions
 */
76
doProjectAction :: String String String ProjectAction *World -> *World
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
doProjectAction cleanhome pwd  pn  (CreateProject mtemplate) world
	//Check if main module exists
	# (exists,world) = accFiles (FExists mainmodule) world
	| not exists
		# world = showLines ["Main module " +++ mainmodule +++ " does not exist. Create it? [y/n]"] world
		# (line, world) = getLine world
		| line.[0] == 'y' = mkMainAndProject world
		| otherwise = error ("Failed to create project. Need " +++ mainmodule) world
	| otherwise = mkProject world
where
	mainmodule = MakeImpPathname pn

	mkMainAndProject world
		# world = doModuleAction "" mainmodule (CreateModule ApplicationModule) world
		= mkProject world
	mkProject world
		# edit_options	 = {eo={newlines=NewlineConventionUnix},pos_size=NoWindowPosAndSize}
		# projectfile = GetLongPathName (MakeProjectPathname pn)
		= case mtemplate of
			Nothing
				# prj = PR_NewProject mainmodule edit_options compilerOptions DefCodeGenOptions DefApplicationOptions [!!] DefaultLinkOptions
				# prj = PR_SetRoot mainmodule edit_options compilerOptions prj
				= saveProject cleanhome pwd prj projectfile world
			(Just template_file_path)
				# template_file_path = GetLongPathName template_file_path
				# ((ok, prj, errmsg), world) = accFiles (read_project_template_file template_file_path cleanhome) world
				| not ok = error ("Couldn't open project template: " +++ errmsg) world
				# ((ok, prj), world) = accFiles (create_new_project_using_template (pwd+++DirSeparatorString+++mainmodule) projectfile compilerOptions edit_options prj) world
				| not ok = error "Couldn't convert project template to project file" world
				= saveProject cleanhome pwd prj projectfile world
107 108

doProjectAction cleanhome pwd  pn  ShowProject world
109 110 111 112
  # (proj_path, project, ok, world) = openProject pwd pn cleanhome world
  | not ok
	= world
  = showLines  [  "Content of " +++ proj_path +++ ":"
113 114 115 116 117 118 119 120
               ,  "ProjectRoot..: " +++ PR_GetRelativeRootDir project
               ,  "Target.......: " +++ PR_GetTarget project
               ,  "Executable...: " +++ PR_GetExecPath project
               ,  "Paths........:"
               :  showPaths project
               ] world

doProjectAction cleanhome pwd  pn  (BuildProject force ideenvs) world
121 122 123 124
  # (envs, world)                = readIDEEnvs cleanhome ideenvs world
  # (proj_path, proj, ok, world) = openProject pwd pn cleanhome world
  | not ok
	= world
125 126 127 128
  //Sanity checks on the project file to see if it is tampered with
  # appopts = PR_GetApplicationOptions proj
  | appopts.stack_traces && not appopts.profiling
    = abort "Stack tracing is enabled but time profiling is not\n"
129 130 131
  # (console, world)             = stdio world
  # iniGeneral                   = initGeneral True compilerOptions cleanhome proj_path proj envs console
  # {ls, gst_world}              = pinit force {ls=iniGeneral,gst_world=world,gst_continue_or_stop=False}
132
  = gst_world
133 134
  where
  pinit force_rebuild gst = BringProjectUptoDate force_rebuild cleanup gst
135
  cleanup exepath bool1 bool2 ps = abortLog (not bool2) "" ps
136

137
doProjectAction cleanhome pwd pn (Compile module_names) world
138 139 140
  # (envs, world) = readIDEEnvs cleanhome EnvsFileName world
    (project_path, project, ok, world) = openProject pwd pn cleanhome world
  | not ok
141
    = world
142 143
  # (console, world) = stdio world
    iniGeneral = initGeneral False compilerOptions cleanhome project_path project envs console
144
    gst = {ls=iniGeneral,gst_world=world,gst_continue_or_stop=False}
145
    gst = foldl (\gst module_name->CompileProjectModule Compilation module_name project (\ok _ _ gst = if ok gst (abortLog True "" gst)) gst) gst module_names
146 147
  = gst.gst_world

148 149 150 151 152
doProjectAction cleanhome pwd pn  (ProjectPath pa) world
  # (proj_path, project, ok, world) = openProject pwd pn cleanhome world
  | not ok
	= world
  = doProjectPathAction cleanhome pwd pn project pa world
153

154 155
doProjectAction cleanhome pwd pn (SetRelativeRoot relroot) world
  = withProject pwd pn cleanhome (uncurry (change_root_directory_of_project relroot) o PR_GetRootPathName) world
156

157 158
doProjectAction cleanhome pwd pn (SetTarget target) world
  = withProject pwd pn cleanhome (PR_SetTarget target) world
159

160 161
doProjectAction cleanhome pwd pn (SetExec exec) world
  = withProject pwd pn cleanhome (PR_SetExecPath exec) world
162

163
doProjectAction cleanhome pwd pn (SetBytecode Nothing) world
164 165 166 167 168 169
  = withProject pwd pn cleanhome (\p->PR_SetByteCodePath (bytecode_path (PR_GetExecPath p)) p) world
where
	bytecode_path exec_path
		| exec_path % (size exec_path-4,size exec_path-1) == ".exe"
			= exec_path % (0,size exec_path-4) +++ "bc"
			= exec_path +++ ".bc"
170 171 172
doProjectAction cleanhome pwd pn (SetBytecode (Just bcfile)) world
  = withProject pwd pn cleanhome (PR_SetByteCodePath bcfile) world

173 174 175 176 177 178 179
doProjectAction cleanhome pwd pn (ExportTemplate prt) world
	# (project_path, project, ok, world) = openProject pwd pn cleanhome world
	| not ok = error "Error opening project" world
	# (ok, world) = accFiles (save_project_template_file prt project cleanhome) world
	| not ok = error "Error saving project template" world
	= world

180
doProjectAction cleanhome pwd pn (SetProjectOptions project_options) world
181
	= withProject pwd pn cleanhome (set_project_options project_options) world
182 183 184 185 186 187 188 189 190 191 192
where
	set_project_options [project_option:project_options] project
		# project = set_project_option project_option project
		= set_project_options project_options project
	set_project_options [] project
		= project

	set_project_option DynamicsOn project
		= PR_SetApplicationOptions {PR_GetApplicationOptions project & dynamics = True} project
	set_project_option DynamicsOff project
		= PR_SetApplicationOptions {PR_GetApplicationOptions project & dynamics = False} project
193 194 195 196
	set_project_option GenericFusionOn project
		= PR_SetApplicationOptions {PR_GetApplicationOptions project & generic_fusion = True} project
	set_project_option GenericFusionOff project
		= PR_SetApplicationOptions {PR_GetApplicationOptions project & generic_fusion = False} project
197 198 199 200
	set_project_option DescExLOn project
		= PR_SetApplicationOptions {PR_GetApplicationOptions project & desc_exl = True} project
	set_project_option DescExLOff project
		= PR_SetApplicationOptions {PR_GetApplicationOptions project & desc_exl = False} project
201 202 203
	set_project_option (HeapSize hs) project
		= PR_SetApplicationOptions {PR_GetApplicationOptions project & hs = hs} project
	set_project_option (StackSize ss) project
204
		= PR_SetApplicationOptions {PR_GetApplicationOptions project & ss = ss} project
205 206
	set_project_option (Output output) project
		= PR_SetApplicationOptions {PR_GetApplicationOptions project & o = output} project
207 208 209 210
	set_project_option RTSFlagsOff project
		= PR_SetApplicationOptions {PR_GetApplicationOptions project & disable_rts_flags=True} project
	set_project_option RTSFlagsOn project
		= PR_SetApplicationOptions {PR_GetApplicationOptions project & disable_rts_flags=False} project
Mart Lubbers's avatar
Mart Lubbers committed
211
	set_project_option TimeProfileOff project
212
		= PR_SetApplicationOptions {PR_GetApplicationOptions project & profiling=False, callgraphProfiling=False, stack_traces=False} project
Mart Lubbers's avatar
Mart Lubbers committed
213
	set_project_option TimeProfileOn project
214 215 216 217 218
		= PR_SetApplicationOptions {PR_GetApplicationOptions project & profiling=True, callgraphProfiling=False, stack_traces=False} project
	set_project_option CallgraphProfileOff project
		= PR_SetApplicationOptions {PR_GetApplicationOptions project & profiling=False, callgraphProfiling=False, stack_traces=False} project
	set_project_option CallgraphProfileOn project
		= PR_SetApplicationOptions {PR_GetApplicationOptions project & profiling=True, callgraphProfiling=True, stack_traces=False} project
Mart Lubbers's avatar
Mart Lubbers committed
219
	set_project_option StackTraceOff project
220
		= PR_SetApplicationOptions {PR_GetApplicationOptions project & profiling=False, callgraphProfiling=False, stack_traces=False} project
Mart Lubbers's avatar
Mart Lubbers committed
221
	set_project_option StackTraceOn project
222
		= PR_SetApplicationOptions {PR_GetApplicationOptions project & profiling=True, callgraphProfiling=False, stack_traces=True} project
Mart Lubbers's avatar
Mart Lubbers committed
223 224 225 226
	set_project_option MemoryProfileOff project
		= PR_SetApplicationOptions {PR_GetApplicationOptions project & memoryProfiling=False} project
	set_project_option MemoryProfileOn project
		= PR_SetApplicationOptions {PR_GetApplicationOptions project & memoryProfiling=True} project
227 228 229 230
	set_project_option LinkerGenerateSymbolsOn project
		= PR_SetLinkOptions project {PR_GetLinkOptions project & generate_symbol_table=True}
	set_project_option LinkerGenerateSymbolsOff project
		= PR_SetLinkOptions project {PR_GetLinkOptions project & generate_symbol_table=False}
231 232 233 234 235 236 237 238 239 240
	set_project_option (PO_OptimiseABC val) project
		= PR_SetCodeGenOptions {PR_GetCodeGenOptions project & optimise_abc=val} project
	set_project_option (PO_GenerateByteCode val) project
		= PR_SetCodeGenOptions {PR_GetCodeGenOptions project & generate_bytecode=val} project
	set_project_option (PO_StripByteCode val) project
		= PR_SetLinkOptions project {PR_GetLinkOptions project & strip_bytecode=val}
	set_project_option (PO_KeepByteCodeSymbols val) project
		= PR_SetLinkOptions project {PR_GetLinkOptions project & keep_bytecode_symbols=val}
	set_project_option (PO_PreLinkByteCode val) project
		= PR_SetLinkOptions project {PR_GetLinkOptions project & prelink_bytecode=val}
241

242
doProjectAction _          _  _   _    world             =
243
  help "cpm project <projectfile> <action>"
244
    [  "Where <action> is one of the following"
245
    ,  "  create [<template.prt>]           : create a new project from an optional template"
246
    ,  "  compile <modulename> [..]         : compile the given modules"
247 248 249 250
    ,  "  show                              : show project information"
    ,  "  build [--force] [--envs=filename] : build the project. Optionally force build (default: 'false')"
    ,  "                                      Optionally specify the environments file (default: 'IDEEnvs')"
    ,  "  path                              : manage project paths"
251 252
    ,  "  root .[.]                         : set the project root relative to the project file."
    ,  "                                    :  . is the same dir, .. the parent, ... the grandparent, etc."
253 254
    ,  "  target <env>                      : set target environment to <env>"
    ,  "  exec <execname>                   : set executable name to <execname>"
255
    ,  "  bytecode [bc]                     : set bytecode file to <bcfile> or <execname>.bc if no file given"
256
    ,  "  template <template.prt>           : export the given project to a template file"
257 258 259 260 261
    ,  "  set <option> [<option>]           : Set one or more of the following options:"
    ,  "                                    : -h SIZE"
    ,  "                                    :     Change the heapsize (e.g. 2M)"
    ,  "                                    : -s SIZE"
    ,  "                                    :     Change the stacksize (e.g. 200K)"
262 263
    ,  "                                    : -generic_fusion,-ngeneric_fusion"
    ,  "                                    :     Enable or disable generic fusion"
264 265
    ,  "                                    : -strip,-nstrip"
	,  "                                    :     Enable or disable application stripping"
266 267
    ,  "                                    : -dynamics,-ndynamics"
    ,  "                                    :     Enable or disable dynamics"
268
    ,  "                                    : -descexl,-ndescexl"
269 270
    ,  "                                    :     Enable or disable descriptor generation and label exporting"
    ,  "                                    :     This translates to passing -desc and -exl to cocl"
271 272
    ,  "                                    : -rtsopts,-nrtsopts"
    ,  "                                    :     Enable or disable the default rts arguments (-h, -s, etc.)"
273 274 275
    ,  "                                    : -b,-nr,-nc,-sc"
    ,  "                                    :     Set the output option to BasicValuesOnly, NoReturnType,"
    ,  "                                    :     NoConsole or ShowConstructors respectively"
276 277
	,  "                                    : -pt, -npt, -pg, -npg, -tst, ntst"
    ,  "                                    :     Enable or disable time/callgraph profiling and stack tracing"
278
	,  "                                    :     Note that these are mutually exclusive and if you select multiple, the last one will take effect"
Mart Lubbers's avatar
Mart Lubbers committed
279 280
	,  "                                    : -mp, -nmp"
    ,  "                                    :     Enable or disable memory profiling"
Mart Lubbers's avatar
Mart Lubbers committed
281 282 283 284 285 286 287 288 289 290 291 292 293 294
    ,  "                                    : -optimiseabc, -noptimiseabc"
    ,  "                                    :     Enable or disable ABC optimization for bytecode targets"
    ,  "                                    : -genbytecode, -ngenbytecode"
    ,  "                                    :     Enable or disable bytecode generation"
    ,  "                                    : -stripbytecode, -nstripbytecode"
    ,  "                                    :     Enable or disable bytecode stripping"
    ,  "                                    : -keepbytecodesymbols, -nkeepbytecodesymbols"
    ,  "                                    :     Enable or disable bytecode symbol keeping"
    ,  "                                    : -prelinkbytecode, -nprelinkbytecode"
    ,  "                                    :     Enable or disable bytecode prelinking"
    ,  ""
    ,  "Examples: "
    ,  " - To create an iTasks project for module test, run:"
    ,  "    cpm project test create"
295
    ,  "    cpm project test bytecode"
Mart Lubbers's avatar
Mart Lubbers committed
296
    ,  "    cpm project test.prj target iTasks"
297
    ,  "    cpm project test.prj set -dynamics -h 200m -s 2m -descexl -optimiseabc -genbytecode -stripbytecode -keepbytecodesymbols -prelinkbytecode"
Mart Lubbers's avatar
Mart Lubbers committed
298
    ,  "    cpm project test.prj build"
299 300
    ] world

301 302 303
/**
 * Execute environment-specific actions
 */
304
doEnvironmentAction :: String String EnvironmentAction *World -> *World
305
doEnvironmentAction cleanhome pwd ListEnvironments        world
306
	= withEnvironments cleanhome (\ts w->(Nothing, showLines [t.target_name\\t<-ts] w)) world
307
doEnvironmentAction cleanhome pwd (ImportEnvironment ef) world
308 309 310 311 312 313
	= withEnvironments cleanhome importEnvironment world
where
	importEnvironment ts world
		# ((ts`, ok, err), world) = openEnvironment ef world
		| not ok = (Nothing, error err world)
		= (Just (ts ++ ts`), world)
314
doEnvironmentAction cleanhome pwd (RemoveEnvironment en) world
315
	= withEnvironment cleanhome en (\_ w->(Just [], w)) world
316
doEnvironmentAction cleanhome pwd (ShowEnvironment en) world 
317
	= withEnvironment cleanhome en (\e w->(Nothing, showLines (printEnvironment e) w)) world
318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342
where
	printEnvironment e =
		[ "Name: " +++ e.target_name
		, "Paths: " +++ foldr (+++) "" ["\t" +++ t +++ "\n"\\t<|-e.target_path]
		, "Dynamics libraries: \n" +++ foldr (+++) "" ["\t" +++ t +++ "\n"\\t<|-e.target_libs]
		, "Object files: \n" +++ foldr (+++) "" ["\t" +++ t +++ "\n"\\t<|-e.target_objs]
		, "Static libraries: \n" +++ foldr (+++) "" ["\t" +++ t +++ "\n"\\t<|-e.target_stat]
		, "Compiler: " +++ e.target_comp
		, "Code generator: " +++ e.target_cgen
		, "ABC optimizer: " +++ e.target_abcopt
		, "Bytecode generator: " +++ e.target_bcgen
		, "Bytecode linker: " +++ e.target_bclink
		, "Bytecode stripper: " +++ e.target_bcstrip
		, "Bytecode prelink: " +++ e.target_bcprelink
		, "Linker: " +++ e.target_link
		, "Dynamic linker: " +++ e.target_dynl
		, "ABC version: " +++ toString e.target_vers
		, "64 bit processor: " +++ toString e.env_64_bit_processor
		, "Redirect console: " +++ toString e.target_redc
		, "Compile method: " +++ case e.target_meth of
			CompileSync = "sync"
			CompileAsync i = "async " +++ toString i
			CompilePers = "pers"
		, "Processor: " +++ toString e.target_proc
		]
343
doEnvironmentAction cleanhome pwd (ExportEnvironment en fp) world
344 345 346 347
	= withEnvironment cleanhome en exportEnvironment world
where
	exportEnvironment t world
		# (ok, world) = saveEnvironments fp [t] world
348
		| not ok = (Nothing, error ("Error saving environment to " +++ fp) world)
349
		= (Nothing, world)
350
doEnvironmentAction cleanhome pwd (CreateEnvironment en Nothing) world
351
	= withEnvironments cleanhome (\t w->(Just [{t_StdEnv & target_name=en}:t], w)) world
352
doEnvironmentAction cleanhome pwd (CreateEnvironment en (Just en`)) world
353
	= withEnvironment cleanhome en` (\t w->(Just [t, {t & target_name=en}], w)) world
354
doEnvironmentAction cleanhome pwd (RenameEnvironment en en`)   world
355
	= withEnvironment cleanhome en (\t w->(Just [{t & target_name=en`}], w)) world
356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372
doEnvironmentAction cleanhome pwd (SetEnvironmentCompiler en cp) world
	= modifyEnvironment cleanhome en (\t->{t & target_comp=cp}) world
doEnvironmentAction cleanhome pwd (SetEnvironmentCodeGen en cp) world
	= modifyEnvironment cleanhome en (\t->{t & target_cgen=cp}) world
doEnvironmentAction _ _  _ world
	= help "cpm environment <action>"
		[ "Where <action> is one of the following"
		, " list                 : list all available environments"
		, " import <filepath>          : import an environement from file <filepath>"
		, " create <envname> [<envname`>]    : create a new environment with name <envname> possibly inheriting all options from <envname`>"
		, " remove <envname>           : remove evironment <envname>"
		, " show <envname>            : show environment <envname>"
		, " export <envname> <filepath>     : export environment <envname> to <filepath>"
		, " rename <envname> <envname`>     : rename environment <envname> to <envname`>"
		, " setcompiler <envname> <compilername> : set compiler for <envname> to <compilername>"
		, " setcodegen <envname> <codegenname>  : set codegen for <envname> to <codegenname>"
		] world
373

374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390
withEnvironments :: String ([Target] *World -> (Maybe [Target], *World)) *World -> *World
withEnvironments cleanhome envf world
	# (envs, world) = uncurry envf (readIDEEnvs cleanhome EnvsFileName world)
	| isNothing envs = world
	# (ok, world) = writeIDEEnvs cleanhome EnvsFileName (fromJust envs) world
	| not ok = error ("Error writing environment") world
	= world

withEnvironment :: String String (Target *World -> (Maybe [Target], *World)) -> (*World -> *World)
withEnvironment cleanhome envname envf
	= withEnvironments cleanhome \ts world->
		case span (\s->s.target_name <> envname) ts of
			(_, []) = (Nothing, error ("Environment " +++ envname +++ " not found") world)
			(e, [t:es]) = case envf t world of
				(Nothing, world) = (Nothing, world)
				(Just ts, world) = (Just (flatten [e, ts, es]), world)

391 392 393 394
modifyEnvironment :: String String (Target -> Target) -> (*World -> *World)
modifyEnvironment cleanhome envname targetf
	= withEnvironment cleanhome envname (\t w->(Just [targetf t], w))

395 396 397
/**
 * Modify a project
 */
398 399 400 401 402 403
withProject :: !String !String !String (Project -> Project) *World -> *World
withProject pwd pn cleanhome f world
  # (project_path, project, ok, world) = openProject pwd pn cleanhome world
  | not ok
	= world
  = saveProject cleanhome pwd (f project) project_path world
404 405 406 407

/**
 * Execute path-related project actions
 */
408
doProjectPathAction :: String String String Project PathAction *World -> *World
409 410
doProjectPathAction cleanhome pwd pn project (AddPathAction paths) world
  = doModPaths cleanhome pwd pn project (Concat [! GetLongPathName path\\path<-paths !]) world
411

412
doProjectPathAction cleanhome pwd pn project (RemovePathAction i) world
413
  = doModPaths cleanhome pwd pn project (RemoveAt i) world
414

415 416
doProjectPathAction _ _ _ project ListPathsAction world
  = showLines ["Paths for project:" : showPaths project] world
417

418 419
doProjectPathAction cleanhome pwd pn project (MovePathAction i pdir) world
  = doModPaths cleanhome pwd pn project (moveStrictListIdx i pdir) world
420

421 422
doProjectPathAction _          _ _   _     _  world
  = help "cpm project <projectname.prj> path <action>"
423 424 425 426 427 428 429 430 431
    [  "Where <action> is one of the following"
    ,  "  add <path>          : add a path to the project"
    ,  "  list                : list all project paths and their index"
    ,  "  remove <i>          : remove path <i> from the list of projects"
    ,  "  move <i> <up|down>  : move path <i> up or down one position" ] world

/**
 * Collect all project paths in a list with an index prefixed
 */
432
showPaths :: !Project -> [String]
433
showPaths project = ["  [" +++ toString n +++ "]  " +++ p \\ p<|-PR_GetPaths project & n<-[0..]]
434 435 436 437 438 439

/**
 * Modify the list of paths in a project given a modification function which
 * takes a strict list of project paths and returns a strict list of project
 * paths.
 */
440 441
doModPaths :: !String !String !String !Project ([!String!] -> [!String!]) *World -> *World
doModPaths cleanhome pwd pn project f world
442 443
  # paths = PR_GetPaths project
  # prj   = PR_SetPaths False paths (f paths) project
444
  # world = saveProject cleanhome pwd prj pn world
445 446
  = showLines ["Successfully modified project paths"] world

447 448 449 450 451 452
append_dir_separator :: !{#Char} -> {#Char}
append_dir_separator s
	| size s>0 && s.[size s-1]==DirSeparator
		= s
		= s+++DirSeparatorString

453 454 455
/**
 * Open a project file
 */
456 457
openProject :: !FilePath !FilePath !FilePath !*World -> (!FilePath, !Project, Bool, !*World)
openProject pwd pn cleanhome world
458
  # proj_path                = GetLongPathName (append_dir_separator pwd +++ pn)
459 460 461 462
  # ((prj, ok, err), world)  = accFiles (ReadProjectFile proj_path cleanhome) world
  | not ok || err <> ""
	= (proj_path, prj, ok, error err world)
  = (proj_path, prj, ok, world)
463 464 465 466

/**
 * Save a project back to its project file
 */
467 468 469 470 471 472 473
saveProject :: !FilePath !FilePath !Project !FilePath !*World -> *World
saveProject cleanhome pwd prj projectfile world
  # proj_path = GetLongPathName projectfile
  # (ok, world) = accFiles (SaveProjectFile proj_path prj cleanhome) world
  | not ok
	= error "Error saving project" world
  = world
474 475 476 477 478

/**
 * Move a path at a given index up or down the list of paths. Abort execution
 * if the index is out of bounds.
 */
479
moveStrictListIdx :: !Int PathDirection [!a!] -> [!a!]
480
moveStrictListIdx i dir xs
481 482 483 484 485 486 487 488 489 490 491 492
  | i < 0 || i > length xs - 1 = abort ("Index " +++ toString i +++ " out of bounds")
  | otherwise                  = msl dir (SplitAt i xs)
  where  msl MovePathUp      ([!!], xs)        = xs
         msl MovePathUp      (xs, [!x:ys!])    = Init xs ++| [!x : Last xs : ys!]
         msl MovePathDown    ([!!], [!x:y:ys!])= [!y:x:ys!]
         msl MovePathDown    (xs, [!!])        = xs
         msl MovePathDown    (xs, [!y!])       = xs ++| [!y!]
         msl MovePathDown    (xs, [!x:y:ys!])  = xs ++| [!y:x:ys!]
         msl MovePathTop     (xs, [!!])        = xs
         msl MovePathTop     (xs, [!y:ys!])    = [!y:xs++|ys!]
         msl MovePathBottom  (xs, [!!])        = xs
         msl MovePathBottom  (xs, [!y:ys!])    = xs ++| ys ++| [!y!]
493 494 495 496

/**
 * Execute module-related actions
 */
497
doModuleAction :: String !String !ModuleAction !*World -> *World
498
doModuleAction _ mn  (CreateModule mt) world
499
  # (dclexists, world)  = accFiles (FExists dclnm) world
500
  | dclexists           = error ("Definition module '" +++ dclnm +++ "' already exists.") world
501
  # (iclexists, world)  = accFiles (FExists iclnm) world
502
  | iclexists           = error ("Implementation module '" +++ iclnm +++ "' already exists.") world
503
  = writeMods mt world
504
  where
505 506 507
  dclnm      = MakeDefPathname mn
  iclnm      = MakeImpPathname mn
  basenm     = iclnm % (0,size iclnm-5)
508

509
  mkmod mty  = mty +++ "module " +++ basenm
510

511 512 513 514
  writeMods ApplicationModule world = writeicl ApplicationModule world
  writeMods LibraryModule world
    # world = writeicl ApplicationModule world
    = writedcl world
515

516 517
  writeicl ApplicationModule  world = writeicl` "" world
  writeicl LibraryModule      world = writeicl` "implementation " world
518

519
  writeicl` pref world = writemod iclnm pref ("Failed to write implementation module '" +++ basenm +++ "'") world
520

521
  writedcl world = writemod dclnm "definition " ("Failed to write definition module '" +++ basenm +++ "'") world
522

523
  writemod nm pref errmsg world
524 525 526 527 528 529 530 531
  	# (ok,file,world) = fopen nm FWriteText world
  	| not ok
  		= error errmsg world
  	# file = fwrites (mkmod pref) file
  	  (ok,world) = fclose file world
  	| not ok
  		= error errmsg world
	    = world
532 533 534 535

doModuleAction _ _   _  world                =
  help "cpm module <modulename> <action>"
    [  "Where <action> is one of the following"
536 537 538 539
    ,  "  create [application|library]  : create a new module. Optionally specify module type (default: 'library')"
    //,  "  check <projectname.prj>       : type-check module in the context of project <projectname.prj>"
    //,  "  compile <projectname.prj>     : compile module in the context of project <projectname.prj>"
    ] world
540 541 542 543

/**
 * Show an error message
 */
544
error :: !String !*World -> *World
545
error message world
Camil Staps's avatar
Camil Staps committed
546
  # stderr     = stderr <<< message <<< "\n"
547
  # (ok,world) = fclose stderr world
548 549 550 551 552 553
  = set_return_code_world (-1) world

/**
 * Show a help message
 */
help :: !String ![String] !*World -> *World
554 555 556 557 558 559
help cmd lines world
  # lines` = [ "CPM: Clean Project Manager"
             : ""
             : "Usage: " +++ cmd
             : lines]
  = showLines lines` world
560 561 562 563 564 565 566

/**
 * Given a list of strings, concatenate them to a single string with newlines
 * in between, then print that new string to console.
 */
showLines :: ![String] !*World -> *World
showLines lines world
567
  # (console, world) = stdio world
568 569
  # console = foldl (\file s -> fwritec '\n' (fwrites s file)) console lines
  = snd (fclose console world)