Cpm.icl 15.4 KB
Newer Older
1
2
module Cpm

Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
3
4
5
/**
 * Imports
 */
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
import CommandLine
import Environment
import Error
import File
import FilePath
import Func
import IdeState
import List
import logfile
import ParserCombinators
import Platform
import PmDriver
import PmEnvironment
import PmProject
import set_return_code
Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
21
import StdBool, StdEnum, StdFile, StdFunc, StdMisc, StdTuple
22
23
24
25
import Text
import UtilIO
import UtilStrictLists

Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
/**
 * CPM: Clean Project Management
 *
 * CPM is a tool for managing CleanIDE-compatible projects on the commandline
 * and is targeted at OS X and Linux users who do not have access to the
 * CleanIDE.
 *
 * Currently, only basic project management features are supported:
 * - Build a project
 * - Create a new project
 * - Show project info
 * - Manage project paths
 * - Create new modules
 *
 * In the future, all aspects of a CleanIDE project file should be manageable
 * via CPM.
 *
 * CPM is written to display help messages when an incomplete command is
 * entered. Users are encouraged to explore CPM by themselves by reading these
 * help messages.
 */

/**
 * Datatypes
 */
Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
51
:: CpmAction
52
53
  =  Project FilePath ProjectAction
  |  Module String ModuleAction
Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
54
  |  CpmHelp
55
56
57
58
59
60
61
62
63
64

:: ProjectAction
  =  CreateProject
  |  ShowProject
  |  BuildProject Bool FilePath
  |  ProjectPath PathAction
  |  ProjectHelp

:: PathAction
  =  AddPathAction String
65
66
  |  RemovePathAction Int
  |  ListPathsAction
67
  |  MovePathAction Int PathDirection
68
  |  PathHelp
69

70
71
72
73
:: PathDirection
  =  PathUp
  |  PathDown

74
:: ModuleAction
75
  =  CreateModule ModuleType
76
77
  |  ModuleHelp

78
79
80
81
:: ModuleType
  =  ApplicationModule
  |  LibraryModule

Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
82
83
84
85
86
87
88
/**
 * Parsers
 */

/**
 * Parse one or more non-whitespace characters
 */
89
90
91
pNotSpace :: CParser Char [Char] a
pNotSpace = sp (<+> (satisfy (not o isWhite)))

Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
92
93
94
/**
 * Top-level parser for CPM commands
 */
Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
95
pCpm :: CParser Char CpmAction a
Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
96
pCpm = pProject <|> pModule <!> (yield CpmHelp)
97

Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
98
99
100
101
/**
 * Wrapper around the token parser that converts a Clean string to a list of
 * charactersm for easier parsing
 */
102
103
104
spstrtok :: (String -> CParser Char [Char] a)
spstrtok = sptoken o fromString

Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
105
106
107
/**
 * Parser for the project commands
 */
Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
108
pProject :: CParser Char CpmAction a
Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
109
pProject = spstrtok "project" &> (pProjectWithName <!> yield (Project "" ProjectHelp))
110
  where  pProjectWithName  =  pNotSpace <&> \pn -> pProjectAction <@ Project (toString pn)
111
112
113
         pProjectAction    =  (spstrtok "create"                                   <@ const CreateProject)
                         <|>  (spstrtok "show"                                     <@ const ShowProject)
                         <|>  (spstrtok "build"   &>  pForce  <&> \ f -> pIDEEnvs  <@ BuildProject f)
114
115
                         <|>  (spstrtok "path"    &>  pPathAction)
                         <!>  (pHelp ProjectHelp)
Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
116

Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
117
118
119
/**
 * Parser for all path-related actions
 */
Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
120
121
pPathAction :: CParser Char ProjectAction a
pPathAction = pPathAction <@ ProjectPath
122
123
124
125
   where  pPathAction  =  (spstrtok "add"     &>  pNotSpace  <@   AddPathAction o toString)
                     <|>  (spstrtok "remove"  &>  sp nat     <@   RemovePathAction)
                     <|>  (spstrtok "list"                   <@   const ListPathsAction)
                     <|>  (spstrtok "move"    &>  pPathDirection)
Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
126
                     <!>  (pHelp PathHelp)
127
          pPathDirection = sp nat <&> \i -> ((spstrtok "up" <@ const PathUp) <|> (spstrtok "down" <@ const PathDown)) <@ MovePathAction i
128

Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
129
130
131
/**
 * Parser to toggle the --force flag
 */
132
pForce :: CParser Char Bool a
Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
133
pForce = (spstrtok "--force" <@ const True) <!> (yield False)
134

Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
135
136
137
/**
 * Parser for the argument to specify where the IDEEnvs file is
 */
138
pIDEEnvs :: CParser Char String a
139
140
pIDEEnvs =  (spstrtok "--envs" &> (<?> (spsymbol '=')) &> pNotSpace <@ toString)
       <!>  (yield EnvsFileName)
141

Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
142
143
144
/**
 * Parser for module-related actions
 */
Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
145
pModule :: CParser Char CpmAction a
Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
146
pModule = spstrtok "module" &> (pModuleWithName <!> yield (Module "" ModuleHelp))
147
148
149
150
  where  pModuleWithName  =  pNotSpace <&> \mn -> pModuleAction <@ Module (toString mn)
         pModuleAction    =  (spstrtok "create" &> pModuleType <@ CreateModule)
                        <!>  (pHelp ModuleHelp)
         pModuleType      =  (spstrtok "application" <@ const ApplicationModule)
Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
151
                        <!>  (yield LibraryModule)
Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
152

Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
153
154
155
/**
 * Parser for the help command
 */
Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
156
157
pHelp :: c -> CParser Char c a
pHelp c = (spstrtok "help" <@ const c) <|> (yield c)
158

Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
159
160
161
162
/**
 * Start function which reads the program arguments, starts the parser and
 * starts processing the parse results.
 */
163
164
165
166
167
168
169
170
171
Start :: *World -> *World
Start world
  # (cmd, world)  = getCommandLine world
    cl            = concat (intersperse " " (tl [fromString arg \\ arg <- cmd]))
    cpm           = startParse (fromString cl)
    (pwd, world)  = accFiles GetFullApplicationPath world
    (ch, world)   = case getEnvironmentVariable "CLEAN_HOME" world of
                      (Just ch, world)  -> (ch, world)
                      (_, world)        -> (pwd, world)
172
  = doCpmAction ch pwd cpm world
173

Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
174
175
176
177
/**
 * Parse the a list of characters to get the action to be executed. If parsing
 * fails, CpmHelp is returned as default action so help may be displayed.
 */
Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
178
startParse :: [.Char] -> CpmAction
Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
179
startParse args = maybe CpmHelp snd (find (null o fst) (begin pCpm args))
180

Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
181
182
183
/**
 * Execute a general CPM action
 */
184
185
186
187
doCpmAction :: String String .CpmAction *World -> .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 _          _    _                world =
188
189
  help  "cpm <target>"
    [  "Where <target> is one of the following:"
190
    ,  "  project <projectname>  : project actions"
191
    ,  "  module <modulename>    : module actions"
192
193
    ,  ""
    ,  "Execute `cpm <target> help` to get help for specific actions."] world
194

Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
195
196
197
198
/**
 * Default compiler options. Currently it is a simple alias for
 * forwards-compatibility.
 */
199
200
201
compilerOptions :: CompilerOptions
compilerOptions = DefaultCompilerOptions

Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
202
203
204
/**
 * Execute project-specific actions
 */
205
206
doProjectAction :: .String .String .String .ProjectAction *World -> .World
doProjectAction cleanhome pwd  pn  CreateProject world
207
208
209
  //Check if main module exists
  # (exists,world)    = fileExists mainmodule world
  | not exists        = error ("Main module " +++ mainmodule +++ " does not exist.") world
210
211
  # (prjok, world)    = accFiles (SaveProjectFile projectfile project cleanhome) world
  | not prjok         = error ("Could not create project file " +++ projectfile) world
212
  = world
213
214
215
216
217
218
219
220
  where  basefilename  = dropExtension pn
         mainmodule    = addExtension basefilename "icl"
         projectfile   = addExtension basefilename "prj"
         edit_options  = {eo={newlines=NewlineConventionUnix},pos_size=NoWindowPosAndSize}
         project       = PR_SetRoot mainmodule edit_options compilerOptions prj
           //Create project file using the Clean IDE libraries 
           where prj  = PR_NewProject mainmodule edit_options compilerOptions DefCodeGenOptions
                          DefApplicationOptions [!!] DefaultLinkOptions
221

222
doProjectAction cleanhome pwd  pn  ShowProject world
223
224
  # projectfile      = addExtension (dropExtension pn) "prj"
  //Open the projectfile
225
  # (mbProj, world)  = openProject cleanhome projectfile world
226
227
  = case mbProj of
      Error e     -> error e world
228
229
230
231
232
233
234
      Ok project  -> showLines
                       [  "Content of " +++ projectfile
                       ,  "Target: " +++ PR_GetTarget project
                       ,  "Executable: " +++ PR_GetExecPath project
                       ,  "Paths:"
                       :  [toString p \\ p <- StrictListToList (PR_GetPaths project)]
                       ] world
235

236
doProjectAction cleanhome pwd  pn  (BuildProject force ideenvs) world
237
  # (envs, world)              = openEnvironments cleanhome envsfile world
238
  # ((proj, ok, err), world)   = accFiles (ReadProjectFile proj_path pwd) world
Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
239
  | not ok || err <> ""        = error ("CPM failed while opening project: "+++.err+++."\n") world
240
  # (ok, logfile, world)       = openLogfile proj_path world
Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
241
  | not ok                     = error ("CPM failed while opening logfile.\n") world
242
243
  # iniGeneral                 = initGeneral True compilerOptions pwd proj_path proj envs logfile
  # {ls, gst_world}            = pinit force {ls=iniGeneral,gst_world=world,gst_continue_or_stop=False}
244
  = gst_world
Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
245
246
  where  envsfile   = cleanhome </> ideenvs
         proj_path  = GetLongPathName pn
247

248
doProjectAction cleanhome  _  pn  (ProjectPath pa) world
249
250
251
252
   # projectfile      = addExtension (dropExtension pn) "prj"
   //Open the projectfile
   # (mbProj, world)  = openProject cleanhome projectfile world
   = case mbProj of
253
254
       Error e     -> error e world
       Ok project  -> doProjectPathAction cleanhome projectfile project pa world
255

256
doProjectAction _          _  _   _    world             =
257
  help "cpm project <projectname> <action>"
258
    [  "Where <action> is one of the following"
259
260
261
262
    ,  "  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')"
263
264
    ,  "  path                                : manage project paths"] world

Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
265
266
267
/**
 * Execute path-related project actions
 */
268
doProjectPathAction :: .String .String Project .PathAction *World -> .World
269
270
doProjectPathAction cleanhome pn project (AddPathAction path) world =
  doModPaths cleanhome pn project (\paths -> path :! paths) world
271

272
273
doProjectPathAction cleanhome pn project (RemovePathAction i) world =
  doModPaths cleanhome pn project (rmStrictListIdx i) world
274

275
doProjectPathAction _ _ project ListPathsAction world = showLines ["Paths for project:" : paths] world
276
  where  paths     = map f (zip2 [0..] (StrictListToList (PR_GetPaths project)))
Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
277
         f (n, p)  = "  [" +++ toString n +++ "]  " +++ p
278

279
280
doProjectPathAction cleanhome pn project (MovePathAction i pdir) world =
  doModPaths cleanhome pn project (moveStrictListIdx i pdir) world
281

282
doProjectPathAction _         _   _     _  world =
283
284
  help "cpm project <projectname> path <action>"
    [  "Where <action> is one of the following"
285
286
287
288
    ,  "  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
289

Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
290
291
292
293
294
/**
 * 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.
 */
295
296
297
298
299
300
301
302
doModPaths :: String String Project .([!String!] -> [!String!]) *World -> .World
doModPaths cleanhome pn project f world
  # (ok, world)  = saveProject cleanhome prj pn world
  | not ok       = abort "Failed to modify project paths"
  = showLines ["Successfully modified project paths"] world
  where  paths   = PR_GetPaths project
         prj     = PR_SetPaths False paths (f paths) project

Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
303
304
305
/**
 * Open a project file
 */
306
307
308
309
310
311
openProject :: !FilePath !FilePath !*World -> (!MaybeErrorString Project,!*World)
openProject cleanhome projectfile world
  # ((prj, ok, err), world) = accFiles (ReadProjectFile projectfile cleanhome) world
  | ok  = (Ok prj, world)
        = (Error err, world)

Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
312
313
314
/**
 * Save a project back to its project file
 */
315
316
317
saveProject :: !FilePath !Project !FilePath !*World -> (Bool, !*World)
saveProject cleanhome prj projectfile world = accFiles (SaveProjectFile projectfile prj cleanhome) world

Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
318
319
320
321
/**
 * Remove an item from a strict list at a given index. Abort execution if the
 * index is out of bounds.
 */
322
rmStrictListIdx :: Int u:[!.a!] -> v:[!.a!], [u <= v]
323
324
325
326
rmStrictListIdx 0  (_ :! t)          = t
rmStrictListIdx n  (h :! t) | n > 0  = h :! (rmStrictListIdx (n - 1) t)
rmStrictListIdx n  _                 = abort ("Index " +++ toString n +++ " out of bounds")

Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
327
328
329
330
/**
 * Move a path at a given index up or down the list of paths. Abort execution
 * if the index is out of bounds.
 */
331
moveStrictListIdx :: .Int .PathDirection .[!a!] -> .[!a!]
332
333
334
335
336
337
338
339
340
341
moveStrictListIdx i dir xs
  | i < 0 || i > (LLength xs - 1)  = abort ("Index " +++ toString i +++ " out of bounds")
  | otherwise                      = ListToStrictList (msl dir (splitAt i (StrictListToList xs)))
  where  msl PathUp    ([], xs)        = xs
         msl PathUp    (xs, [x:ys])    = ((init xs) ++ [x : (last xs) : ys])
         msl PathDown  ([], [x:y:ys])  = [y:x:ys]
         msl PathDown  (xs, [])        = xs
         msl PathDown  (xs, [y])       = xs ++ [y]
         msl PathDown  (xs, [x:y:ys])  = (xs ++ [y:x:ys])

Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
342
343
344
/**
 * Execute module-related actions
 */
345
346
doModuleAction :: .String .String .ModuleAction *World -> .World
doModuleAction cleanhome mn  (CreateModule mt) world
347
  # (dclexists, world)  = fileExists dclnm world
348
  | dclexists           = dexerr world
349
  # (iclexists, world)  = fileExists iclnm world
350
  | iclexists           = iexerr world
351
  = writeMods mt world
352
353
354
355
356
357
  where  basenm     = dropExtension mn
         dclnm      = addExtension basenm "dcl"
         iclnm      = addExtension basenm "icl"

         mkmod mty  = mty +++ "module " +++ basenm

358
359
360
         writeMods ApplicationModule world = writeicl ApplicationModule world
         writeMods LibraryModule world
           # world = writeicl ApplicationModule world
361
362
           = writedcl world

363
         writeicl ApplicationModule world = writeicl` "implementation " world
364

365
         writeicl LibraryModule world = writeicl` "" world
366

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

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

371
         writemod nm pref errmsg world
372
373
374
375
376
377
           # (me, world)  = writeFile nm (mkmod pref) world
           | isError me   = error errmsg world
           = world

         dexerr world = error ("Definition module '" +++ dclnm +++ "' already exists.") world
         iexerr world = error ("Implementation module '" +++ iclnm +++ "' already exists.") world
378

379
doModuleAction _ _   _  world                =
380
381
382
  help "cpm module <modulename> <action>"
    [  "Where <action> is one of the following"
    ,  "  create [application|library]  : create a new module. Optionally specify module type (default: 'library')"] world
383

Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
384
385
386
387
/**
 * Show an error message
 */
error :: String *World -> .World
388
389
390
391
392
393
error message world
  # stderr      = fwrites message stderr
  # (ok,world)  = fclose stderr world
  # world       = set_return_code_world (-1) world
  = world

Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
394
395
396
/**
 * Show a help message
 */
397
help :: !String ![String] !*World -> *World
398
help cmd lines world = showLines lines` world
399
400
401
402
403
  where lines` = [  "CPM: Clean Project Management"
                 :  ""
                 :  "Usage: " +++ cmd
                 :  lines]

Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
404
405
406
407
/**
 * Given a list of strings, concatenate them to a single string with newlines
 * in between, then print that new string to console.
 */
408
409
showLines :: ![String] !*World -> *World
showLines lines world
410
411
412
413
414
415
416
417
418
419
420
421
422
  # (console,world)  = stdio world
  # console          = seqSt (\s c -> fwrites (s +++ "\n") c) lines console
  # (_,world)        = fclose console world
  = world


// TODO: Use the version from BatchBuild
pinit :: .Bool *GeneralSt -> *GeneralSt
pinit force_rebuild ps
  = BringProjectUptoDate force_rebuild cleanup ps
where
  cleanup exepath bool1 bool2 ps
    = abortLog False "" ps