CpmLogic.icl 19.1 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
118
119
120
  # (envs, world)                = readIDEEnvs cleanhome ideenvs world
  # (proj_path, proj, ok, world) = openProject pwd pn cleanhome world
  | not ok
	= world
  # (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}
121
  = gst_world
122
123
  where
  pinit force_rebuild gst = BringProjectUptoDate force_rebuild cleanup gst
124
  cleanup exepath bool1 bool2 ps = abortLog (not bool2) "" ps
125

126
127
128
129
130
131
132
133
134
135
136
doProjectAction cleanhome pwd pn (Compile module_name) world
  # (envs, world) = readIDEEnvs cleanhome EnvsFileName world
    (project_path, project, ok, world) = openProject pwd pn cleanhome world
  | not ok
	= world
  # (console, world) = stdio world
    iniGeneral = initGeneral False compilerOptions cleanhome project_path project envs console
	gst = {ls=iniGeneral,gst_world=world,gst_continue_or_stop=False}
	gst = CompileProjectModule Compilation module_name project (\ _ _ _ gst -> gst) gst
  = gst.gst_world

137
138
139
140
141
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
142

143
144
doProjectAction cleanhome pwd pn (SetRelativeRoot relroot) world
  = withProject pwd pn cleanhome (uncurry (change_root_directory_of_project relroot) o PR_GetRootPathName) world
145

146
147
doProjectAction cleanhome pwd pn (SetTarget target) world
  = withProject pwd pn cleanhome (PR_SetTarget target) world
148

149
150
doProjectAction cleanhome pwd pn (SetExec exec) world
  = withProject pwd pn cleanhome (PR_SetExecPath exec) world
151

152
doProjectAction cleanhome pwd pn (SetProjectOptions project_options) world
153
	= withProject pwd pn cleanhome (set_project_options project_options) world
154
155
156
157
158
159
160
161
162
163
164
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
165
166
167
168
	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
169
170
171
172
	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
173
174
175
	set_project_option (HeapSize hs) project
		= PR_SetApplicationOptions {PR_GetApplicationOptions project & hs = hs} project
	set_project_option (StackSize ss) project
176
		= PR_SetApplicationOptions {PR_GetApplicationOptions project & ss = ss} project
177
178
	set_project_option (Output output) project
		= PR_SetApplicationOptions {PR_GetApplicationOptions project & o = output} project
179
180
181
182
	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
183
184
185
186
	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}
187

188
doProjectAction _          _  _   _    world             =
189
  help "cpm project <projectfile> <action>"
190
    [  "Where <action> is one of the following"
191
192
193
194
195
    ,  "  create                            : create a new project"
    ,  "  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"
196
197
    ,  "  root .[.]                         : set the project root relative to the project file."
    ,  "                                    :  . is the same dir, .. the parent, ... the grandparent, etc."
198
199
200
201
202
    ,  "  target <env>                      : set target environment to <env>"
    ,  "  exec <execname>                   : set executable name to <execname>"
    ,  "  set option [option]               : Set one or more of the following options:"
    ,  "                                    : -generic_fusion,-ngeneric_fusion"
    ,  "                                    :     Enable or disable generic fusion"
203
204
    ,  "                                    : -strip,-nstrip"
	,  "                                    :     Enable or disable application stripping"
205
206
207
208
209
    ,  "                                    : -dynamics,-ndynamics"
    ,  "                                    :     Enable or disable dynamics"
    ,  "                                    : -descexl,-descexl"
    ,  "                                    :     Enable or disable descriptor generation and label exporting"
    ,  "                                    :     This translates to passing -desc and -exl to cocl"
210
211
    ,  "                                    : -rtsopts,-nrtsopts"
    ,  "                                    :     Enable or disable the default rts arguments (-h, -s, etc.)"
212
213
214
    ,  "                                    : -b,-nr,-nc,-sc"
    ,  "                                    :     Set the output option to BasicValuesOnly, NoReturnType,"
    ,  "                                    :     NoConsole or ShowConstructors respectively"
215
216
    ] world

217
218
219
/**
 * Execute environment-specific actions
 */
220
doEnvironmentAction :: String String EnvironmentAction *World -> *World
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
doEnvironmentAction cleanhome  pwd  ListEnvironments                world = error ("Not implemented") world
doEnvironmentAction cleanhome  pwd  (ImportEnvironment ef)          world = error ("Not implemented") world
doEnvironmentAction cleanhome  pwd  (RemoveEnvironment en)          world = error ("Not implemented") world
doEnvironmentAction cleanhome  pwd  (ShowEnvironment en)            world = error ("Not implemented") world
doEnvironmentAction cleanhome  pwd  (ExportEnvironment en)          world = error ("Not implemented") world
doEnvironmentAction cleanhome  pwd  (CreateEnvironment en)          world = error ("Not implemented") world
doEnvironmentAction cleanhome  pwd  (RenameEnvironment en en`)      world = error ("Not implemented") world
doEnvironmentAction cleanhome  pwd  (SetEnvironmentCompiler en cp)  world = error ("Not implemented") world
doEnvironmentAction cleanhome  pwd  (SetEnvironmentCodeGen en cp)   world = error ("Not implemented") 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>                      : create a new environment with name <envname>"
    ,  "  remove <envname>                      : remove evironment <envname>"
    ,  "  show <envname>                        : show environment <envname>"
    ,  "  export <envname>                      : export environment <envname>"
    ,  "  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

244
245
246
/**
 * Modify a project
 */
247
248
249
250
251
252
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
253
254
255
256

/**
 * Execute path-related project actions
 */
257
258
doProjectPathAction :: String String String Project PathAction *World -> *World
doProjectPathAction cleanhome pwd pn project (AddPathAction path) world
259
  = doModPaths cleanhome pwd pn project (\t -> [!GetLongPathName path:t!]) world
260

261
doProjectPathAction cleanhome pwd pn project (RemovePathAction i) world
262
  = doModPaths cleanhome pwd pn project (RemoveAt i) world
263

264
265
doProjectPathAction _ _ _ project ListPathsAction world
  = showLines ["Paths for project:" : showPaths project] world
266

267
268
doProjectPathAction cleanhome pwd pn project (MovePathAction i pdir) world
  = doModPaths cleanhome pwd pn project (moveStrictListIdx i pdir) world
269

270
271
doProjectPathAction _          _ _   _     _  world
  = help "cpm project <projectname.prj> path <action>"
272
273
274
275
276
277
278
279
280
    [  "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
 */
281
showPaths :: !Project -> [String]
282
showPaths project = ["  [" +++ toString n +++ "]  " +++ p \\ p<|-PR_GetPaths project & n<-[0..]]
283
284
285
286
287
288

/**
 * 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.
 */
289
290
doModPaths :: !String !String !String !Project ([!String!] -> [!String!]) *World -> *World
doModPaths cleanhome pwd pn project f world
291
292
  # paths = PR_GetPaths project
  # prj   = PR_SetPaths False paths (f paths) project
293
  # world = saveProject cleanhome pwd prj pn world
294
295
  = showLines ["Successfully modified project paths"] world

296
297
298
299
300
301
append_dir_separator :: !{#Char} -> {#Char}
append_dir_separator s
	| size s>0 && s.[size s-1]==DirSeparator
		= s
		= s+++DirSeparatorString

302
303
304
/**
 * Open a project file
 */
305
306
openProject :: !FilePath !FilePath !FilePath !*World -> (!FilePath, !Project, Bool, !*World)
openProject pwd pn cleanhome world
307
  # proj_path                = GetLongPathName (append_dir_separator pwd +++ pn)
308
309
310
311
  # ((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)
312
313
314
315

/**
 * Save a project back to its project file
 */
316
317
318
319
320
321
322
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
323
324
325
326
327

/**
 * Move a path at a given index up or down the list of paths. Abort execution
 * if the index is out of bounds.
 */
328
moveStrictListIdx :: !Int PathDirection [!a!] -> [!a!]
329
moveStrictListIdx i dir xs
330
331
332
333
334
335
336
337
338
339
340
341
  | 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!]
342
343
344
345

/**
 * Execute module-related actions
 */
346
doModuleAction :: String !String !ModuleAction !*World -> *World
347
doModuleAction _ mn  (CreateModule mt) world
348
  # (dclexists, world)  = accFiles (FExists dclnm) world
349
  | dclexists           = error ("Definition module '" +++ dclnm +++ "' already exists.") world
350
  # (iclexists, world)  = accFiles (FExists iclnm) world
351
  | iclexists           = error ("Implementation module '" +++ iclnm +++ "' already exists.") world
352
  = writeMods mt world
353
  where
354
355
356
  dclnm      = MakeDefPathname mn
  iclnm      = MakeImpPathname mn
  basenm     = iclnm % (0,size iclnm-5)
357

358
  mkmod mty  = mty +++ "module " +++ basenm
359

360
361
362
363
  writeMods ApplicationModule world = writeicl ApplicationModule world
  writeMods LibraryModule world
    # world = writeicl ApplicationModule world
    = writedcl world
364

365
366
  writeicl ApplicationModule  world = writeicl` "" world
  writeicl LibraryModule      world = writeicl` "implementation " world
367

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

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

372
  writemod nm pref errmsg world
373
374
375
376
377
378
379
380
  	# (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
381
382
383
384

doModuleAction _ _   _  world                =
  help "cpm module <modulename> <action>"
    [  "Where <action> is one of the following"
385
386
387
388
    ,  "  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
389
390
391
392

/**
 * Show an error message
 */
393
error :: !String !*World -> *World
394
error message world
395
396
  # stderr     = fwrites message stderr
  # (ok,world) = fclose stderr world
397
398
399
400
401
402
  = set_return_code_world (-1) world

/**
 * Show a help message
 */
help :: !String ![String] !*World -> *World
403
404
405
406
407
408
help cmd lines world
  # lines` = [ "CPM: Clean Project Manager"
             : ""
             : "Usage: " +++ cmd
             : lines]
  = showLines lines` world
409
410
411
412
413
414
415

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