CpmLogic.icl 25.9 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"
Mart Lubbers's avatar
Mart Lubbers committed
253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271
    ,  "                                    : -bytecode FILE"
    ,  "                                    :     Set the bytecode file target, usually mainmodule.bc"
    ,  "                                    : -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"
    ,  "    cpm project test.prj target iTasks"
    ,  "    cpm project test.prj set -dynamics -h 200m -s 2m -descexl -bytecode -optimiseabc -genbytecode -stripbytecode -keepbytecodesymbols -prelinkbytecode"
    ,  "    cpm project test.prj build"
272 273
    ] world

274 275 276
/**
 * Execute environment-specific actions
 */
277
doEnvironmentAction :: String String EnvironmentAction *World -> *World
278
doEnvironmentAction cleanhome pwd ListEnvironments        world
279
	= withEnvironments cleanhome (\ts w->(Nothing, showLines [t.target_name\\t<-ts] w)) world
280
doEnvironmentAction cleanhome pwd (ImportEnvironment ef) world
281 282 283 284 285 286
	= 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)
287
doEnvironmentAction cleanhome pwd (RemoveEnvironment en) world
288
	= withEnvironment cleanhome en (\_ w->(Just [], w)) world
289
doEnvironmentAction cleanhome pwd (ShowEnvironment en) world 
290
	= withEnvironment cleanhome en (\e w->(Nothing, showLines (printEnvironment e) w)) world
291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315
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
		]
316
doEnvironmentAction cleanhome pwd (ExportEnvironment en fp) world
317 318 319 320
	= withEnvironment cleanhome en exportEnvironment world
where
	exportEnvironment t world
		# (ok, world) = saveEnvironments fp [t] world
321
		| not ok = (Nothing, error ("Error saving environment to " +++ fp) world)
322
		= (Nothing, world)
323
doEnvironmentAction cleanhome pwd (CreateEnvironment en Nothing) world
324
	= withEnvironments cleanhome (\t w->(Just [{t_StdEnv & target_name=en}:t], w)) world
325
doEnvironmentAction cleanhome pwd (CreateEnvironment en (Just en`)) world
326
	= withEnvironment cleanhome en` (\t w->(Just [t, {t & target_name=en}], w)) world
327
doEnvironmentAction cleanhome pwd (RenameEnvironment en en`)   world
328
	= withEnvironment cleanhome en (\t w->(Just [{t & target_name=en`}], w)) world
329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345
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
346

347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363
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)

364 365 366 367
modifyEnvironment :: String String (Target -> Target) -> (*World -> *World)
modifyEnvironment cleanhome envname targetf
	= withEnvironment cleanhome envname (\t w->(Just [targetf t], w))

368 369 370
/**
 * Modify a project
 */
371 372 373 374 375 376
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
377 378 379 380

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

385
doProjectPathAction cleanhome pwd pn project (RemovePathAction i) world
386
  = doModPaths cleanhome pwd pn project (RemoveAt i) world
387

388 389
doProjectPathAction _ _ _ project ListPathsAction world
  = showLines ["Paths for project:" : showPaths project] world
390

391 392
doProjectPathAction cleanhome pwd pn project (MovePathAction i pdir) world
  = doModPaths cleanhome pwd pn project (moveStrictListIdx i pdir) world
393

394 395
doProjectPathAction _          _ _   _     _  world
  = help "cpm project <projectname.prj> path <action>"
396 397 398 399 400 401 402 403 404
    [  "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
 */
405
showPaths :: !Project -> [String]
406
showPaths project = ["  [" +++ toString n +++ "]  " +++ p \\ p<|-PR_GetPaths project & n<-[0..]]
407 408 409 410 411 412

/**
 * 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.
 */
413 414
doModPaths :: !String !String !String !Project ([!String!] -> [!String!]) *World -> *World
doModPaths cleanhome pwd pn project f world
415 416
  # paths = PR_GetPaths project
  # prj   = PR_SetPaths False paths (f paths) project
417
  # world = saveProject cleanhome pwd prj pn world
418 419
  = showLines ["Successfully modified project paths"] world

420 421 422 423 424 425
append_dir_separator :: !{#Char} -> {#Char}
append_dir_separator s
	| size s>0 && s.[size s-1]==DirSeparator
		= s
		= s+++DirSeparatorString

426 427 428
/**
 * Open a project file
 */
429 430
openProject :: !FilePath !FilePath !FilePath !*World -> (!FilePath, !Project, Bool, !*World)
openProject pwd pn cleanhome world
431
  # proj_path                = GetLongPathName (append_dir_separator pwd +++ pn)
432 433 434 435
  # ((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)
436 437 438 439

/**
 * Save a project back to its project file
 */
440 441 442 443 444 445 446
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
447 448 449 450 451

/**
 * Move a path at a given index up or down the list of paths. Abort execution
 * if the index is out of bounds.
 */
452
moveStrictListIdx :: !Int PathDirection [!a!] -> [!a!]
453
moveStrictListIdx i dir xs
454 455 456 457 458 459 460 461 462 463 464 465
  | 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!]
466 467 468 469

/**
 * Execute module-related actions
 */
470
doModuleAction :: String !String !ModuleAction !*World -> *World
471
doModuleAction _ mn  (CreateModule mt) world
472
  # (dclexists, world)  = accFiles (FExists dclnm) world
473
  | dclexists           = error ("Definition module '" +++ dclnm +++ "' already exists.") world
474
  # (iclexists, world)  = accFiles (FExists iclnm) world
475
  | iclexists           = error ("Implementation module '" +++ iclnm +++ "' already exists.") world
476
  = writeMods mt world
477
  where
478 479 480
  dclnm      = MakeDefPathname mn
  iclnm      = MakeImpPathname mn
  basenm     = iclnm % (0,size iclnm-5)
481

482
  mkmod mty  = mty +++ "module " +++ basenm
483

484 485 486 487
  writeMods ApplicationModule world = writeicl ApplicationModule world
  writeMods LibraryModule world
    # world = writeicl ApplicationModule world
    = writedcl world
488

489 490
  writeicl ApplicationModule  world = writeicl` "" world
  writeicl LibraryModule      world = writeicl` "implementation " world
491

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

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

496
  writemod nm pref errmsg world
497 498 499 500 501 502 503 504
  	# (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
505 506 507 508

doModuleAction _ _   _  world                =
  help "cpm module <modulename> <action>"
    [  "Where <action> is one of the following"
509 510 511 512
    ,  "  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
513 514 515 516

/**
 * Show an error message
 */
517
error :: !String !*World -> *World
518
error message world
Camil Staps's avatar
Camil Staps committed
519
  # stderr     = stderr <<< message <<< "\n"
520
  # (ok,world) = fclose stderr world
521 522 523 524 525 526
  = set_return_code_world (-1) world

/**
 * Show a help message
 */
help :: !String ![String] !*World -> *World
527 528 529 530 531 532
help cmd lines world
  # lines` = [ "CPM: Clean Project Manager"
             : ""
             : "Usage: " +++ cmd
             : lines]
  = showLines lines` world
533 534 535 536 537 538 539

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