CpmLogic.icl 27 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
145
    gst = {ls=iniGeneral,gst_world=world,gst_continue_or_stop=False}
    gst = foldl (\gst module_name->CompileProjectModule Compilation module_name project (\_ _ _ gst->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, stack_traces=False} project
Mart Lubbers's avatar
Mart Lubbers committed
213
	set_project_option TimeProfileOn project
214
		= PR_SetApplicationOptions {PR_GetApplicationOptions project & profiling=True, stack_traces=False} project
Mart Lubbers's avatar
Mart Lubbers committed
215
	set_project_option StackTraceOff project
216
		= PR_SetApplicationOptions {PR_GetApplicationOptions project & profiling=False, stack_traces=False} project
Mart Lubbers's avatar
Mart Lubbers committed
217
	set_project_option StackTraceOn project
218
		= PR_SetApplicationOptions {PR_GetApplicationOptions project & profiling=True, stack_traces=True} project
Mart Lubbers's avatar
Mart Lubbers committed
219
220
221
222
	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
223
224
225
226
	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}
227
228
229
230
231
232
233
234
235
236
	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}
237

238
doProjectAction _          _  _   _    world             =
239
  help "cpm project <projectfile> <action>"
240
    [  "Where <action> is one of the following"
241
    ,  "  create [<template.prt>]           : create a new project from an optional template"
242
    ,  "  compile <modulename> [..]         : compile the given modules"
243
244
245
246
    ,  "  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"
247
248
    ,  "  root .[.]                         : set the project root relative to the project file."
    ,  "                                    :  . is the same dir, .. the parent, ... the grandparent, etc."
249
250
    ,  "  target <env>                      : set target environment to <env>"
    ,  "  exec <execname>                   : set executable name to <execname>"
251
    ,  "  bytecode [bc]                     : set bytecode file to <bcfile> or <execname>.bc if no file given"
252
    ,  "  template <template.prt>           : export the given project to a template file"
253
254
255
256
257
    ,  "  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)"
258
259
    ,  "                                    : -generic_fusion,-ngeneric_fusion"
    ,  "                                    :     Enable or disable generic fusion"
260
261
    ,  "                                    : -strip,-nstrip"
	,  "                                    :     Enable or disable application stripping"
262
263
    ,  "                                    : -dynamics,-ndynamics"
    ,  "                                    :     Enable or disable dynamics"
264
    ,  "                                    : -descexl,-ndescexl"
265
266
    ,  "                                    :     Enable or disable descriptor generation and label exporting"
    ,  "                                    :     This translates to passing -desc and -exl to cocl"
267
268
    ,  "                                    : -rtsopts,-nrtsopts"
    ,  "                                    :     Enable or disable the default rts arguments (-h, -s, etc.)"
269
270
271
    ,  "                                    : -b,-nr,-nc,-sc"
    ,  "                                    :     Set the output option to BasicValuesOnly, NoReturnType,"
    ,  "                                    :     NoConsole or ShowConstructors respectively"
272
273
274
	,  "                                    : -pt, -npt, -tst, ntst"
    ,  "                                    :     Enable or disable time profiling and stack tracing"
	,  "                                    :     Note that these are mutually exclusive and if you select multiple, the last one will take effect"
Mart Lubbers's avatar
Mart Lubbers committed
275
276
	,  "                                    : -mp, -nmp"
    ,  "                                    :     Enable or disable memory profiling"
Mart Lubbers's avatar
Mart Lubbers committed
277
278
279
280
281
282
283
284
285
286
287
288
289
290
    ,  "                                    : -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"
291
    ,  "    cpm project test bytecode"
Mart Lubbers's avatar
Mart Lubbers committed
292
    ,  "    cpm project test.prj target iTasks"
293
    ,  "    cpm project test.prj set -dynamics -h 200m -s 2m -descexl -optimiseabc -genbytecode -stripbytecode -keepbytecodesymbols -prelinkbytecode"
Mart Lubbers's avatar
Mart Lubbers committed
294
    ,  "    cpm project test.prj build"
295
296
    ] world

297
298
299
/**
 * Execute environment-specific actions
 */
300
doEnvironmentAction :: String String EnvironmentAction *World -> *World
301
doEnvironmentAction cleanhome pwd ListEnvironments        world
302
	= withEnvironments cleanhome (\ts w->(Nothing, showLines [t.target_name\\t<-ts] w)) world
303
doEnvironmentAction cleanhome pwd (ImportEnvironment ef) world
304
305
306
307
308
309
	= 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)
310
doEnvironmentAction cleanhome pwd (RemoveEnvironment en) world
311
	= withEnvironment cleanhome en (\_ w->(Just [], w)) world
312
doEnvironmentAction cleanhome pwd (ShowEnvironment en) world 
313
	= withEnvironment cleanhome en (\e w->(Nothing, showLines (printEnvironment e) w)) world
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
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
		]
339
doEnvironmentAction cleanhome pwd (ExportEnvironment en fp) world
340
341
342
343
	= withEnvironment cleanhome en exportEnvironment world
where
	exportEnvironment t world
		# (ok, world) = saveEnvironments fp [t] world
344
		| not ok = (Nothing, error ("Error saving environment to " +++ fp) world)
345
		= (Nothing, world)
346
doEnvironmentAction cleanhome pwd (CreateEnvironment en Nothing) world
347
	= withEnvironments cleanhome (\t w->(Just [{t_StdEnv & target_name=en}:t], w)) world
348
doEnvironmentAction cleanhome pwd (CreateEnvironment en (Just en`)) world
349
	= withEnvironment cleanhome en` (\t w->(Just [t, {t & target_name=en}], w)) world
350
doEnvironmentAction cleanhome pwd (RenameEnvironment en en`)   world
351
	= withEnvironment cleanhome en (\t w->(Just [{t & target_name=en`}], w)) world
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
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
369

370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
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)

387
388
389
390
modifyEnvironment :: String String (Target -> Target) -> (*World -> *World)
modifyEnvironment cleanhome envname targetf
	= withEnvironment cleanhome envname (\t w->(Just [targetf t], w))

391
392
393
/**
 * Modify a project
 */
394
395
396
397
398
399
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
400
401
402
403

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

408
doProjectPathAction cleanhome pwd pn project (RemovePathAction i) world
409
  = doModPaths cleanhome pwd pn project (RemoveAt i) world
410

411
412
doProjectPathAction _ _ _ project ListPathsAction world
  = showLines ["Paths for project:" : showPaths project] world
413

414
415
doProjectPathAction cleanhome pwd pn project (MovePathAction i pdir) world
  = doModPaths cleanhome pwd pn project (moveStrictListIdx i pdir) world
416

417
418
doProjectPathAction _          _ _   _     _  world
  = help "cpm project <projectname.prj> path <action>"
419
420
421
422
423
424
425
426
427
    [  "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
 */
428
showPaths :: !Project -> [String]
429
showPaths project = ["  [" +++ toString n +++ "]  " +++ p \\ p<|-PR_GetPaths project & n<-[0..]]
430
431
432
433
434
435

/**
 * 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.
 */
436
437
doModPaths :: !String !String !String !Project ([!String!] -> [!String!]) *World -> *World
doModPaths cleanhome pwd pn project f world
438
439
  # paths = PR_GetPaths project
  # prj   = PR_SetPaths False paths (f paths) project
440
  # world = saveProject cleanhome pwd prj pn world
441
442
  = showLines ["Successfully modified project paths"] world

443
444
445
446
447
448
append_dir_separator :: !{#Char} -> {#Char}
append_dir_separator s
	| size s>0 && s.[size s-1]==DirSeparator
		= s
		= s+++DirSeparatorString

449
450
451
/**
 * Open a project file
 */
452
453
openProject :: !FilePath !FilePath !FilePath !*World -> (!FilePath, !Project, Bool, !*World)
openProject pwd pn cleanhome world
454
  # proj_path                = GetLongPathName (append_dir_separator pwd +++ pn)
455
456
457
458
  # ((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)
459
460
461
462

/**
 * Save a project back to its project file
 */
463
464
465
466
467
468
469
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
470
471
472
473
474

/**
 * Move a path at a given index up or down the list of paths. Abort execution
 * if the index is out of bounds.
 */
475
moveStrictListIdx :: !Int PathDirection [!a!] -> [!a!]
476
moveStrictListIdx i dir xs
477
478
479
480
481
482
483
484
485
486
487
488
  | 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!]
489
490
491
492

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

505
  mkmod mty  = mty +++ "module " +++ basenm
506

507
508
509
510
  writeMods ApplicationModule world = writeicl ApplicationModule world
  writeMods LibraryModule world
    # world = writeicl ApplicationModule world
    = writedcl world
511

512
513
  writeicl ApplicationModule  world = writeicl` "" world
  writeicl LibraryModule      world = writeicl` "implementation " world
514

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

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

519
  writemod nm pref errmsg world
520
521
522
523
524
525
526
527
  	# (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
528
529
530
531

doModuleAction _ _   _  world                =
  help "cpm module <modulename> <action>"
    [  "Where <action> is one of the following"
532
533
534
535
    ,  "  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
536
537
538
539

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

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

/**
 * 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
563
  # (console, world) = stdio world
564
565
  # console = foldl (\file s -> fwritec '\n' (fwrites s file)) console lines
  = snd (fclose console world)