The Meta-Environment API
00001 #ifndef __RSCRIPT_UTILS__ 00002 #define __RSCRIPT_UTILS__ 00003 00004 #include <parse-utils.tb> 00005 #include <error-utils.tb> 00006 #include <io-utils.tb> 00007 #include <config-utils.tb> 00008 00009 #define RSCRIPT_TREE_CACHE "rscript-annotated-tree" 00010 00011 process NewModuleContentHandler is 00012 let 00013 ModuleId: str, 00014 Pid: int 00015 in 00016 Pid := process-id 00017 . 00018 ( 00019 rec-msg(get-module-contents(Pid, ModuleId?)) 00020 . snd-msg(module-contents(Pid, [""])) 00021 + 00022 rec-msg(cancel-content-handler(Pid)) 00023 ) 00024 endlet 00025 00026 process DumpRScriptDefinition(ModuleId: module-id, Filename: str) is 00027 let 00028 Syntax: term, 00029 Path: str, 00030 Text: str, 00031 Error: term, 00032 ErrorMessage: str 00033 in 00034 AddJob(Filename) 00035 . GetSyntaxDefinition(ModuleId, Syntax?) 00036 . 00037 if not-equal(Syntax, UNDEFINED) then 00038 GetModulePath(ModuleId, RSCRIPT_NAMESPACE, Path?) 00039 . snd-msg(unparse(Syntax)) 00040 . rec-msg(unparsed-text(Text?)) 00041 . snd-msg(io-write-text-list(Filename, [Text])) 00042 . 00043 ( 00044 rec-msg(io-file-written) 00045 + 00046 rec-msg(io-file-not-written(Error?)) 00047 ) 00048 else 00049 tau 00050 fi 00051 . JobDone(Filename) 00052 endlet 00053 00054 process GetModules(ModuleIds: list, Modules: list?) is 00055 let 00056 Runner: list, 00057 Result: list, 00058 ModuleTree: term, 00059 ModuleId: module-id, 00060 Incomplete: bool 00061 in 00062 Runner := ModuleIds 00063 . Result := [] 00064 . 00065 if and(not-equal(Runner, []),not-equal(Incomplete,true)) then 00066 ModuleId := first(Runner) 00067 . GetRSCRIPTParsetree(ModuleId, ModuleTree?) 00068 . 00069 if equal(ModuleTree, UNDEFINED) then 00070 Incomplete := true 00071 else 00072 tau 00073 fi 00074 . Result := join(ModuleTree, Result) 00075 . Runner := next(Runner) 00076 fi 00077 * 00078 if or(equal(Runner, []),equal(Incomplete,true)) then 00079 tau 00080 fi 00081 . 00082 if equal(Incomplete, true) then 00083 Modules := [] 00084 else 00085 Modules := Result 00086 fi 00087 endlet 00088 00089 process GetSyntaxDefinition(ModuleId: module-id, Syntax: term?) is 00090 let 00091 ModuleIds: list, 00092 Modules: list, 00093 Status: term 00094 in 00095 MM-GetAttribute(ModuleId, RSCRIPT_NAMESPACE, "status", Status?) 00096 . 00097 if equal(Status, complete) then 00098 MM-GetAllModuleDependencies(ModuleId, ModuleIds?) 00099 . ModuleIds := join([ModuleId], ModuleIds) 00100 . GetModules(ModuleIds, Modules?) 00101 . 00102 if equal(Modules, []) then 00103 Syntax := UNDEFINED 00104 else 00105 snd-msg(sm-make-rscript-definition(Modules)) 00106 . 00107 ( 00108 rec-msg(sm-rscript-definition(Syntax?)) 00109 + 00110 rec-msg(sm-no-rscript-definition) 00111 . Syntax := UNDEFINED 00112 ) 00113 fi 00114 else 00115 Syntax := UNDEFINED 00116 fi 00117 endlet 00118 00119 process CheckRSCRIPTModule(ModuleId: module-id) is 00120 let 00121 Errors: list, 00122 Modulename: str, 00123 Summary: summary, 00124 Tree: term 00125 in 00126 GetRSCRIPTParsetree(ModuleId, Tree?) 00127 . 00128 if not-equal(Tree, UNDEFINED) then 00129 snd-msg(check-rscript(Tree)) 00130 . rec-msg(checked-rscript(Summary?)) 00131 . MM-GetAttribute(ModuleId, RSCRIPT_NAMESPACE, "name", Modulename?) 00132 . ReplaceSummaryInfo(Summary?, "rscript-checker", Modulename) 00133 . RemoveSummary("rscript-checker", Modulename) 00134 . DisplaySummary(Summary) 00135 else 00136 tau 00137 fi 00138 endlet 00139 00140 process GetImportedModulenames(Tree: term, Imports: list?) is 00141 tau 00142 00143 process CloseOtherModules(ModuleId: module-id) is 00144 let 00145 Dependencies: list, 00146 CloseModules: list, 00147 NewTerm: term 00148 in 00149 MM-GetAllModuleDependencies(ModuleId, Dependencies?) 00150 . Dependencies := join(Dependencies, [ModuleId]) 00151 . MM-GetAllModules(CloseModules?) 00152 . CloseModules := diff(CloseModules, Dependencies) 00153 . CloseModules(CloseModules) 00154 endlet 00155 00156 process CloseModule(ModuleId: module-id, Recursive: bool) is 00157 let 00158 Dependencies: list, 00159 Modulename: str, 00160 CloseModules: list, 00161 NewTerm: term 00162 in 00163 MM-GetAttribute(ModuleId, RSCRIPT_NAMESPACE, "name", Modulename?) 00164 . 00165 if equal(Recursive, true) then 00166 MM-GetClosableModules(ModuleId, CloseModules?) 00167 . 00168 if equal(CloseModules, []) then 00169 printf("warning: Unable to close %s, it would break some import(s).\n", Modulename) 00170 else 00171 CloseModules(CloseModules) 00172 fi 00173 else 00174 MM-GetModuleParents(ModuleId, Dependencies?) 00175 . 00176 if equal(Dependencies, []) then 00177 CloseModules([ModuleId]) 00178 else 00179 printf("warning: Unable to close %s, it would break the import of: %t\n", 00180 Modulename, Dependencies) 00181 fi 00182 fi 00183 endlet 00184 00185 process CloseModules(CloseModules: list) is 00186 let 00187 ModuleId: module-id, 00188 Modules: list 00189 in 00190 Modules := quote(CloseModules) 00191 . 00192 if not-equal(Modules, []) then 00193 ModuleId := first(Modules) 00194 . MM-DeleteModule(ModuleId) 00195 . Modules := next(Modules) 00196 fi 00197 * 00198 if equal(Modules, []) then 00199 tau 00200 fi 00201 endlet 00202 00203 process CancelCreateNewModule(Pid: int, Error: str, Args: list) is 00204 snd-note(ui-status(errorf(Error, Args))) 00205 . snd-msg(cancel-content-handler(Pid)) 00206 00207 process CreateNewModule(Pid: int, Directory: str, Filename: str) is 00208 let 00209 BaseDir: str, 00210 Contents: list, 00211 Error: term, 00212 Extension: str, 00213 ModuleId: module-id, 00214 Modulename: str, 00215 Path: str 00216 in 00217 Modulename := Filename 00218 . MM-GetModuleIdByAttribute(RSCRIPT_NAMESPACE, "name", Modulename, ModuleId?) 00219 . 00220 if equal(ModuleId, UNDEFINED) then 00221 BuildPath(Directory, Modulename, RSCRIPT_EXTENSION, Path?) 00222 . snd-msg(io-exists-file(Path)) 00223 . 00224 ( 00225 rec-msg(io-file-exists) 00226 . CancelCreateNewModule(Pid, "File %s already exists", [Path]) 00227 + 00228 rec-msg(io-file-not-exists) 00229 . snd-msg(get-module-contents(Pid, Modulename)) 00230 . rec-msg(module-contents(Pid, Contents?)) 00231 . snd-msg(io-write-text-list(Path, Contents)) 00232 . 00233 ( 00234 rec-msg(io-file-written) 00235 . OpenModule(Modulename, ModuleId?) 00236 + 00237 rec-msg(io-file-not-written(Error?)) 00238 . snd-note(ui-status(errorf("%s: %s", [Path, Error]))) 00239 ) 00240 ) 00241 else 00242 CancelCreateNewModule(Pid, "Module %s already exists", [Modulename]) 00243 fi 00244 endlet 00245 00246 process CopyRScriptModule(SrcModulename: str, Directory: str, Filename: str) is 00247 let 00248 Id: int, 00249 Pid: int 00250 in 00251 Id := process-id 00252 . snd-note(ui-status(statf(Id, "Copying %s to %s", [SrcModulename, Filename]))) 00253 . create(CopyRScriptContentHandler(SrcModulename), Pid?) 00254 . CreateNewModule(Pid, Directory, Filename) 00255 . snd-note(ui-status(endstat(Id))) 00256 endlet 00257 00258 process CopyRScriptContentHandler(SrcModulename: str) is 00259 let 00260 Contents: str, 00261 DestModulename: str, 00262 Pid: int, 00263 Syntax: term 00264 in 00265 Pid := process-id 00266 . 00267 ( 00268 rec-msg(get-module-contents(Pid, DestModulename?)) 00269 . snd-msg(ts-get-term-value("rscript-tree", SrcModulename)) 00270 . rec-msg(ts-value("rscript-tree", SrcModulename, Syntax?)) 00271 . snd-msg(sm-rename-modulename-in-module(Syntax, DestModulename)) 00272 . rec-msg(sm-modulename-renamed-in-module(Syntax?)) 00273 . snd-msg(unparse(Syntax)) 00274 . rec-msg(unparsed-text(Contents?)) 00275 . snd-msg(module-contents(Pid, [Contents])) 00276 + 00277 rec-msg(cancel-content-handler(Pid)) 00278 ) 00279 endlet 00280 00281 process SaveRScriptModules(Modules: list, Status: term?) is 00282 let 00283 Runner: list, 00284 Module: str 00285 in 00286 Runner := Modules 00287 . 00288 if not-equal(Runner, []) then 00289 Module := first(Runner) 00290 . snd-msg(save-module(Module, rscript)) 00291 . rec-msg(saved-module(Module, Status?)) 00292 . Runner := next(Runner) 00293 fi 00294 * 00295 if equal(Runner, []) then 00296 tau 00297 fi 00298 endlet 00299 00300 process IsLibraryModule(ModuleId: module-id, LibraryModule: bool?) is 00301 let 00302 Directories: list, 00303 Extension: str, 00304 Filename: str, 00305 Modulename: str, 00306 Path: str, 00307 Prefix: str 00308 in 00309 snd-msg(cm-get-library-paths) 00310 . rec-msg(cm-library-paths(Directories?)) 00311 . GetModulePath(ModuleId, RSCRIPT_NAMESPACE, Path?) 00312 . snd-msg(io-get-relative-filename(Directories, Path, ".rscript")) 00313 . rec-msg(io-filename(Directories, Path, ".rscript", Prefix?, Filename?)) 00314 . 00315 if equal(Filename, "") then 00316 LibraryModule := false 00317 else 00318 LibraryModule := true 00319 fi 00320 endlet 00321 00322 process CreateModule(Modulename: str, ModuleId: module-id?) is 00323 MM-GetModuleIdByAttribute(RSCRIPT_NAMESPACE, "name", Modulename, ModuleId?) 00324 . 00325 if equal(ModuleId, UNDEFINED) then 00326 MM-CreateModule(ModuleId?) 00327 . MM-SetAttribute(ModuleId, RSCRIPT_NAMESPACE, "name", Modulename) 00328 . MM-SetAttribute(ModuleId, RSCRIPT_NAMESPACE, "status", unknown) 00329 else 00330 tau 00331 fi 00332 00333 process OpenModule(Modulename: str, ModuleId: module-id?) is 00334 let 00335 Editable: bool, 00336 LibraryModule: bool, 00337 Path: str 00338 in 00339 CreateModule(Modulename, ModuleId?) 00340 . GetModulePath(ModuleId, RSCRIPT_NAMESPACE, Path?) 00341 . 00342 if equal(Path, EMPTY_PATH) then 00343 LocateFile(Modulename, RSCRIPT_EXTENSION, Path?) 00344 . 00345 if equal(Path, EMPTY_PATH) then 00346 printf("warning: Unable to locate %s\n", Modulename) 00347 . BuildPath(".", Modulename, RSCRIPT_EXTENSION, Path?) 00348 . SetModulePath(ModuleId, RSCRIPT_NAMESPACE, Path) 00349 . MM-SetAttribute(ModuleId, RSCRIPT_NAMESPACE, "editable", true) 00350 . MM-SetAttribute(ModuleId, RSCRIPT_NAMESPACE, "status", unavailable) 00351 else 00352 SetModulePath(ModuleId, RSCRIPT_NAMESPACE, Path) 00353 . IsLibraryModule(ModuleId, LibraryModule?) 00354 . Editable := not(LibraryModule) 00355 . MM-SetAttribute(ModuleId, RSCRIPT_NAMESPACE, "editable", Editable) 00356 . MM-SetAttribute(ModuleId, RSCRIPT_NAMESPACE, "status", available) 00357 fi 00358 else 00359 tau 00360 fi 00361 endlet 00362 00363 toolbus(InitCache(RSCRIPT_TREE_CACHE)) 00364 toolbus(ClearCacheHandler(RSCRIPT_TREE_CACHE, RSCRIPT_NAMESPACE, "status", <term>, edited)) 00365 00366 process GetRSCRIPTParsetree(ModuleId: module-id, Result: term?) is 00367 let 00368 ParseTable: term, 00369 Path: str, 00370 Pid: int, 00371 Text: str, 00372 Type: term, 00373 Tree: term 00374 in 00375 snd-msg(tm-request-transaction(rscript-parsing)) 00376 . GetCachedValue(RSCRIPT_TREE_CACHE, ModuleId, Tree?) 00377 . 00378 if equal(Tree, UNDEFINED) then 00379 Type := rscript 00380 . GetModulePath(ModuleId, RSCRIPT_NAMESPACE, Path?) 00381 . ReadText(Path, Text?) 00382 . 00383 if not-equal(Text, "") then 00384 GetParseTable(ModuleId, Type, ParseTable?) 00385 . 00386 if not-equal(ParseTable, UNDEFINED) then 00387 create(ParseTreeHandler(ModuleId, Path), Pid?) 00388 . ParseText(Pid, Text, ParseTable, RSCRIPT_TOPSORT, on) 00389 . 00390 ( 00391 rec-msg(parse-handler-done(Pid, ModuleId, Tree?)) 00392 . AnnotateTree(Tree, Path, Result?) 00393 . PutCachedValue(RSCRIPT_TREE_CACHE, ModuleId, Result) 00394 + 00395 rec-msg(parse-handler-done(Pid)) 00396 . Result := UNDEFINED 00397 ) 00398 else 00399 Result := UNDEFINED 00400 fi 00401 else 00402 Result := UNDEFINED 00403 fi 00404 else 00405 Result := Tree 00406 fi 00407 . snd-msg(tm-end-transaction(rscript-parsing)) 00408 endlet 00409 00410 process RSCRIPTIdentifyModule(ModuleId: module-id, ResultStatus: term?) is 00411 let 00412 Tree: term, 00413 Path: str, 00414 Directory: str, 00415 Filename: str 00416 in 00417 GetRSCRIPTParsetree(ModuleId, Tree?) 00418 . 00419 if not-equal(Tree, UNDEFINED) then 00420 /*GetModulePath(ModuleId, RSCRIPT_NAMESPACE, Path?) 00421 . snd-msg(io-get-path-directory(Path)) 00422 . rec-msg(io-directory(Path, Directory?)) 00423 . snd-msg(sm-get-module-path(Directory, Modulename)) 00424 . rec-msg(sm-module-path(Directory?)) 00425 . BuildPath(Directory, Modulename, RSCRIPT_EXTENSION, File?) 00426 . 00427 if equal(File, Path) then 00428 MM-SetAttribute(ModuleId, RSCRIPT_NAMESPACE, "name", Modulename) 00429 . ResultStatus := identified 00430 else 00431 printf("error: Module %s should be in a file named %s\n", Modulename, File) 00432 . ResultStatus := error 00433 fi*/ 00434 GetModulePath(ModuleId, RSCRIPT_NAMESPACE, Path?) 00435 . snd-msg(io-get-path-filename(Path)) 00436 . rec-msg(io-filename(Path, Filename?)) 00437 . MM-SetAttribute(ModuleId, RSCRIPT_NAMESPACE, "name", Filename) 00438 . ResultStatus := identified 00439 else 00440 tau 00441 fi 00442 endlet 00443 00444 process RunRScript(ModuleId : module-id) is 00445 let 00446 Modulename: str, 00447 RStore: rstore, 00448 Tree: term 00449 in 00450 GetRSCRIPTParsetree(ModuleId, Tree?) 00451 . MM-GetAttribute(ModuleId, RSCRIPT_NAMESPACE, "name", Modulename?) 00452 . AddJob("Evaluating RScript...") 00453 . snd-msg(eval-rscript(Tree)) 00454 . 00455 ( 00456 rec-msg(evaluated-rscript(RStore?)) 00457 . snd-msg(rc-load-rstore(Modulename, RStore)) 00458 + 00459 rec-msg(evaluate-rscript-aborted) 00460 ) 00461 . JobDone("Evaluating RScript...") 00462 endlet 00463 00464 process RunRScriptWithRStore(ModuleId : module-id) is 00465 let 00466 Modulename: str, 00467 RStore: rstore, 00468 RStoreId: int, 00469 Tree: term 00470 in 00471 GetRSCRIPTParsetree(ModuleId, Tree?) 00472 . MM-GetAttribute(ModuleId, RSCRIPT_NAMESPACE, "name", Modulename?) 00473 . snd-msg(fb-get-selected-rstoreid) 00474 . 00475 ( 00476 rec-msg(fb-selected-rstoreid(RStoreId?)) 00477 . AddJob("Evaluating RScript...") 00478 . snd-msg(rc-get-rstore(RStoreId)) 00479 . rec-msg(rc-rstore(RStoreId, RStore?)) 00480 . snd-msg(eval-rscript-with-rstore(Tree, RStore)) 00481 . 00482 ( 00483 rec-msg(evaluated-rscript(RStore?)) 00484 . snd-msg(rc-load-rstore(Modulename, RStore)) 00485 + 00486 rec-msg(evaluate-rscript-aborted) 00487 ) 00488 . JobDone("Evaluating RScript...") 00489 + 00490 rec-msg(fb-no-rstore-selected) 00491 . snd-msg(show-message-dialog("No RStore selected")) 00492 ) 00493 endlet 00494 00495 process TestRScript(ModuleId : module-id) is 00496 let 00497 Modulename: str, 00498 Summary: summary, 00499 Tree: term 00500 in 00501 GetRSCRIPTParsetree(ModuleId, Tree?) 00502 . MM-GetAttribute(ModuleId, RSCRIPT_NAMESPACE, "name", Modulename?) 00503 . AddJob("Running RScript unit tests...") 00504 . snd-msg(eval-rscript-testsuite(Tree)) 00505 . 00506 ( 00507 rec-msg(evaluated-rscript-testsuite(Summary?)) 00508 . printf("Summary: [%t]\n", Summary) 00509 . DisplaySummary(Summary) 00510 + 00511 rec-msg(eval-rscript-testsuite-aborted) 00512 ) 00513 . JobDone("Running RScript unit tests...") 00514 endlet 00515 00516 #endif