Cpm.icl 11.9 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
module Cpm

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
18
import StdEnv, StdFile
19
20
21
22
import Text
import UtilIO
import UtilStrictLists

Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
23
:: CpmAction
24
25
  =  Project FilePath ProjectAction
  |  Module String ModuleAction
Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
26
  |  CpmHelp
27
28
29
30
31
32
33
34
35
36

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

:: PathAction
  =  AddPathAction String
37
38
39
  |  RemovePathAction Int
  |  ListPathsAction
  |  PathHelp
40
41

:: ModuleAction
42
  =  CreateModule ModuleType
43
44
  |  ModuleHelp

45
46
47
48
:: ModuleType
  =  ApplicationModule
  |  LibraryModule

49
50
51
pNotSpace :: CParser Char [Char] a
pNotSpace = sp (<+> (satisfy (not o isWhite)))

Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
52
pCpm :: CParser Char CpmAction a
Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
53
pCpm = pProject <|> pModule <!> (yield CpmHelp)
54
55
56
57

spstrtok :: (String -> CParser Char [Char] a)
spstrtok = sptoken o fromString

Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
58
pProject :: CParser Char CpmAction a
Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
59
60
61
62
63
64
65
66
67
68
69
70
71
pProject = spstrtok "project" &> pNotSpace <&> \pn -> pProjectAction <@ Project (toString pn)
  where  pProjectAction  =  (spstrtok "create"                                  <@ const CreateProject)
                       <|>  (spstrtok "show"                                    <@ const ShowProject)
                       <|>  (spstrtok "build"   &>  pForce  <&> \ f-> pIDEEnvs  <@ BuildProject f)
                       <|>  (spstrtok "path"    &>  pPathAction)
                       <!>  (pHelp ProjectHelp)

pPathAction :: CParser Char ProjectAction a
pPathAction = pPathAction <@ ProjectPath
   where  pPathAction  =  (spstrtok "add"     &>  pNotSpace  <@ AddPathAction o toString)
                     <|>  (spstrtok "remove"  &>  nat        <@ RemovePathAction)
                     <|>  (spstrtok "list"                   <@ const ListPathsAction)
                     <!>  (pHelp PathHelp)
72
73

pForce :: CParser Char Bool a
Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
74
pForce = (spstrtok "--force" <@ const True) <|> (yield False)
75
76

pIDEEnvs :: CParser Char String a
Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
77
pIDEEnvs = (spstrtok "--envs" &> (<?> (spsymbol '=')) &> pNotSpace <@ toString) <!> (yield EnvsFileName)
78

Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
79
pModule :: CParser Char CpmAction a
Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
80
81
82
83
84
85
86
pModule = spstrtok "module" &> pNotSpace <&> \mn -> pModuleAction <@ Module (toString mn)
  where  pModuleAction  =  (spstrtok "create" &> pModuleType <@ CreateModule)
                      <!>  (yield ModuleHelp)
         pModuleType    =  (spstrtok "application" <@ const ApplicationModule) <|> (yield LibraryModule)

pHelp :: c -> CParser Char c a
pHelp c = (spstrtok "help" <@ const c) <|> (yield c)
87
88
89
90
91
92
93
94
95
96

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)
Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
97
  = doCpmAction world ch pwd cpm
98

Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
99
100
startParse :: [.Char] -> CpmAction
startParse args =  case filter (\(xs, _) -> xs == []) (begin pCpm args) of
101
                     [(_, as):_]  -> as
Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
102
                     _            -> CpmHelp
103

Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
104
105
106
doCpmAction :: *World String String .CpmAction -> .World
doCpmAction world cleanhome  pwd  (Project pn pa)  = doProjectAction world cleanhome pwd pn pa
doCpmAction world cleanhome  pwd  (Module mn ma)   = doModuleAction world cleanhome mn ma
Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
107
doCpmAction world _          _    _                =
108
109
  help  "cpm <target>"
    [  "Where <target> is one of the following:"
110
    ,  "  project <projectname>  : project actions"
111
    ,  "  module <modulename>    : module actions"
112
113
    ,  ""
    ,  "Execute `cpm <target> help` to get help for specific actions."] world
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128

doProjectAction :: *World .String .String .String .ProjectAction -> .World
doProjectAction world cleanhome pwd  pn  CreateProject
  # basefilename      = dropExtension pn
  # mainmodule        = addExtension basefilename "icl"
  # projectfile       = addExtension basefilename "prj"
  //Check if main module exists
  # (exists,world)    = fileExists mainmodule world
  | not exists        = error ("Main module " +++ mainmodule +++ " does not exist.") world
  //Create project file using the Clean IDE libraries 
  # edit_options      = {eo={newlines=NewlineConventionUnix},pos_size=NoWindowPosAndSize}
  # compiler_options  = DefaultCompilerOptions;
  # project           = PR_NewProject mainmodule edit_options compiler_options DefCodeGenOptions
                          DefApplicationOptions [!!] DefaultLinkOptions
  # project           = PR_SetRoot mainmodule edit_options compiler_options project
129
130
  # (prjok, world)    = accFiles (SaveProjectFile projectfile project cleanhome) world
  | not prjok         = error ("Could not create project file " +++ projectfile) world
131
132
133
134
135
136
137
138
  = world

doProjectAction world cleanhome pwd  pn  ShowProject
  # projectfile      = addExtension (dropExtension pn) "prj"
  //Open the projectfile
  # (mbProj ,world)  = openProject cleanhome projectfile world
  = case mbProj of
      Error e     -> error e world
139
140
141
142
143
144
145
      Ok project  -> showLines
                       [  "Content of " +++ projectfile
                       ,  "Target: " +++ PR_GetTarget project
                       ,  "Executable: " +++ PR_GetExecPath project
                       ,  "Paths:"
                       :  [toString p \\ p <- StrictListToList (PR_GetPaths project)]
                       ] world
146
147

doProjectAction world cleanhome pwd  pn  (BuildProject force ideenvs)
148
  # envsfile                   = cleanhome </> ideenvs
149
  # (envs, world)              = openEnvironments cleanhome envsfile world
150
151
  # proj_path                  = GetLongPathName pn
  # ((proj, ok, err), world)   = accFiles (ReadProjectFile proj_path pwd) world
Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
152
  | not ok || err <> ""        = error ("CPM failed while opening project: "+++.err+++."\n") world
153
  # (ok, logfile, world)       = openLogfile proj_path world
Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
154
  | not ok                     = error ("CPM failed while opening logfile.\n") world
155
  # default_compiler_options   = DefaultCompilerOptions
156
  # iniGeneral                 = initGeneral True default_compiler_options pwd proj_path proj envs logfile
157
158
159
160
  # ps                         = {ls=iniGeneral,gst_world=world,gst_continue_or_stop=False}
  # {ls, gst_world}            = pinit force ps
  = gst_world

161
162
163
164
165
166
167
168
doProjectAction world cleanhome  _  pn  (ProjectPath pa)
   # projectfile      = addExtension (dropExtension pn) "prj"
   //Open the projectfile
   # (mbProj, world)  = openProject cleanhome projectfile world
   = case mbProj of
       Error e     = error e world
       Ok project  = doProjectPathAction world cleanhome projectfile project pa

Jurrien Stutterheim's avatar
Jurrien Stutterheim committed
169
doProjectAction world _          _  _   _                 =
170
  help "cpm project <projectname> <action>"
171
    [  "Where <action> is one of the following"
172
173
174
175
    ,  "  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')"
176
177
178
179
180
181
182
183
184
    ,  "  path                                : manage project paths"] world

doProjectPathAction :: *World .String .String Project .PathAction -> .World
doProjectPathAction world cleanhome pn project (AddPathAction path)
  # paths        = PR_GetPaths project
  # prj          = PR_SetPaths False paths (path :! paths) project // TODO: Double check to see if PR_SetPaths is used correctly
  # (ok, world)  = saveProject cleanhome prj pn world
  | not ok       = abort "Failed to add path to project" // TODO: Improve
  = world
185

186
187
188
189
190
191
192
193
194
195
196
doProjectPathAction world cleanhome pn project (RemovePathAction n)
  # paths        = PR_GetPaths project
  # paths`       = rmStrictListIdx n paths
  # prj          = PR_SetPaths False paths paths` project // TODO: Double check to see if PR_SetPaths is used correctly
  # (ok, world)  = saveProject cleanhome prj pn world
  | not ok       = abort "Failed to remove path from project" // TODO: Improve
  = world

doProjectPathAction world _ _ project ListPathsAction = showLines ["Paths for project:" : paths] world
  where  paths     = map f (zip2 [0..] (StrictListToList (PR_GetPaths project)))
         f (n, p)  = "  [" +++ toString n +++ "] " +++ p
197

198
199
200
201
202
203
doProjectPathAction world _         _   _     _   =
  help "cpm project <projectname> path <action>"
    [  "Where <action> is one of the following"
    ,  "  add <path>  : add a path to the project"
    ,  "  list        : list all project paths"
    ,  "  remove <n>  : remove path <n> from the list of projects"] world
204
205
206
207
208
209
210

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)

211
212
213
214
215
216
217
218
219
saveProject :: !FilePath !Project !FilePath !*World -> (Bool, !*World)
saveProject cleanhome prj projectfile world = accFiles (SaveProjectFile projectfile prj cleanhome) world


rmStrictListIdx :: !Int !(List String) -> List String
rmStrictListIdx 0  (_ :! t)          = t
rmStrictListIdx n  (h :! t) | n > 0  = h :! (rmStrictListIdx (n - 1) t)
rmStrictListIdx n  _                 = abort ("Index " +++ toString n +++ " out of bounds")

220
doModuleAction :: *World .String .String .ModuleAction -> .World
221
doModuleAction world cleanhome mn  (CreateModule mt)
222
  # (dclexists, world)  = fileExists dclnm world
223
  | dclexists           = dexerr world
224
  # (iclexists, world)  = fileExists iclnm world
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
  | iclexists           = iexerr world
  = writeMods world mt
  where  basenm     = dropExtension mn
         dclnm      = addExtension basenm "dcl"
         iclnm      = addExtension basenm "icl"

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

         writeMods world ApplicationModule  = writeicl world ApplicationModule
         writeMods world LibraryModule
           # world = writeicl world ApplicationModule
           = writedcl world

         writeicl world ApplicationModule = writeicl` world "implementation "

         writeicl world LibraryModule = writeicl` world ""

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

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

         writemod world nm pref errmsg
           # (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
253
254

doModuleAction world _ _   _                  =
255
256
257
  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
258
259
260
261
262
263
264
265

error :: {#.Char} *World -> .World
error message world
  # stderr      = fwrites message stderr
  # (ok,world)  = fclose stderr world
  # world       = set_return_code_world (-1) world
  = world

266
help :: !String ![String] !*World -> *World
267
help cmd lines world = showLines lines` world
268
269
270
271
272
  where lines` = [  "CPM: Clean Project Management"
                 :  ""
                 :  "Usage: " +++ cmd
                 :  lines]

273
274
showLines :: ![String] !*World -> *World
showLines lines world
275
276
277
278
279
280
281
282
283
284
285
286
287
  # (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