CpmLogic.icl 24.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
doProjectAction cleanhome pwd  pn  CreateProject world
  //Check if main module exists
79
  # (exists,world)  = accFiles (FExists mainmodule) world
80
81
82
  | not exists //       = error ("Main module " +++ mainmodule +++ " does not exist.") world
    # world         = showLines ["Main module " +++ mainmodule +++ " does not exist. Create it? [y/n]"] world
    # (line, world) = getLine world
83
84
    | line.[0] == 'y' = mkMainAndProject world
    | otherwise       = error ("Failed to create project. Need " +++ mainmodule) world
85
  | otherwise       = mkProject world
86
  where
87
  mainmodule   = MakeImpPathname pn
88

89
90
91
92
  mkMainAndProject world
    # world = doModuleAction "" mainmodule (CreateModule ApplicationModule) world
    = mkProject world
  mkProject world
93
94
95
96
97
    # edit_options   = {eo={newlines=NewlineConventionUnix},pos_size=NoWindowPosAndSize}
    //Create project file using the Clean IDE libraries
    # prj            = PR_NewProject mainmodule edit_options compilerOptions DefCodeGenOptions
                         DefApplicationOptions [!!] DefaultLinkOptions
    # project        = PR_SetRoot mainmodule edit_options compilerOptions prj
98
    # projectfile    = MakeProjectPathname pn
99
    = saveProject cleanhome pwd project projectfile world
100
101

doProjectAction cleanhome pwd  pn  ShowProject world
102
103
104
105
  # (proj_path, project, ok, world) = openProject pwd pn cleanhome world
  | not ok
	= world
  = showLines  [  "Content of " +++ proj_path +++ ":"
106
107
108
109
110
111
112
113
               ,  "ProjectRoot..: " +++ PR_GetRelativeRootDir project
               ,  "Target.......: " +++ PR_GetTarget project
               ,  "Executable...: " +++ PR_GetExecPath project
               ,  "Paths........:"
               :  showPaths project
               ] world

doProjectAction cleanhome pwd  pn  (BuildProject force ideenvs) world
114
115
116
117
  # (envs, world)                = readIDEEnvs cleanhome ideenvs world
  # (proj_path, proj, ok, world) = openProject pwd pn cleanhome world
  | not ok
	= world
118
119
120
121
  //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"
122
123
124
  # (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}
125
  = gst_world
126
127
  where
  pinit force_rebuild gst = BringProjectUptoDate force_rebuild cleanup gst
128
  cleanup exepath bool1 bool2 ps = abortLog (not bool2) "" ps
129

130
doProjectAction cleanhome pwd pn (Compile module_names) world
131
132
133
  # (envs, world) = readIDEEnvs cleanhome EnvsFileName world
    (project_path, project, ok, world) = openProject pwd pn cleanhome world
  | not ok
134
    = world
135
136
  # (console, world) = stdio world
    iniGeneral = initGeneral False compilerOptions cleanhome project_path project envs console
137
138
    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
139
140
  = gst.gst_world

141
142
143
144
145
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
146

147
148
doProjectAction cleanhome pwd pn (SetRelativeRoot relroot) world
  = withProject pwd pn cleanhome (uncurry (change_root_directory_of_project relroot) o PR_GetRootPathName) world
149

150
151
doProjectAction cleanhome pwd pn (SetTarget target) world
  = withProject pwd pn cleanhome (PR_SetTarget target) world
152

153
154
doProjectAction cleanhome pwd pn (SetExec exec) world
  = withProject pwd pn cleanhome (PR_SetExecPath exec) world
155

156
doProjectAction cleanhome pwd pn (SetProjectOptions project_options) world
157
	= withProject pwd pn cleanhome (set_project_options project_options) world
158
159
160
161
162
163
164
165
166
167
168
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
169
170
171
172
	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
173
174
175
176
	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
177
178
179
	set_project_option (HeapSize hs) project
		= PR_SetApplicationOptions {PR_GetApplicationOptions project & hs = hs} project
	set_project_option (StackSize ss) project
180
		= PR_SetApplicationOptions {PR_GetApplicationOptions project & ss = ss} project
181
182
	set_project_option (Output output) project
		= PR_SetApplicationOptions {PR_GetApplicationOptions project & o = output} project
183
184
185
186
	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
187
	set_project_option TimeProfileOff project
188
		= PR_SetApplicationOptions {PR_GetApplicationOptions project & profiling=False, stack_traces=False} project
Mart Lubbers's avatar
Mart Lubbers committed
189
	set_project_option TimeProfileOn project
190
		= PR_SetApplicationOptions {PR_GetApplicationOptions project & profiling=True, stack_traces=False} project
Mart Lubbers's avatar
Mart Lubbers committed
191
	set_project_option StackTraceOff project
192
		= PR_SetApplicationOptions {PR_GetApplicationOptions project & profiling=False, stack_traces=False} project
Mart Lubbers's avatar
Mart Lubbers committed
193
	set_project_option StackTraceOn project
194
		= PR_SetApplicationOptions {PR_GetApplicationOptions project & profiling=True, stack_traces=True} project
Mart Lubbers's avatar
Mart Lubbers committed
195
196
197
198
	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
199
200
201
202
	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}
203
204
205
206
207
208
209
210
211
212
213
214
	set_project_option (ByteCodePath path) project
		= PR_SetByteCodePath path project
	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}
215

216
doProjectAction _          _  _   _    world             =
217
  help "cpm project <projectfile> <action>"
218
    [  "Where <action> is one of the following"
219
    ,  "  create                            : create a new project"
220
    ,  "  compile <modulename> [..]         : compile the given modules"
221
222
223
224
    ,  "  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"
225
226
    ,  "  root .[.]                         : set the project root relative to the project file."
    ,  "                                    :  . is the same dir, .. the parent, ... the grandparent, etc."
227
228
    ,  "  target <env>                      : set target environment to <env>"
    ,  "  exec <execname>                   : set executable name to <execname>"
229
230
231
232
233
    ,  "  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)"
234
235
    ,  "                                    : -generic_fusion,-ngeneric_fusion"
    ,  "                                    :     Enable or disable generic fusion"
236
237
    ,  "                                    : -strip,-nstrip"
	,  "                                    :     Enable or disable application stripping"
238
239
    ,  "                                    : -dynamics,-ndynamics"
    ,  "                                    :     Enable or disable dynamics"
240
    ,  "                                    : -descexl,-ndescexl"
241
242
    ,  "                                    :     Enable or disable descriptor generation and label exporting"
    ,  "                                    :     This translates to passing -desc and -exl to cocl"
243
244
    ,  "                                    : -rtsopts,-nrtsopts"
    ,  "                                    :     Enable or disable the default rts arguments (-h, -s, etc.)"
245
246
247
    ,  "                                    : -b,-nr,-nc,-sc"
    ,  "                                    :     Set the output option to BasicValuesOnly, NoReturnType,"
    ,  "                                    :     NoConsole or ShowConstructors respectively"
248
249
250
	,  "                                    : -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
251
252
	,  "                                    : -mp, -nmp"
    ,  "                                    :     Enable or disable memory profiling"
253
254
    ] world

255
256
257
/**
 * Execute environment-specific actions
 */
258
doEnvironmentAction :: String String EnvironmentAction *World -> *World
259
doEnvironmentAction cleanhome pwd ListEnvironments        world
260
	= withEnvironments cleanhome (\ts w->(Nothing, showLines [t.target_name\\t<-ts] w)) world
261
doEnvironmentAction cleanhome pwd (ImportEnvironment ef) world
262
263
264
265
266
267
	= 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)
268
doEnvironmentAction cleanhome pwd (RemoveEnvironment en) world
269
	= withEnvironment cleanhome en (\_ w->(Just [], w)) world
270
doEnvironmentAction cleanhome pwd (ShowEnvironment en) world 
271
	= withEnvironment cleanhome en (\e w->(Nothing, showLines (printEnvironment e) w)) world
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
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
		]
297
doEnvironmentAction cleanhome pwd (ExportEnvironment en fp) world
298
299
300
301
	= withEnvironment cleanhome en exportEnvironment world
where
	exportEnvironment t world
		# (ok, world) = saveEnvironments fp [t] world
302
		| not ok = (Nothing, error ("Error saving environment to " +++ fp) world)
303
		= (Nothing, world)
304
doEnvironmentAction cleanhome pwd (CreateEnvironment en Nothing) world
305
	= withEnvironments cleanhome (\t w->(Just [{t_StdEnv & target_name=en}:t], w)) world
306
doEnvironmentAction cleanhome pwd (CreateEnvironment en (Just en`)) world
307
	= withEnvironment cleanhome en` (\t w->(Just [t, {t & target_name=en}], w)) world
308
doEnvironmentAction cleanhome pwd (RenameEnvironment en en`)   world
309
	= withEnvironment cleanhome en (\t w->(Just [{t & target_name=en`}], w)) world
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
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
327

328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
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)

345
346
347
348
modifyEnvironment :: String String (Target -> Target) -> (*World -> *World)
modifyEnvironment cleanhome envname targetf
	= withEnvironment cleanhome envname (\t w->(Just [targetf t], w))

349
350
351
/**
 * Modify a project
 */
352
353
354
355
356
357
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
358
359
360
361

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

366
doProjectPathAction cleanhome pwd pn project (RemovePathAction i) world
367
  = doModPaths cleanhome pwd pn project (RemoveAt i) world
368

369
370
doProjectPathAction _ _ _ project ListPathsAction world
  = showLines ["Paths for project:" : showPaths project] world
371

372
373
doProjectPathAction cleanhome pwd pn project (MovePathAction i pdir) world
  = doModPaths cleanhome pwd pn project (moveStrictListIdx i pdir) world
374

375
376
doProjectPathAction _          _ _   _     _  world
  = help "cpm project <projectname.prj> path <action>"
377
378
379
380
381
382
383
384
385
    [  "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
 */
386
showPaths :: !Project -> [String]
387
showPaths project = ["  [" +++ toString n +++ "]  " +++ p \\ p<|-PR_GetPaths project & n<-[0..]]
388
389
390
391
392
393

/**
 * 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.
 */
394
395
doModPaths :: !String !String !String !Project ([!String!] -> [!String!]) *World -> *World
doModPaths cleanhome pwd pn project f world
396
397
  # paths = PR_GetPaths project
  # prj   = PR_SetPaths False paths (f paths) project
398
  # world = saveProject cleanhome pwd prj pn world
399
400
  = showLines ["Successfully modified project paths"] world

401
402
403
404
405
406
append_dir_separator :: !{#Char} -> {#Char}
append_dir_separator s
	| size s>0 && s.[size s-1]==DirSeparator
		= s
		= s+++DirSeparatorString

407
408
409
/**
 * Open a project file
 */
410
411
openProject :: !FilePath !FilePath !FilePath !*World -> (!FilePath, !Project, Bool, !*World)
openProject pwd pn cleanhome world
412
  # proj_path                = GetLongPathName (append_dir_separator pwd +++ pn)
413
414
415
416
  # ((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)
417
418
419
420

/**
 * Save a project back to its project file
 */
421
422
423
424
425
426
427
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
428
429
430
431
432

/**
 * Move a path at a given index up or down the list of paths. Abort execution
 * if the index is out of bounds.
 */
433
moveStrictListIdx :: !Int PathDirection [!a!] -> [!a!]
434
moveStrictListIdx i dir xs
435
436
437
438
439
440
441
442
443
444
445
446
  | 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!]
447
448
449
450

/**
 * Execute module-related actions
 */
451
doModuleAction :: String !String !ModuleAction !*World -> *World
452
doModuleAction _ mn  (CreateModule mt) world
453
  # (dclexists, world)  = accFiles (FExists dclnm) world
454
  | dclexists           = error ("Definition module '" +++ dclnm +++ "' already exists.") world
455
  # (iclexists, world)  = accFiles (FExists iclnm) world
456
  | iclexists           = error ("Implementation module '" +++ iclnm +++ "' already exists.") world
457
  = writeMods mt world
458
  where
459
460
461
  dclnm      = MakeDefPathname mn
  iclnm      = MakeImpPathname mn
  basenm     = iclnm % (0,size iclnm-5)
462

463
  mkmod mty  = mty +++ "module " +++ basenm
464

465
466
467
468
  writeMods ApplicationModule world = writeicl ApplicationModule world
  writeMods LibraryModule world
    # world = writeicl ApplicationModule world
    = writedcl world
469

470
471
  writeicl ApplicationModule  world = writeicl` "" world
  writeicl LibraryModule      world = writeicl` "implementation " world
472

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

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

477
  writemod nm pref errmsg world
478
479
480
481
482
483
484
485
  	# (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
486
487
488
489

doModuleAction _ _   _  world                =
  help "cpm module <modulename> <action>"
    [  "Where <action> is one of the following"
490
491
492
493
    ,  "  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
494
495
496
497

/**
 * Show an error message
 */
498
error :: !String !*World -> *World
499
error message world
Camil Staps's avatar
Camil Staps committed
500
  # stderr     = stderr <<< message <<< "\n"
501
  # (ok,world) = fclose stderr world
502
503
504
505
506
507
  = set_return_code_world (-1) world

/**
 * Show a help message
 */
help :: !String ![String] !*World -> *World
508
509
510
511
512
513
help cmd lines world
  # lines` = [ "CPM: Clean Project Manager"
             : ""
             : "Usage: " +++ cmd
             : lines]
  = showLines lines` world
514
515
516
517
518
519
520

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